]> git.vpit.fr Git - perl/modules/re-engine-Hooks.git/blob - src/5015006/regcomp.c
Hook convertion of branches into tries
[perl/modules/re-engine-Hooks.git] / src / 5015006 / regcomp.c
1 /*    regcomp.c
2  */
3
4 /*
5  * 'A fair jaw-cracker dwarf-language must be.'            --Samwise Gamgee
6  *
7  *     [p.285 of _The Lord of the Rings_, II/iii: "The Ring Goes South"]
8  */
9
10 /* This file contains functions for compiling a regular expression.  See
11  * also regexec.c which funnily enough, contains functions for executing
12  * a regular expression.
13  *
14  * This file is also copied at build time to ext/re/re_comp.c, where
15  * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
16  * This causes the main functions to be compiled under new names and with
17  * debugging support added, which makes "use re 'debug'" work.
18  */
19
20 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
21  * confused with the original package (see point 3 below).  Thanks, Henry!
22  */
23
24 /* Additional note: this code is very heavily munged from Henry's version
25  * in places.  In some spots I've traded clarity for efficiency, so don't
26  * blame Henry for some of the lack of readability.
27  */
28
29 /* The names of the functions have been changed from regcomp and
30  * regexec to pregcomp and pregexec in order to avoid conflicts
31  * with the POSIX routines of the same names.
32 */
33
34 #ifdef PERL_EXT_RE_BUILD
35 #include "re_top.h"
36 #endif
37
38 /*
39  * pregcomp and pregexec -- regsub and regerror are not used in perl
40  *
41  *      Copyright (c) 1986 by University of Toronto.
42  *      Written by Henry Spencer.  Not derived from licensed software.
43  *
44  *      Permission is granted to anyone to use this software for any
45  *      purpose on any computer system, and to redistribute it freely,
46  *      subject to the following restrictions:
47  *
48  *      1. The author is not responsible for the consequences of use of
49  *              this software, no matter how awful, even if they arise
50  *              from defects in it.
51  *
52  *      2. The origin of this software must not be misrepresented, either
53  *              by explicit claim or by omission.
54  *
55  *      3. Altered versions must be plainly marked as such, and must not
56  *              be misrepresented as being the original software.
57  *
58  *
59  ****    Alterations to Henry's code are...
60  ****
61  ****    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
62  ****    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
63  ****    by Larry Wall and others
64  ****
65  ****    You may distribute under the terms of either the GNU General Public
66  ****    License or the Artistic License, as specified in the README file.
67
68  *
69  * Beware that some of this code is subtly aware of the way operator
70  * precedence is structured in regular expressions.  Serious changes in
71  * regular-expression syntax might require a total rethink.
72  */
73 #include "EXTERN.h"
74 #define PERL_IN_REGCOMP_C
75 #include "perl.h"
76
77 #ifndef PERL_IN_XSUB_RE
78 #include "re_defs.h"
79 #endif
80
81 #define REG_COMP_C
82 #ifdef PERL_IN_XSUB_RE
83 #  include "re_comp.h"
84 #else
85 #  include "regcomp.h"
86 #endif
87
88 #include "dquote_static.c"
89
90 #ifdef op
91 #undef op
92 #endif /* op */
93
94 #ifdef MSDOS
95 #  if defined(BUGGY_MSC6)
96  /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
97 #    pragma optimize("a",off)
98  /* But MSC 6.00A is happy with 'w', for aliases only across function calls*/
99 #    pragma optimize("w",on )
100 #  endif /* BUGGY_MSC6 */
101 #endif /* MSDOS */
102
103 #ifndef STATIC
104 #define STATIC  static
105 #endif
106
107 typedef struct RExC_state_t {
108     U32         flags;                  /* are we folding, multilining? */
109     char        *precomp;               /* uncompiled string. */
110     REGEXP      *rx_sv;                 /* The SV that is the regexp. */
111     regexp      *rx;                    /* perl core regexp structure */
112     regexp_internal     *rxi;           /* internal data for regexp object pprivate field */        
113     char        *start;                 /* Start of input for compile */
114     char        *end;                   /* End of input for compile */
115     char        *parse;                 /* Input-scan pointer. */
116     I32         whilem_seen;            /* number of WHILEM in this expr */
117     regnode     *emit_start;            /* Start of emitted-code area */
118     regnode     *emit_bound;            /* First regnode outside of the allocated space */
119     regnode     *emit;                  /* Code-emit pointer; &regdummy = don't = compiling */
120     I32         naughty;                /* How bad is this pattern? */
121     I32         sawback;                /* Did we see \1, ...? */
122     U32         seen;
123     I32         size;                   /* Code size. */
124     I32         npar;                   /* Capture buffer count, (OPEN). */
125     I32         cpar;                   /* Capture buffer count, (CLOSE). */
126     I32         nestroot;               /* root parens we are in - used by accept */
127     I32         extralen;
128     I32         seen_zerolen;
129     I32         seen_evals;
130     regnode     **open_parens;          /* pointers to open parens */
131     regnode     **close_parens;         /* pointers to close parens */
132     regnode     *opend;                 /* END node in program */
133     I32         utf8;           /* whether the pattern is utf8 or not */
134     I32         orig_utf8;      /* whether the pattern was originally in utf8 */
135                                 /* XXX use this for future optimisation of case
136                                  * where pattern must be upgraded to utf8. */
137     I32         uni_semantics;  /* If a d charset modifier should use unicode
138                                    rules, even if the pattern is not in
139                                    utf8 */
140     HV          *paren_names;           /* Paren names */
141     
142     regnode     **recurse;              /* Recurse regops */
143     I32         recurse_count;          /* Number of recurse regops */
144     I32         in_lookbehind;
145     I32         contains_locale;
146     I32         override_recoding;
147 #if ADD_TO_REGEXEC
148     char        *starttry;              /* -Dr: where regtry was called. */
149 #define RExC_starttry   (pRExC_state->starttry)
150 #endif
151 #ifdef DEBUGGING
152     const char  *lastparse;
153     I32         lastnum;
154     AV          *paren_name_list;       /* idx -> name */
155 #define RExC_lastparse  (pRExC_state->lastparse)
156 #define RExC_lastnum    (pRExC_state->lastnum)
157 #define RExC_paren_name_list    (pRExC_state->paren_name_list)
158 #endif
159 } RExC_state_t;
160
161 #define RExC_flags      (pRExC_state->flags)
162 #define RExC_precomp    (pRExC_state->precomp)
163 #define RExC_rx_sv      (pRExC_state->rx_sv)
164 #define RExC_rx         (pRExC_state->rx)
165 #define RExC_rxi        (pRExC_state->rxi)
166 #define RExC_start      (pRExC_state->start)
167 #define RExC_end        (pRExC_state->end)
168 #define RExC_parse      (pRExC_state->parse)
169 #define RExC_whilem_seen        (pRExC_state->whilem_seen)
170 #ifdef RE_TRACK_PATTERN_OFFSETS
171 #define RExC_offsets    (pRExC_state->rxi->u.offsets) /* I am not like the others */
172 #endif
173 #define RExC_emit       (pRExC_state->emit)
174 #define RExC_emit_start (pRExC_state->emit_start)
175 #define RExC_emit_bound (pRExC_state->emit_bound)
176 #define RExC_naughty    (pRExC_state->naughty)
177 #define RExC_sawback    (pRExC_state->sawback)
178 #define RExC_seen       (pRExC_state->seen)
179 #define RExC_size       (pRExC_state->size)
180 #define RExC_npar       (pRExC_state->npar)
181 #define RExC_nestroot   (pRExC_state->nestroot)
182 #define RExC_extralen   (pRExC_state->extralen)
183 #define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
184 #define RExC_seen_evals (pRExC_state->seen_evals)
185 #define RExC_utf8       (pRExC_state->utf8)
186 #define RExC_uni_semantics      (pRExC_state->uni_semantics)
187 #define RExC_orig_utf8  (pRExC_state->orig_utf8)
188 #define RExC_open_parens        (pRExC_state->open_parens)
189 #define RExC_close_parens       (pRExC_state->close_parens)
190 #define RExC_opend      (pRExC_state->opend)
191 #define RExC_paren_names        (pRExC_state->paren_names)
192 #define RExC_recurse    (pRExC_state->recurse)
193 #define RExC_recurse_count      (pRExC_state->recurse_count)
194 #define RExC_in_lookbehind      (pRExC_state->in_lookbehind)
195 #define RExC_contains_locale    (pRExC_state->contains_locale)
196 #define RExC_override_recoding  (pRExC_state->override_recoding)
197
198
199 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
200 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
201         ((*s) == '{' && regcurly(s)))
202
203 #ifdef SPSTART
204 #undef SPSTART          /* dratted cpp namespace... */
205 #endif
206 /*
207  * Flags to be passed up and down.
208  */
209 #define WORST           0       /* Worst case. */
210 #define HASWIDTH        0x01    /* Known to match non-null strings. */
211
212 /* Simple enough to be STAR/PLUS operand, in an EXACT node must be a single
213  * character, and if utf8, must be invariant.  Note that this is not the same thing as REGNODE_SIMPLE */
214 #define SIMPLE          0x02
215 #define SPSTART         0x04    /* Starts with * or +. */
216 #define TRYAGAIN        0x08    /* Weeded out a declaration. */
217 #define POSTPONED       0x10    /* (?1),(?&name), (??{...}) or similar */
218
219 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
220
221 /* whether trie related optimizations are enabled */
222 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
223 #define TRIE_STUDY_OPT
224 #define FULL_TRIE_STUDY
225 #define TRIE_STCLASS
226 #endif
227
228
229
230 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
231 #define PBITVAL(paren) (1 << ((paren) & 7))
232 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
233 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
234 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
235
236 /* If not already in utf8, do a longjmp back to the beginning */
237 #define UTF8_LONGJMP 42 /* Choose a value not likely to ever conflict */
238 #define REQUIRE_UTF8    STMT_START {                                       \
239                                      if (! UTF) JMPENV_JUMP(UTF8_LONGJMP); \
240                         } STMT_END
241
242 /* About scan_data_t.
243
244   During optimisation we recurse through the regexp program performing
245   various inplace (keyhole style) optimisations. In addition study_chunk
246   and scan_commit populate this data structure with information about
247   what strings MUST appear in the pattern. We look for the longest 
248   string that must appear at a fixed location, and we look for the
249   longest string that may appear at a floating location. So for instance
250   in the pattern:
251   
252     /FOO[xX]A.*B[xX]BAR/
253     
254   Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
255   strings (because they follow a .* construct). study_chunk will identify
256   both FOO and BAR as being the longest fixed and floating strings respectively.
257   
258   The strings can be composites, for instance
259   
260      /(f)(o)(o)/
261      
262   will result in a composite fixed substring 'foo'.
263   
264   For each string some basic information is maintained:
265   
266   - offset or min_offset
267     This is the position the string must appear at, or not before.
268     It also implicitly (when combined with minlenp) tells us how many
269     characters must match before the string we are searching for.
270     Likewise when combined with minlenp and the length of the string it
271     tells us how many characters must appear after the string we have 
272     found.
273   
274   - max_offset
275     Only used for floating strings. This is the rightmost point that
276     the string can appear at. If set to I32 max it indicates that the
277     string can occur infinitely far to the right.
278   
279   - minlenp
280     A pointer to the minimum length of the pattern that the string 
281     was found inside. This is important as in the case of positive 
282     lookahead or positive lookbehind we can have multiple patterns 
283     involved. Consider
284     
285     /(?=FOO).*F/
286     
287     The minimum length of the pattern overall is 3, the minimum length
288     of the lookahead part is 3, but the minimum length of the part that
289     will actually match is 1. So 'FOO's minimum length is 3, but the 
290     minimum length for the F is 1. This is important as the minimum length
291     is used to determine offsets in front of and behind the string being 
292     looked for.  Since strings can be composites this is the length of the
293     pattern at the time it was committed with a scan_commit. Note that
294     the length is calculated by study_chunk, so that the minimum lengths
295     are not known until the full pattern has been compiled, thus the 
296     pointer to the value.
297   
298   - lookbehind
299   
300     In the case of lookbehind the string being searched for can be
301     offset past the start point of the final matching string. 
302     If this value was just blithely removed from the min_offset it would
303     invalidate some of the calculations for how many chars must match
304     before or after (as they are derived from min_offset and minlen and
305     the length of the string being searched for). 
306     When the final pattern is compiled and the data is moved from the
307     scan_data_t structure into the regexp structure the information
308     about lookbehind is factored in, with the information that would 
309     have been lost precalculated in the end_shift field for the 
310     associated string.
311
312   The fields pos_min and pos_delta are used to store the minimum offset
313   and the delta to the maximum offset at the current point in the pattern.    
314
315 */
316
317 typedef struct scan_data_t {
318     /*I32 len_min;      unused */
319     /*I32 len_delta;    unused */
320     I32 pos_min;
321     I32 pos_delta;
322     SV *last_found;
323     I32 last_end;           /* min value, <0 unless valid. */
324     I32 last_start_min;
325     I32 last_start_max;
326     SV **longest;           /* Either &l_fixed, or &l_float. */
327     SV *longest_fixed;      /* longest fixed string found in pattern */
328     I32 offset_fixed;       /* offset where it starts */
329     I32 *minlen_fixed;      /* pointer to the minlen relevant to the string */
330     I32 lookbehind_fixed;   /* is the position of the string modfied by LB */
331     SV *longest_float;      /* longest floating string found in pattern */
332     I32 offset_float_min;   /* earliest point in string it can appear */
333     I32 offset_float_max;   /* latest point in string it can appear */
334     I32 *minlen_float;      /* pointer to the minlen relevant to the string */
335     I32 lookbehind_float;   /* is the position of the string modified by LB */
336     I32 flags;
337     I32 whilem_c;
338     I32 *last_closep;
339     struct regnode_charclass_class *start_class;
340 } scan_data_t;
341
342 /*
343  * Forward declarations for pregcomp()'s friends.
344  */
345
346 static const scan_data_t zero_scan_data =
347   { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,0};
348
349 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
350 #define SF_BEFORE_SEOL          0x0001
351 #define SF_BEFORE_MEOL          0x0002
352 #define SF_FIX_BEFORE_EOL       (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
353 #define SF_FL_BEFORE_EOL        (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
354
355 #ifdef NO_UNARY_PLUS
356 #  define SF_FIX_SHIFT_EOL      (0+2)
357 #  define SF_FL_SHIFT_EOL               (0+4)
358 #else
359 #  define SF_FIX_SHIFT_EOL      (+2)
360 #  define SF_FL_SHIFT_EOL               (+4)
361 #endif
362
363 #define SF_FIX_BEFORE_SEOL      (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
364 #define SF_FIX_BEFORE_MEOL      (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
365
366 #define SF_FL_BEFORE_SEOL       (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
367 #define SF_FL_BEFORE_MEOL       (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
368 #define SF_IS_INF               0x0040
369 #define SF_HAS_PAR              0x0080
370 #define SF_IN_PAR               0x0100
371 #define SF_HAS_EVAL             0x0200
372 #define SCF_DO_SUBSTR           0x0400
373 #define SCF_DO_STCLASS_AND      0x0800
374 #define SCF_DO_STCLASS_OR       0x1000
375 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
376 #define SCF_WHILEM_VISITED_POS  0x2000
377
378 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
379 #define SCF_SEEN_ACCEPT         0x8000 
380
381 #define UTF cBOOL(RExC_utf8)
382 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
383 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
384 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_DEPENDS_CHARSET)
385 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags) >= REGEX_UNICODE_CHARSET)
386 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_RESTRICTED_CHARSET)
387 #define MORE_ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
388 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags) >= REGEX_ASCII_RESTRICTED_CHARSET)
389
390 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
391
392 #define OOB_UNICODE             12345678
393 #define OOB_NAMEDCLASS          -1
394
395 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
396 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
397
398
399 /* length of regex to show in messages that don't mark a position within */
400 #define RegexLengthToShowInErrorMessages 127
401
402 /*
403  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
404  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
405  * op/pragma/warn/regcomp.
406  */
407 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
408 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
409
410 #define REPORT_LOCATION " in regex; marked by " MARKER1 " in m/%.*s" MARKER2 "%s/"
411
412 /*
413  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
414  * arg. Show regex, up to a maximum length. If it's too long, chop and add
415  * "...".
416  */
417 #define _FAIL(code) STMT_START {                                        \
418     const char *ellipses = "";                                          \
419     IV len = RExC_end - RExC_precomp;                                   \
420                                                                         \
421     if (!SIZE_ONLY)                                                     \
422         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv);                   \
423     if (len > RegexLengthToShowInErrorMessages) {                       \
424         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
425         len = RegexLengthToShowInErrorMessages - 10;                    \
426         ellipses = "...";                                               \
427     }                                                                   \
428     code;                                                               \
429 } STMT_END
430
431 #define FAIL(msg) _FAIL(                            \
432     Perl_croak(aTHX_ "%s in regex m/%.*s%s/",       \
433             msg, (int)len, RExC_precomp, ellipses))
434
435 #define FAIL2(msg,arg) _FAIL(                       \
436     Perl_croak(aTHX_ msg " in regex m/%.*s%s/",     \
437             arg, (int)len, RExC_precomp, ellipses))
438
439 /*
440  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
441  */
442 #define Simple_vFAIL(m) STMT_START {                                    \
443     const IV offset = RExC_parse - RExC_precomp;                        \
444     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
445             m, (int)offset, RExC_precomp, RExC_precomp + offset);       \
446 } STMT_END
447
448 /*
449  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
450  */
451 #define vFAIL(m) STMT_START {                           \
452     if (!SIZE_ONLY)                                     \
453         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv);   \
454     Simple_vFAIL(m);                                    \
455 } STMT_END
456
457 /*
458  * Like Simple_vFAIL(), but accepts two arguments.
459  */
460 #define Simple_vFAIL2(m,a1) STMT_START {                        \
461     const IV offset = RExC_parse - RExC_precomp;                        \
462     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1,                   \
463             (int)offset, RExC_precomp, RExC_precomp + offset);  \
464 } STMT_END
465
466 /*
467  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
468  */
469 #define vFAIL2(m,a1) STMT_START {                       \
470     if (!SIZE_ONLY)                                     \
471         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv);   \
472     Simple_vFAIL2(m, a1);                               \
473 } STMT_END
474
475
476 /*
477  * Like Simple_vFAIL(), but accepts three arguments.
478  */
479 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
480     const IV offset = RExC_parse - RExC_precomp;                \
481     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2,               \
482             (int)offset, RExC_precomp, RExC_precomp + offset);  \
483 } STMT_END
484
485 /*
486  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
487  */
488 #define vFAIL3(m,a1,a2) STMT_START {                    \
489     if (!SIZE_ONLY)                                     \
490         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv);   \
491     Simple_vFAIL3(m, a1, a2);                           \
492 } STMT_END
493
494 /*
495  * Like Simple_vFAIL(), but accepts four arguments.
496  */
497 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
498     const IV offset = RExC_parse - RExC_precomp;                \
499     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3,           \
500             (int)offset, RExC_precomp, RExC_precomp + offset);  \
501 } STMT_END
502
503 #define ckWARNreg(loc,m) STMT_START {                                   \
504     const IV offset = loc - RExC_precomp;                               \
505     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
506             (int)offset, RExC_precomp, RExC_precomp + offset);          \
507 } STMT_END
508
509 #define ckWARNregdep(loc,m) STMT_START {                                \
510     const IV offset = loc - RExC_precomp;                               \
511     Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP),     \
512             m REPORT_LOCATION,                                          \
513             (int)offset, RExC_precomp, RExC_precomp + offset);          \
514 } STMT_END
515
516 #define ckWARN2regdep(loc,m, a1) STMT_START {                           \
517     const IV offset = loc - RExC_precomp;                               \
518     Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP),     \
519             m REPORT_LOCATION,                                          \
520             a1, (int)offset, RExC_precomp, RExC_precomp + offset);      \
521 } STMT_END
522
523 #define ckWARN2reg(loc, m, a1) STMT_START {                             \
524     const IV offset = loc - RExC_precomp;                               \
525     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
526             a1, (int)offset, RExC_precomp, RExC_precomp + offset);      \
527 } STMT_END
528
529 #define vWARN3(loc, m, a1, a2) STMT_START {                             \
530     const IV offset = loc - RExC_precomp;                               \
531     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
532             a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset);  \
533 } STMT_END
534
535 #define ckWARN3reg(loc, m, a1, a2) STMT_START {                         \
536     const IV offset = loc - RExC_precomp;                               \
537     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
538             a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset);  \
539 } STMT_END
540
541 #define vWARN4(loc, m, a1, a2, a3) STMT_START {                         \
542     const IV offset = loc - RExC_precomp;                               \
543     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
544             a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
545 } STMT_END
546
547 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START {                     \
548     const IV offset = loc - RExC_precomp;                               \
549     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
550             a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
551 } STMT_END
552
553 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {                     \
554     const IV offset = loc - RExC_precomp;                               \
555     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
556             a1, a2, a3, a4, (int)offset, RExC_precomp, RExC_precomp + offset); \
557 } STMT_END
558
559
560 /* Allow for side effects in s */
561 #define REGC(c,s) STMT_START {                  \
562     if (!SIZE_ONLY) *(s) = (c); else (void)(s); \
563 } STMT_END
564
565 /* Macros for recording node offsets.   20001227 mjd@plover.com 
566  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
567  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
568  * Element 0 holds the number n.
569  * Position is 1 indexed.
570  */
571 #ifndef RE_TRACK_PATTERN_OFFSETS
572 #define Set_Node_Offset_To_R(node,byte)
573 #define Set_Node_Offset(node,byte)
574 #define Set_Cur_Node_Offset
575 #define Set_Node_Length_To_R(node,len)
576 #define Set_Node_Length(node,len)
577 #define Set_Node_Cur_Length(node)
578 #define Node_Offset(n) 
579 #define Node_Length(n) 
580 #define Set_Node_Offset_Length(node,offset,len)
581 #define ProgLen(ri) ri->u.proglen
582 #define SetProgLen(ri,x) ri->u.proglen = x
583 #else
584 #define ProgLen(ri) ri->u.offsets[0]
585 #define SetProgLen(ri,x) ri->u.offsets[0] = x
586 #define Set_Node_Offset_To_R(node,byte) STMT_START {                    \
587     if (! SIZE_ONLY) {                                                  \
588         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
589                     __LINE__, (int)(node), (int)(byte)));               \
590         if((node) < 0) {                                                \
591             Perl_croak(aTHX_ "value of node is %d in Offset macro", (int)(node)); \
592         } else {                                                        \
593             RExC_offsets[2*(node)-1] = (byte);                          \
594         }                                                               \
595     }                                                                   \
596 } STMT_END
597
598 #define Set_Node_Offset(node,byte) \
599     Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
600 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
601
602 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
603     if (! SIZE_ONLY) {                                                  \
604         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
605                 __LINE__, (int)(node), (int)(len)));                    \
606         if((node) < 0) {                                                \
607             Perl_croak(aTHX_ "value of node is %d in Length macro", (int)(node)); \
608         } else {                                                        \
609             RExC_offsets[2*(node)] = (len);                             \
610         }                                                               \
611     }                                                                   \
612 } STMT_END
613
614 #define Set_Node_Length(node,len) \
615     Set_Node_Length_To_R((node)-RExC_emit_start, len)
616 #define Set_Cur_Node_Length(len) Set_Node_Length(RExC_emit, len)
617 #define Set_Node_Cur_Length(node) \
618     Set_Node_Length(node, RExC_parse - parse_start)
619
620 /* Get offsets and lengths */
621 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
622 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
623
624 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
625     Set_Node_Offset_To_R((node)-RExC_emit_start, (offset));     \
626     Set_Node_Length_To_R((node)-RExC_emit_start, (len));        \
627 } STMT_END
628 #endif
629
630 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
631 #define EXPERIMENTAL_INPLACESCAN
632 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
633
634 #define DEBUG_STUDYDATA(str,data,depth)                              \
635 DEBUG_OPTIMISE_MORE_r(if(data){                                      \
636     PerlIO_printf(Perl_debug_log,                                    \
637         "%*s" str "Pos:%"IVdf"/%"IVdf                                \
638         " Flags: 0x%"UVXf" Whilem_c: %"IVdf" Lcp: %"IVdf" %s",       \
639         (int)(depth)*2, "",                                          \
640         (IV)((data)->pos_min),                                       \
641         (IV)((data)->pos_delta),                                     \
642         (UV)((data)->flags),                                         \
643         (IV)((data)->whilem_c),                                      \
644         (IV)((data)->last_closep ? *((data)->last_closep) : -1),     \
645         is_inf ? "INF " : ""                                         \
646     );                                                               \
647     if ((data)->last_found)                                          \
648         PerlIO_printf(Perl_debug_log,                                \
649             "Last:'%s' %"IVdf":%"IVdf"/%"IVdf" %sFixed:'%s' @ %"IVdf \
650             " %sFloat: '%s' @ %"IVdf"/%"IVdf"",                      \
651             SvPVX_const((data)->last_found),                         \
652             (IV)((data)->last_end),                                  \
653             (IV)((data)->last_start_min),                            \
654             (IV)((data)->last_start_max),                            \
655             ((data)->longest &&                                      \
656              (data)->longest==&((data)->longest_fixed)) ? "*" : "",  \
657             SvPVX_const((data)->longest_fixed),                      \
658             (IV)((data)->offset_fixed),                              \
659             ((data)->longest &&                                      \
660              (data)->longest==&((data)->longest_float)) ? "*" : "",  \
661             SvPVX_const((data)->longest_float),                      \
662             (IV)((data)->offset_float_min),                          \
663             (IV)((data)->offset_float_max)                           \
664         );                                                           \
665     PerlIO_printf(Perl_debug_log,"\n");                              \
666 });
667
668 static void clear_re(pTHX_ void *r);
669
670 /* Mark that we cannot extend a found fixed substring at this point.
671    Update the longest found anchored substring and the longest found
672    floating substrings if needed. */
673
674 STATIC void
675 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, I32 *minlenp, int is_inf)
676 {
677     const STRLEN l = CHR_SVLEN(data->last_found);
678     const STRLEN old_l = CHR_SVLEN(*data->longest);
679     GET_RE_DEBUG_FLAGS_DECL;
680
681     PERL_ARGS_ASSERT_SCAN_COMMIT;
682
683     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
684         SvSetMagicSV(*data->longest, data->last_found);
685         if (*data->longest == data->longest_fixed) {
686             data->offset_fixed = l ? data->last_start_min : data->pos_min;
687             if (data->flags & SF_BEFORE_EOL)
688                 data->flags
689                     |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
690             else
691                 data->flags &= ~SF_FIX_BEFORE_EOL;
692             data->minlen_fixed=minlenp; 
693             data->lookbehind_fixed=0;
694         }
695         else { /* *data->longest == data->longest_float */
696             data->offset_float_min = l ? data->last_start_min : data->pos_min;
697             data->offset_float_max = (l
698                                       ? data->last_start_max
699                                       : data->pos_min + data->pos_delta);
700             if (is_inf || (U32)data->offset_float_max > (U32)I32_MAX)
701                 data->offset_float_max = I32_MAX;
702             if (data->flags & SF_BEFORE_EOL)
703                 data->flags
704                     |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
705             else
706                 data->flags &= ~SF_FL_BEFORE_EOL;
707             data->minlen_float=minlenp;
708             data->lookbehind_float=0;
709         }
710     }
711     SvCUR_set(data->last_found, 0);
712     {
713         SV * const sv = data->last_found;
714         if (SvUTF8(sv) && SvMAGICAL(sv)) {
715             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
716             if (mg)
717                 mg->mg_len = 0;
718         }
719     }
720     data->last_end = -1;
721     data->flags &= ~SF_BEFORE_EOL;
722     DEBUG_STUDYDATA("commit: ",data,0);
723 }
724
725 /* Can match anything (initialization) */
726 STATIC void
727 S_cl_anything(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
728 {
729     PERL_ARGS_ASSERT_CL_ANYTHING;
730
731     ANYOF_BITMAP_SETALL(cl);
732     cl->flags = ANYOF_CLASS|ANYOF_EOS|ANYOF_UNICODE_ALL
733                 |ANYOF_LOC_NONBITMAP_FOLD|ANYOF_NON_UTF8_LATIN1_ALL;
734
735     /* If any portion of the regex is to operate under locale rules,
736      * initialization includes it.  The reason this isn't done for all regexes
737      * is that the optimizer was written under the assumption that locale was
738      * all-or-nothing.  Given the complexity and lack of documentation in the
739      * optimizer, and that there are inadequate test cases for locale, so many
740      * parts of it may not work properly, it is safest to avoid locale unless
741      * necessary. */
742     if (RExC_contains_locale) {
743         ANYOF_CLASS_SETALL(cl);     /* /l uses class */
744         cl->flags |= ANYOF_LOCALE;
745     }
746     else {
747         ANYOF_CLASS_ZERO(cl);       /* Only /l uses class now */
748     }
749 }
750
751 /* Can match anything (initialization) */
752 STATIC int
753 S_cl_is_anything(const struct regnode_charclass_class *cl)
754 {
755     int value;
756
757     PERL_ARGS_ASSERT_CL_IS_ANYTHING;
758
759     for (value = 0; value <= ANYOF_MAX; value += 2)
760         if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
761             return 1;
762     if (!(cl->flags & ANYOF_UNICODE_ALL))
763         return 0;
764     if (!ANYOF_BITMAP_TESTALLSET((const void*)cl))
765         return 0;
766     return 1;
767 }
768
769 /* Can match anything (initialization) */
770 STATIC void
771 S_cl_init(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
772 {
773     PERL_ARGS_ASSERT_CL_INIT;
774
775     Zero(cl, 1, struct regnode_charclass_class);
776     cl->type = ANYOF;
777     cl_anything(pRExC_state, cl);
778     ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
779 }
780
781 /* These two functions currently do the exact same thing */
782 #define cl_init_zero            S_cl_init
783
784 /* 'AND' a given class with another one.  Can create false positives.  'cl'
785  * should not be inverted.  'and_with->flags & ANYOF_CLASS' should be 0 if
786  * 'and_with' is a regnode_charclass instead of a regnode_charclass_class. */
787 STATIC void
788 S_cl_and(struct regnode_charclass_class *cl,
789         const struct regnode_charclass_class *and_with)
790 {
791     PERL_ARGS_ASSERT_CL_AND;
792
793     assert(and_with->type == ANYOF);
794
795     /* I (khw) am not sure all these restrictions are necessary XXX */
796     if (!(ANYOF_CLASS_TEST_ANY_SET(and_with))
797         && !(ANYOF_CLASS_TEST_ANY_SET(cl))
798         && (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
799         && !(and_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
800         && !(cl->flags & ANYOF_LOC_NONBITMAP_FOLD)) {
801         int i;
802
803         if (and_with->flags & ANYOF_INVERT)
804             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
805                 cl->bitmap[i] &= ~and_with->bitmap[i];
806         else
807             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
808                 cl->bitmap[i] &= and_with->bitmap[i];
809     } /* XXXX: logic is complicated otherwise, leave it along for a moment. */
810
811     if (and_with->flags & ANYOF_INVERT) {
812
813         /* Here, the and'ed node is inverted.  Get the AND of the flags that
814          * aren't affected by the inversion.  Those that are affected are
815          * handled individually below */
816         U8 affected_flags = cl->flags & ~INVERSION_UNAFFECTED_FLAGS;
817         cl->flags &= (and_with->flags & INVERSION_UNAFFECTED_FLAGS);
818         cl->flags |= affected_flags;
819
820         /* We currently don't know how to deal with things that aren't in the
821          * bitmap, but we know that the intersection is no greater than what
822          * is already in cl, so let there be false positives that get sorted
823          * out after the synthetic start class succeeds, and the node is
824          * matched for real. */
825
826         /* The inversion of these two flags indicate that the resulting
827          * intersection doesn't have them */
828         if (and_with->flags & ANYOF_UNICODE_ALL) {
829             cl->flags &= ~ANYOF_UNICODE_ALL;
830         }
831         if (and_with->flags & ANYOF_NON_UTF8_LATIN1_ALL) {
832             cl->flags &= ~ANYOF_NON_UTF8_LATIN1_ALL;
833         }
834     }
835     else {   /* and'd node is not inverted */
836         U8 outside_bitmap_but_not_utf8; /* Temp variable */
837
838         if (! ANYOF_NONBITMAP(and_with)) {
839
840             /* Here 'and_with' doesn't match anything outside the bitmap
841              * (except possibly ANYOF_UNICODE_ALL), which means the
842              * intersection can't either, except for ANYOF_UNICODE_ALL, in
843              * which case we don't know what the intersection is, but it's no
844              * greater than what cl already has, so can just leave it alone,
845              * with possible false positives */
846             if (! (and_with->flags & ANYOF_UNICODE_ALL)) {
847                 ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
848                 cl->flags &= ~ANYOF_NONBITMAP_NON_UTF8;
849             }
850         }
851         else if (! ANYOF_NONBITMAP(cl)) {
852
853             /* Here, 'and_with' does match something outside the bitmap, and cl
854              * doesn't have a list of things to match outside the bitmap.  If
855              * cl can match all code points above 255, the intersection will
856              * be those above-255 code points that 'and_with' matches.  If cl
857              * can't match all Unicode code points, it means that it can't
858              * match anything outside the bitmap (since the 'if' that got us
859              * into this block tested for that), so we leave the bitmap empty.
860              */
861             if (cl->flags & ANYOF_UNICODE_ALL) {
862                 ARG_SET(cl, ARG(and_with));
863
864                 /* and_with's ARG may match things that don't require UTF8.
865                  * And now cl's will too, in spite of this being an 'and'.  See
866                  * the comments below about the kludge */
867                 cl->flags |= and_with->flags & ANYOF_NONBITMAP_NON_UTF8;
868             }
869         }
870         else {
871             /* Here, both 'and_with' and cl match something outside the
872              * bitmap.  Currently we do not do the intersection, so just match
873              * whatever cl had at the beginning.  */
874         }
875
876
877         /* Take the intersection of the two sets of flags.  However, the
878          * ANYOF_NONBITMAP_NON_UTF8 flag is treated as an 'or'.  This is a
879          * kludge around the fact that this flag is not treated like the others
880          * which are initialized in cl_anything().  The way the optimizer works
881          * is that the synthetic start class (SSC) is initialized to match
882          * anything, and then the first time a real node is encountered, its
883          * values are AND'd with the SSC's with the result being the values of
884          * the real node.  However, there are paths through the optimizer where
885          * the AND never gets called, so those initialized bits are set
886          * inappropriately, which is not usually a big deal, as they just cause
887          * false positives in the SSC, which will just mean a probably
888          * imperceptible slow down in execution.  However this bit has a
889          * higher false positive consequence in that it can cause utf8.pm,
890          * utf8_heavy.pl ... to be loaded when not necessary, which is a much
891          * bigger slowdown and also causes significant extra memory to be used.
892          * In order to prevent this, the code now takes a different tack.  The
893          * bit isn't set unless some part of the regular expression needs it,
894          * but once set it won't get cleared.  This means that these extra
895          * modules won't get loaded unless there was some path through the
896          * pattern that would have required them anyway, and  so any false
897          * positives that occur by not ANDing them out when they could be
898          * aren't as severe as they would be if we treated this bit like all
899          * the others */
900         outside_bitmap_but_not_utf8 = (cl->flags | and_with->flags)
901                                       & ANYOF_NONBITMAP_NON_UTF8;
902         cl->flags &= and_with->flags;
903         cl->flags |= outside_bitmap_but_not_utf8;
904     }
905 }
906
907 /* 'OR' a given class with another one.  Can create false positives.  'cl'
908  * should not be inverted.  'or_with->flags & ANYOF_CLASS' should be 0 if
909  * 'or_with' is a regnode_charclass instead of a regnode_charclass_class. */
910 STATIC void
911 S_cl_or(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, const struct regnode_charclass_class *or_with)
912 {
913     PERL_ARGS_ASSERT_CL_OR;
914
915     if (or_with->flags & ANYOF_INVERT) {
916
917         /* Here, the or'd node is to be inverted.  This means we take the
918          * complement of everything not in the bitmap, but currently we don't
919          * know what that is, so give up and match anything */
920         if (ANYOF_NONBITMAP(or_with)) {
921             cl_anything(pRExC_state, cl);
922         }
923         /* We do not use
924          * (B1 | CL1) | (!B2 & !CL2) = (B1 | !B2 & !CL2) | (CL1 | (!B2 & !CL2))
925          *   <= (B1 | !B2) | (CL1 | !CL2)
926          * which is wasteful if CL2 is small, but we ignore CL2:
927          *   (B1 | CL1) | (!B2 & !CL2) <= (B1 | CL1) | !B2 = (B1 | !B2) | CL1
928          * XXXX Can we handle case-fold?  Unclear:
929          *   (OK1(i) | OK1(i')) | !(OK1(i) | OK1(i')) =
930          *   (OK1(i) | OK1(i')) | (!OK1(i) & !OK1(i'))
931          */
932         else if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
933              && !(or_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
934              && !(cl->flags & ANYOF_LOC_NONBITMAP_FOLD) ) {
935             int i;
936
937             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
938                 cl->bitmap[i] |= ~or_with->bitmap[i];
939         } /* XXXX: logic is complicated otherwise */
940         else {
941             cl_anything(pRExC_state, cl);
942         }
943
944         /* And, we can just take the union of the flags that aren't affected
945          * by the inversion */
946         cl->flags |= or_with->flags & INVERSION_UNAFFECTED_FLAGS;
947
948         /* For the remaining flags:
949             ANYOF_UNICODE_ALL and inverted means to not match anything above
950                     255, which means that the union with cl should just be
951                     what cl has in it, so can ignore this flag
952             ANYOF_NON_UTF8_LATIN1_ALL and inverted means if not utf8 and ord
953                     is 127-255 to match them, but then invert that, so the
954                     union with cl should just be what cl has in it, so can
955                     ignore this flag
956          */
957     } else {    /* 'or_with' is not inverted */
958         /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
959         if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
960              && (!(or_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
961                  || (cl->flags & ANYOF_LOC_NONBITMAP_FOLD)) ) {
962             int i;
963
964             /* OR char bitmap and class bitmap separately */
965             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
966                 cl->bitmap[i] |= or_with->bitmap[i];
967             if (ANYOF_CLASS_TEST_ANY_SET(or_with)) {
968                 for (i = 0; i < ANYOF_CLASSBITMAP_SIZE; i++)
969                     cl->classflags[i] |= or_with->classflags[i];
970                 cl->flags |= ANYOF_CLASS;
971             }
972         }
973         else { /* XXXX: logic is complicated, leave it along for a moment. */
974             cl_anything(pRExC_state, cl);
975         }
976
977         if (ANYOF_NONBITMAP(or_with)) {
978
979             /* Use the added node's outside-the-bit-map match if there isn't a
980              * conflict.  If there is a conflict (both nodes match something
981              * outside the bitmap, but what they match outside is not the same
982              * pointer, and hence not easily compared until XXX we extend
983              * inversion lists this far), give up and allow the start class to
984              * match everything outside the bitmap.  If that stuff is all above
985              * 255, can just set UNICODE_ALL, otherwise caould be anything. */
986             if (! ANYOF_NONBITMAP(cl)) {
987                 ARG_SET(cl, ARG(or_with));
988             }
989             else if (ARG(cl) != ARG(or_with)) {
990
991                 if ((or_with->flags & ANYOF_NONBITMAP_NON_UTF8)) {
992                     cl_anything(pRExC_state, cl);
993                 }
994                 else {
995                     cl->flags |= ANYOF_UNICODE_ALL;
996                 }
997             }
998         }
999
1000         /* Take the union */
1001         cl->flags |= or_with->flags;
1002     }
1003 }
1004
1005 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
1006 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
1007 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
1008 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list ? (TRIE_LIST_CUR( idx ) - 1) : 0 )
1009
1010
1011 #ifdef DEBUGGING
1012 /*
1013    dump_trie(trie,widecharmap,revcharmap)
1014    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
1015    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
1016
1017    These routines dump out a trie in a somewhat readable format.
1018    The _interim_ variants are used for debugging the interim
1019    tables that are used to generate the final compressed
1020    representation which is what dump_trie expects.
1021
1022    Part of the reason for their existence is to provide a form
1023    of documentation as to how the different representations function.
1024
1025 */
1026
1027 /*
1028   Dumps the final compressed table form of the trie to Perl_debug_log.
1029   Used for debugging make_trie().
1030 */
1031
1032 STATIC void
1033 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
1034             AV *revcharmap, U32 depth)
1035 {
1036     U32 state;
1037     SV *sv=sv_newmortal();
1038     int colwidth= widecharmap ? 6 : 4;
1039     U16 word;
1040     GET_RE_DEBUG_FLAGS_DECL;
1041
1042     PERL_ARGS_ASSERT_DUMP_TRIE;
1043
1044     PerlIO_printf( Perl_debug_log, "%*sChar : %-6s%-6s%-4s ",
1045         (int)depth * 2 + 2,"",
1046         "Match","Base","Ofs" );
1047
1048     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
1049         SV ** const tmp = av_fetch( revcharmap, state, 0);
1050         if ( tmp ) {
1051             PerlIO_printf( Perl_debug_log, "%*s", 
1052                 colwidth,
1053                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1054                             PL_colors[0], PL_colors[1],
1055                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1056                             PERL_PV_ESCAPE_FIRSTCHAR 
1057                 ) 
1058             );
1059         }
1060     }
1061     PerlIO_printf( Perl_debug_log, "\n%*sState|-----------------------",
1062         (int)depth * 2 + 2,"");
1063
1064     for( state = 0 ; state < trie->uniquecharcount ; state++ )
1065         PerlIO_printf( Perl_debug_log, "%.*s", colwidth, "--------");
1066     PerlIO_printf( Perl_debug_log, "\n");
1067
1068     for( state = 1 ; state < trie->statecount ; state++ ) {
1069         const U32 base = trie->states[ state ].trans.base;
1070
1071         PerlIO_printf( Perl_debug_log, "%*s#%4"UVXf"|", (int)depth * 2 + 2,"", (UV)state);
1072
1073         if ( trie->states[ state ].wordnum ) {
1074             PerlIO_printf( Perl_debug_log, " W%4X", trie->states[ state ].wordnum );
1075         } else {
1076             PerlIO_printf( Perl_debug_log, "%6s", "" );
1077         }
1078
1079         PerlIO_printf( Perl_debug_log, " @%4"UVXf" ", (UV)base );
1080
1081         if ( base ) {
1082             U32 ofs = 0;
1083
1084             while( ( base + ofs  < trie->uniquecharcount ) ||
1085                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
1086                      && trie->trans[ base + ofs - trie->uniquecharcount ].check != state))
1087                     ofs++;
1088
1089             PerlIO_printf( Perl_debug_log, "+%2"UVXf"[ ", (UV)ofs);
1090
1091             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
1092                 if ( ( base + ofs >= trie->uniquecharcount ) &&
1093                      ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
1094                      trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
1095                 {
1096                    PerlIO_printf( Perl_debug_log, "%*"UVXf,
1097                     colwidth,
1098                     (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next );
1099                 } else {
1100                     PerlIO_printf( Perl_debug_log, "%*s",colwidth,"   ." );
1101                 }
1102             }
1103
1104             PerlIO_printf( Perl_debug_log, "]");
1105
1106         }
1107         PerlIO_printf( Perl_debug_log, "\n" );
1108     }
1109     PerlIO_printf(Perl_debug_log, "%*sword_info N:(prev,len)=", (int)depth*2, "");
1110     for (word=1; word <= trie->wordcount; word++) {
1111         PerlIO_printf(Perl_debug_log, " %d:(%d,%d)",
1112             (int)word, (int)(trie->wordinfo[word].prev),
1113             (int)(trie->wordinfo[word].len));
1114     }
1115     PerlIO_printf(Perl_debug_log, "\n" );
1116 }    
1117 /*
1118   Dumps a fully constructed but uncompressed trie in list form.
1119   List tries normally only are used for construction when the number of 
1120   possible chars (trie->uniquecharcount) is very high.
1121   Used for debugging make_trie().
1122 */
1123 STATIC void
1124 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
1125                          HV *widecharmap, AV *revcharmap, U32 next_alloc,
1126                          U32 depth)
1127 {
1128     U32 state;
1129     SV *sv=sv_newmortal();
1130     int colwidth= widecharmap ? 6 : 4;
1131     GET_RE_DEBUG_FLAGS_DECL;
1132
1133     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
1134
1135     /* print out the table precompression.  */
1136     PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s%s",
1137         (int)depth * 2 + 2,"", (int)depth * 2 + 2,"",
1138         "------:-----+-----------------\n" );
1139     
1140     for( state=1 ; state < next_alloc ; state ++ ) {
1141         U16 charid;
1142     
1143         PerlIO_printf( Perl_debug_log, "%*s %4"UVXf" :",
1144             (int)depth * 2 + 2,"", (UV)state  );
1145         if ( ! trie->states[ state ].wordnum ) {
1146             PerlIO_printf( Perl_debug_log, "%5s| ","");
1147         } else {
1148             PerlIO_printf( Perl_debug_log, "W%4x| ",
1149                 trie->states[ state ].wordnum
1150             );
1151         }
1152         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
1153             SV ** const tmp = av_fetch( revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0);
1154             if ( tmp ) {
1155                 PerlIO_printf( Perl_debug_log, "%*s:%3X=%4"UVXf" | ",
1156                     colwidth,
1157                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1158                             PL_colors[0], PL_colors[1],
1159                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1160                             PERL_PV_ESCAPE_FIRSTCHAR 
1161                     ) ,
1162                     TRIE_LIST_ITEM(state,charid).forid,
1163                     (UV)TRIE_LIST_ITEM(state,charid).newstate
1164                 );
1165                 if (!(charid % 10)) 
1166                     PerlIO_printf(Perl_debug_log, "\n%*s| ",
1167                         (int)((depth * 2) + 14), "");
1168             }
1169         }
1170         PerlIO_printf( Perl_debug_log, "\n");
1171     }
1172 }    
1173
1174 /*
1175   Dumps a fully constructed but uncompressed trie in table form.
1176   This is the normal DFA style state transition table, with a few 
1177   twists to facilitate compression later. 
1178   Used for debugging make_trie().
1179 */
1180 STATIC void
1181 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
1182                           HV *widecharmap, AV *revcharmap, U32 next_alloc,
1183                           U32 depth)
1184 {
1185     U32 state;
1186     U16 charid;
1187     SV *sv=sv_newmortal();
1188     int colwidth= widecharmap ? 6 : 4;
1189     GET_RE_DEBUG_FLAGS_DECL;
1190
1191     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
1192     
1193     /*
1194        print out the table precompression so that we can do a visual check
1195        that they are identical.
1196      */
1197     
1198     PerlIO_printf( Perl_debug_log, "%*sChar : ",(int)depth * 2 + 2,"" );
1199
1200     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1201         SV ** const tmp = av_fetch( revcharmap, charid, 0);
1202         if ( tmp ) {
1203             PerlIO_printf( Perl_debug_log, "%*s", 
1204                 colwidth,
1205                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1206                             PL_colors[0], PL_colors[1],
1207                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1208                             PERL_PV_ESCAPE_FIRSTCHAR 
1209                 ) 
1210             );
1211         }
1212     }
1213
1214     PerlIO_printf( Perl_debug_log, "\n%*sState+-",(int)depth * 2 + 2,"" );
1215
1216     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
1217         PerlIO_printf( Perl_debug_log, "%.*s", colwidth,"--------");
1218     }
1219
1220     PerlIO_printf( Perl_debug_log, "\n" );
1221
1222     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
1223
1224         PerlIO_printf( Perl_debug_log, "%*s%4"UVXf" : ", 
1225             (int)depth * 2 + 2,"",
1226             (UV)TRIE_NODENUM( state ) );
1227
1228         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1229             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
1230             if (v)
1231                 PerlIO_printf( Perl_debug_log, "%*"UVXf, colwidth, v );
1232             else
1233                 PerlIO_printf( Perl_debug_log, "%*s", colwidth, "." );
1234         }
1235         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
1236             PerlIO_printf( Perl_debug_log, " (%4"UVXf")\n", (UV)trie->trans[ state ].check );
1237         } else {
1238             PerlIO_printf( Perl_debug_log, " (%4"UVXf") W%4X\n", (UV)trie->trans[ state ].check,
1239             trie->states[ TRIE_NODENUM( state ) ].wordnum );
1240         }
1241     }
1242 }
1243
1244 #endif
1245
1246
1247 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
1248   startbranch: the first branch in the whole branch sequence
1249   first      : start branch of sequence of branch-exact nodes.
1250                May be the same as startbranch
1251   last       : Thing following the last branch.
1252                May be the same as tail.
1253   tail       : item following the branch sequence
1254   count      : words in the sequence
1255   flags      : currently the OP() type we will be building one of /EXACT(|F|Fl)/
1256   depth      : indent depth
1257
1258 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
1259
1260 A trie is an N'ary tree where the branches are determined by digital
1261 decomposition of the key. IE, at the root node you look up the 1st character and
1262 follow that branch repeat until you find the end of the branches. Nodes can be
1263 marked as "accepting" meaning they represent a complete word. Eg:
1264
1265   /he|she|his|hers/
1266
1267 would convert into the following structure. Numbers represent states, letters
1268 following numbers represent valid transitions on the letter from that state, if
1269 the number is in square brackets it represents an accepting state, otherwise it
1270 will be in parenthesis.
1271
1272       +-h->+-e->[3]-+-r->(8)-+-s->[9]
1273       |    |
1274       |   (2)
1275       |    |
1276      (1)   +-i->(6)-+-s->[7]
1277       |
1278       +-s->(3)-+-h->(4)-+-e->[5]
1279
1280       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
1281
1282 This shows that when matching against the string 'hers' we will begin at state 1
1283 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
1284 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
1285 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
1286 single traverse. We store a mapping from accepting to state to which word was
1287 matched, and then when we have multiple possibilities we try to complete the
1288 rest of the regex in the order in which they occured in the alternation.
1289
1290 The only prior NFA like behaviour that would be changed by the TRIE support is
1291 the silent ignoring of duplicate alternations which are of the form:
1292
1293  / (DUPE|DUPE) X? (?{ ... }) Y /x
1294
1295 Thus EVAL blocks following a trie may be called a different number of times with
1296 and without the optimisation. With the optimisations dupes will be silently
1297 ignored. This inconsistent behaviour of EVAL type nodes is well established as
1298 the following demonstrates:
1299
1300  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
1301
1302 which prints out 'word' three times, but
1303
1304  'words'=~/(word|word|word)(?{ print $1 })S/
1305
1306 which doesnt print it out at all. This is due to other optimisations kicking in.
1307
1308 Example of what happens on a structural level:
1309
1310 The regexp /(ac|ad|ab)+/ will produce the following debug output:
1311
1312    1: CURLYM[1] {1,32767}(18)
1313    5:   BRANCH(8)
1314    6:     EXACT <ac>(16)
1315    8:   BRANCH(11)
1316    9:     EXACT <ad>(16)
1317   11:   BRANCH(14)
1318   12:     EXACT <ab>(16)
1319   16:   SUCCEED(0)
1320   17:   NOTHING(18)
1321   18: END(0)
1322
1323 This would be optimizable with startbranch=5, first=5, last=16, tail=16
1324 and should turn into:
1325
1326    1: CURLYM[1] {1,32767}(18)
1327    5:   TRIE(16)
1328         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
1329           <ac>
1330           <ad>
1331           <ab>
1332   16:   SUCCEED(0)
1333   17:   NOTHING(18)
1334   18: END(0)
1335
1336 Cases where tail != last would be like /(?foo|bar)baz/:
1337
1338    1: BRANCH(4)
1339    2:   EXACT <foo>(8)
1340    4: BRANCH(7)
1341    5:   EXACT <bar>(8)
1342    7: TAIL(8)
1343    8: EXACT <baz>(10)
1344   10: END(0)
1345
1346 which would be optimizable with startbranch=1, first=1, last=7, tail=8
1347 and would end up looking like:
1348
1349     1: TRIE(8)
1350       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
1351         <foo>
1352         <bar>
1353    7: TAIL(8)
1354    8: EXACT <baz>(10)
1355   10: END(0)
1356
1357     d = uvuni_to_utf8_flags(d, uv, 0);
1358
1359 is the recommended Unicode-aware way of saying
1360
1361     *(d++) = uv;
1362 */
1363
1364 #define TRIE_STORE_REVCHAR                                                 \
1365     STMT_START {                                                           \
1366         if (UTF) {                                                         \
1367             SV *zlopp = newSV(2);                                          \
1368             unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp);      \
1369             unsigned const char *const kapow = uvuni_to_utf8(flrbbbbb, uvc & 0xFF); \
1370             SvCUR_set(zlopp, kapow - flrbbbbb);                            \
1371             SvPOK_on(zlopp);                                               \
1372             SvUTF8_on(zlopp);                                              \
1373             av_push(revcharmap, zlopp);                                    \
1374         } else {                                                           \
1375             char ooooff = (char)uvc;                                               \
1376             av_push(revcharmap, newSVpvn(&ooooff, 1));                     \
1377         }                                                                  \
1378         } STMT_END
1379
1380 #define TRIE_READ_CHAR STMT_START {                                           \
1381     wordlen++;                                                                \
1382     if ( UTF ) {                                                              \
1383         if ( folder ) {                                                       \
1384             if ( foldlen > 0 ) {                                              \
1385                uvc = utf8n_to_uvuni( scan, UTF8_MAXLEN, &len, uniflags );     \
1386                foldlen -= len;                                                \
1387                scan += len;                                                   \
1388                len = 0;                                                       \
1389             } else {                                                          \
1390                 len = UTF8SKIP(uc);\
1391                 uvc = to_utf8_fold( uc, foldbuf, &foldlen);                   \
1392                 foldlen -= UNISKIP( uvc );                                    \
1393                 scan = foldbuf + UNISKIP( uvc );                              \
1394             }                                                                 \
1395         } else {                                                              \
1396             uvc = utf8n_to_uvuni( (const U8*)uc, UTF8_MAXLEN, &len, uniflags);\
1397         }                                                                     \
1398     } else {                                                                  \
1399         uvc = (U32)*uc;                                                       \
1400         len = 1;                                                              \
1401     }                                                                         \
1402 } STMT_END
1403
1404
1405
1406 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
1407     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
1408         U32 ging = TRIE_LIST_LEN( state ) *= 2;                 \
1409         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
1410     }                                                           \
1411     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
1412     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
1413     TRIE_LIST_CUR( state )++;                                   \
1414 } STMT_END
1415
1416 #define TRIE_LIST_NEW(state) STMT_START {                       \
1417     Newxz( trie->states[ state ].trans.list,               \
1418         4, reg_trie_trans_le );                                 \
1419      TRIE_LIST_CUR( state ) = 1;                                \
1420      TRIE_LIST_LEN( state ) = 4;                                \
1421 } STMT_END
1422
1423 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
1424     U16 dupe= trie->states[ state ].wordnum;                    \
1425     regnode * const noper_next = regnext( noper );              \
1426                                                                 \
1427     DEBUG_r({                                                   \
1428         /* store the word for dumping */                        \
1429         SV* tmp;                                                \
1430         if (OP(noper) != NOTHING)                               \
1431             tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF);    \
1432         else                                                    \
1433             tmp = newSVpvn_utf8( "", 0, UTF );                  \
1434         av_push( trie_words, tmp );                             \
1435     });                                                         \
1436                                                                 \
1437     curword++;                                                  \
1438     trie->wordinfo[curword].prev   = 0;                         \
1439     trie->wordinfo[curword].len    = wordlen;                   \
1440     trie->wordinfo[curword].accept = state;                     \
1441                                                                 \
1442     if ( noper_next < tail ) {                                  \
1443         if (!trie->jump)                                        \
1444             trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, sizeof(U16) ); \
1445         trie->jump[curword] = (U16)(noper_next - convert);      \
1446         if (!jumper)                                            \
1447             jumper = noper_next;                                \
1448         if (!nextbranch)                                        \
1449             nextbranch= regnext(cur);                           \
1450     }                                                           \
1451                                                                 \
1452     if ( dupe ) {                                               \
1453         /* It's a dupe. Pre-insert into the wordinfo[].prev   */\
1454         /* chain, so that when the bits of chain are later    */\
1455         /* linked together, the dups appear in the chain      */\
1456         trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
1457         trie->wordinfo[dupe].prev = curword;                    \
1458     } else {                                                    \
1459         /* we haven't inserted this word yet.                */ \
1460         trie->states[ state ].wordnum = curword;                \
1461     }                                                           \
1462 } STMT_END
1463
1464
1465 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
1466      ( ( base + charid >=  ucharcount                                   \
1467          && base + charid < ubound                                      \
1468          && state == trie->trans[ base - ucharcount + charid ].check    \
1469          && trie->trans[ base - ucharcount + charid ].next )            \
1470            ? trie->trans[ base - ucharcount + charid ].next             \
1471            : ( state==1 ? special : 0 )                                 \
1472       )
1473
1474 #define MADE_TRIE       1
1475 #define MADE_JUMP_TRIE  2
1476 #define MADE_EXACT_TRIE 4
1477
1478 STATIC I32
1479 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *first, regnode *last, regnode *tail, U32 word_count, U32 flags, U32 depth)
1480 {
1481     dVAR;
1482     /* first pass, loop through and scan words */
1483     reg_trie_data *trie;
1484     HV *widecharmap = NULL;
1485     AV *revcharmap = newAV();
1486     regnode *cur;
1487     const U32 uniflags = UTF8_ALLOW_DEFAULT;
1488     STRLEN len = 0;
1489     UV uvc = 0;
1490     U16 curword = 0;
1491     U32 next_alloc = 0;
1492     regnode *jumper = NULL;
1493     regnode *nextbranch = NULL;
1494     regnode *convert = NULL;
1495     U32 *prev_states; /* temp array mapping each state to previous one */
1496     /* we just use folder as a flag in utf8 */
1497     const U8 * folder = NULL;
1498
1499 #ifdef DEBUGGING
1500     const U32 data_slot = add_data( pRExC_state, 4, "tuuu" );
1501     AV *trie_words = NULL;
1502     /* along with revcharmap, this only used during construction but both are
1503      * useful during debugging so we store them in the struct when debugging.
1504      */
1505 #else
1506     const U32 data_slot = add_data( pRExC_state, 2, "tu" );
1507     STRLEN trie_charcount=0;
1508 #endif
1509     SV *re_trie_maxbuff;
1510     GET_RE_DEBUG_FLAGS_DECL;
1511
1512     PERL_ARGS_ASSERT_MAKE_TRIE;
1513 #ifndef DEBUGGING
1514     PERL_UNUSED_ARG(depth);
1515 #endif
1516
1517     switch (flags) {
1518         case EXACTFA:
1519         case EXACTFU: folder = PL_fold_latin1; break;
1520         case EXACTF:  folder = PL_fold; break;
1521         case EXACTFL: folder = PL_fold_locale; break;
1522     }
1523
1524     trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
1525     trie->refcount = 1;
1526     trie->startstate = 1;
1527     trie->wordcount = word_count;
1528     RExC_rxi->data->data[ data_slot ] = (void*)trie;
1529     trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
1530     if (!(UTF && folder))
1531         trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
1532     trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
1533                        trie->wordcount+1, sizeof(reg_trie_wordinfo));
1534
1535     DEBUG_r({
1536         trie_words = newAV();
1537     });
1538
1539     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
1540     if (!SvIOK(re_trie_maxbuff)) {
1541         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
1542     }
1543     DEBUG_OPTIMISE_r({
1544                 PerlIO_printf( Perl_debug_log,
1545                   "%*smake_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
1546                   (int)depth * 2 + 2, "", 
1547                   REG_NODE_NUM(startbranch),REG_NODE_NUM(first), 
1548                   REG_NODE_NUM(last), REG_NODE_NUM(tail),
1549                   (int)depth);
1550     });
1551    
1552    /* Find the node we are going to overwrite */
1553     if ( first == startbranch && OP( last ) != BRANCH ) {
1554         /* whole branch chain */
1555         convert = first;
1556     } else {
1557         /* branch sub-chain */
1558         convert = NEXTOPER( first );
1559     }
1560         
1561     /*  -- First loop and Setup --
1562
1563        We first traverse the branches and scan each word to determine if it
1564        contains widechars, and how many unique chars there are, this is
1565        important as we have to build a table with at least as many columns as we
1566        have unique chars.
1567
1568        We use an array of integers to represent the character codes 0..255
1569        (trie->charmap) and we use a an HV* to store Unicode characters. We use the
1570        native representation of the character value as the key and IV's for the
1571        coded index.
1572
1573        *TODO* If we keep track of how many times each character is used we can
1574        remap the columns so that the table compression later on is more
1575        efficient in terms of memory by ensuring the most common value is in the
1576        middle and the least common are on the outside.  IMO this would be better
1577        than a most to least common mapping as theres a decent chance the most
1578        common letter will share a node with the least common, meaning the node
1579        will not be compressible. With a middle is most common approach the worst
1580        case is when we have the least common nodes twice.
1581
1582      */
1583
1584     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1585         regnode * const noper = NEXTOPER( cur );
1586         const U8 *uc = (U8*)STRING( noper );
1587         const U8 * const e  = uc + STR_LEN( noper );
1588         STRLEN foldlen = 0;
1589         U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1590         const U8 *scan = (U8*)NULL;
1591         U32 wordlen      = 0;         /* required init */
1592         STRLEN chars = 0;
1593         bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the bitmap?*/
1594
1595         if (OP(noper) == NOTHING) {
1596             trie->minlen= 0;
1597             continue;
1598         }
1599         if ( set_bit ) /* bitmap only alloced when !(UTF&&Folding) */
1600             TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
1601                                           regardless of encoding */
1602
1603         for ( ; uc < e ; uc += len ) {
1604             TRIE_CHARCOUNT(trie)++;
1605             TRIE_READ_CHAR;
1606             chars++;
1607             if ( uvc < 256 ) {
1608                 if ( !trie->charmap[ uvc ] ) {
1609                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
1610                     if ( folder )
1611                         trie->charmap[ folder[ uvc ] ] = trie->charmap[ uvc ];
1612                     TRIE_STORE_REVCHAR;
1613                 }
1614                 if ( set_bit ) {
1615                     /* store the codepoint in the bitmap, and its folded
1616                      * equivalent. */
1617                     TRIE_BITMAP_SET(trie,uvc);
1618
1619                     /* store the folded codepoint */
1620                     if ( folder ) TRIE_BITMAP_SET(trie,folder[ uvc ]);
1621
1622                     if ( !UTF ) {
1623                         /* store first byte of utf8 representation of
1624                            variant codepoints */
1625                         if (! UNI_IS_INVARIANT(uvc)) {
1626                             TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));
1627                         }
1628                     }
1629                     set_bit = 0; /* We've done our bit :-) */
1630                 }
1631             } else {
1632                 SV** svpp;
1633                 if ( !widecharmap )
1634                     widecharmap = newHV();
1635
1636                 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
1637
1638                 if ( !svpp )
1639                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%"UVXf, uvc );
1640
1641                 if ( !SvTRUE( *svpp ) ) {
1642                     sv_setiv( *svpp, ++trie->uniquecharcount );
1643                     TRIE_STORE_REVCHAR;
1644                 }
1645             }
1646         }
1647         if( cur == first ) {
1648             trie->minlen=chars;
1649             trie->maxlen=chars;
1650         } else if (chars < trie->minlen) {
1651             trie->minlen=chars;
1652         } else if (chars > trie->maxlen) {
1653             trie->maxlen=chars;
1654         }
1655
1656     } /* end first pass */
1657     DEBUG_TRIE_COMPILE_r(
1658         PerlIO_printf( Perl_debug_log, "%*sTRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
1659                 (int)depth * 2 + 2,"",
1660                 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
1661                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
1662                 (int)trie->minlen, (int)trie->maxlen )
1663     );
1664
1665     /*
1666         We now know what we are dealing with in terms of unique chars and
1667         string sizes so we can calculate how much memory a naive
1668         representation using a flat table  will take. If it's over a reasonable
1669         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
1670         conservative but potentially much slower representation using an array
1671         of lists.
1672
1673         At the end we convert both representations into the same compressed
1674         form that will be used in regexec.c for matching with. The latter
1675         is a form that cannot be used to construct with but has memory
1676         properties similar to the list form and access properties similar
1677         to the table form making it both suitable for fast searches and
1678         small enough that its feasable to store for the duration of a program.
1679
1680         See the comment in the code where the compressed table is produced
1681         inplace from the flat tabe representation for an explanation of how
1682         the compression works.
1683
1684     */
1685
1686
1687     Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
1688     prev_states[1] = 0;
1689
1690     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1) > SvIV(re_trie_maxbuff) ) {
1691         /*
1692             Second Pass -- Array Of Lists Representation
1693
1694             Each state will be represented by a list of charid:state records
1695             (reg_trie_trans_le) the first such element holds the CUR and LEN
1696             points of the allocated array. (See defines above).
1697
1698             We build the initial structure using the lists, and then convert
1699             it into the compressed table form which allows faster lookups
1700             (but cant be modified once converted).
1701         */
1702
1703         STRLEN transcount = 1;
1704
1705         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, 
1706             "%*sCompiling trie using list compiler\n",
1707             (int)depth * 2 + 2, ""));
1708         
1709         trie->states = (reg_trie_state *)
1710             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1711                                   sizeof(reg_trie_state) );
1712         TRIE_LIST_NEW(1);
1713         next_alloc = 2;
1714
1715         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1716
1717             regnode * const noper = NEXTOPER( cur );
1718             U8 *uc           = (U8*)STRING( noper );
1719             const U8 * const e = uc + STR_LEN( noper );
1720             U32 state        = 1;         /* required init */
1721             U16 charid       = 0;         /* sanity init */
1722             U8 *scan         = (U8*)NULL; /* sanity init */
1723             STRLEN foldlen   = 0;         /* required init */
1724             U32 wordlen      = 0;         /* required init */
1725             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1726
1727             if (OP(noper) != NOTHING) {
1728                 for ( ; uc < e ; uc += len ) {
1729
1730                     TRIE_READ_CHAR;
1731
1732                     if ( uvc < 256 ) {
1733                         charid = trie->charmap[ uvc ];
1734                     } else {
1735                         SV** const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
1736                         if ( !svpp ) {
1737                             charid = 0;
1738                         } else {
1739                             charid=(U16)SvIV( *svpp );
1740                         }
1741                     }
1742                     /* charid is now 0 if we dont know the char read, or nonzero if we do */
1743                     if ( charid ) {
1744
1745                         U16 check;
1746                         U32 newstate = 0;
1747
1748                         charid--;
1749                         if ( !trie->states[ state ].trans.list ) {
1750                             TRIE_LIST_NEW( state );
1751                         }
1752                         for ( check = 1; check <= TRIE_LIST_USED( state ); check++ ) {
1753                             if ( TRIE_LIST_ITEM( state, check ).forid == charid ) {
1754                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
1755                                 break;
1756                             }
1757                         }
1758                         if ( ! newstate ) {
1759                             newstate = next_alloc++;
1760                             prev_states[newstate] = state;
1761                             TRIE_LIST_PUSH( state, charid, newstate );
1762                             transcount++;
1763                         }
1764                         state = newstate;
1765                     } else {
1766                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1767                     }
1768                 }
1769             }
1770             TRIE_HANDLE_WORD(state);
1771
1772         } /* end second pass */
1773
1774         /* next alloc is the NEXT state to be allocated */
1775         trie->statecount = next_alloc; 
1776         trie->states = (reg_trie_state *)
1777             PerlMemShared_realloc( trie->states,
1778                                    next_alloc
1779                                    * sizeof(reg_trie_state) );
1780
1781         /* and now dump it out before we compress it */
1782         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
1783                                                          revcharmap, next_alloc,
1784                                                          depth+1)
1785         );
1786
1787         trie->trans = (reg_trie_trans *)
1788             PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
1789         {
1790             U32 state;
1791             U32 tp = 0;
1792             U32 zp = 0;
1793
1794
1795             for( state=1 ; state < next_alloc ; state ++ ) {
1796                 U32 base=0;
1797
1798                 /*
1799                 DEBUG_TRIE_COMPILE_MORE_r(
1800                     PerlIO_printf( Perl_debug_log, "tp: %d zp: %d ",tp,zp)
1801                 );
1802                 */
1803
1804                 if (trie->states[state].trans.list) {
1805                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
1806                     U16 maxid=minid;
1807                     U16 idx;
1808
1809                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1810                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
1811                         if ( forid < minid ) {
1812                             minid=forid;
1813                         } else if ( forid > maxid ) {
1814                             maxid=forid;
1815                         }
1816                     }
1817                     if ( transcount < tp + maxid - minid + 1) {
1818                         transcount *= 2;
1819                         trie->trans = (reg_trie_trans *)
1820                             PerlMemShared_realloc( trie->trans,
1821                                                      transcount
1822                                                      * sizeof(reg_trie_trans) );
1823                         Zero( trie->trans + (transcount / 2), transcount / 2 , reg_trie_trans );
1824                     }
1825                     base = trie->uniquecharcount + tp - minid;
1826                     if ( maxid == minid ) {
1827                         U32 set = 0;
1828                         for ( ; zp < tp ; zp++ ) {
1829                             if ( ! trie->trans[ zp ].next ) {
1830                                 base = trie->uniquecharcount + zp - minid;
1831                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1832                                 trie->trans[ zp ].check = state;
1833                                 set = 1;
1834                                 break;
1835                             }
1836                         }
1837                         if ( !set ) {
1838                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1839                             trie->trans[ tp ].check = state;
1840                             tp++;
1841                             zp = tp;
1842                         }
1843                     } else {
1844                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1845                             const U32 tid = base -  trie->uniquecharcount + TRIE_LIST_ITEM( state, idx ).forid;
1846                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state, idx ).newstate;
1847                             trie->trans[ tid ].check = state;
1848                         }
1849                         tp += ( maxid - minid + 1 );
1850                     }
1851                     Safefree(trie->states[ state ].trans.list);
1852                 }
1853                 /*
1854                 DEBUG_TRIE_COMPILE_MORE_r(
1855                     PerlIO_printf( Perl_debug_log, " base: %d\n",base);
1856                 );
1857                 */
1858                 trie->states[ state ].trans.base=base;
1859             }
1860             trie->lasttrans = tp + 1;
1861         }
1862     } else {
1863         /*
1864            Second Pass -- Flat Table Representation.
1865
1866            we dont use the 0 slot of either trans[] or states[] so we add 1 to each.
1867            We know that we will need Charcount+1 trans at most to store the data
1868            (one row per char at worst case) So we preallocate both structures
1869            assuming worst case.
1870
1871            We then construct the trie using only the .next slots of the entry
1872            structs.
1873
1874            We use the .check field of the first entry of the node temporarily to
1875            make compression both faster and easier by keeping track of how many non
1876            zero fields are in the node.
1877
1878            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
1879            transition.
1880
1881            There are two terms at use here: state as a TRIE_NODEIDX() which is a
1882            number representing the first entry of the node, and state as a
1883            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1) and
1884            TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3) if there
1885            are 2 entrys per node. eg:
1886
1887              A B       A B
1888           1. 2 4    1. 3 7
1889           2. 0 3    3. 0 5
1890           3. 0 0    5. 0 0
1891           4. 0 0    7. 0 0
1892
1893            The table is internally in the right hand, idx form. However as we also
1894            have to deal with the states array which is indexed by nodenum we have to
1895            use TRIE_NODENUM() to convert.
1896
1897         */
1898         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, 
1899             "%*sCompiling trie using table compiler\n",
1900             (int)depth * 2 + 2, ""));
1901
1902         trie->trans = (reg_trie_trans *)
1903             PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
1904                                   * trie->uniquecharcount + 1,
1905                                   sizeof(reg_trie_trans) );
1906         trie->states = (reg_trie_state *)
1907             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1908                                   sizeof(reg_trie_state) );
1909         next_alloc = trie->uniquecharcount + 1;
1910
1911
1912         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1913
1914             regnode * const noper   = NEXTOPER( cur );
1915             const U8 *uc     = (U8*)STRING( noper );
1916             const U8 * const e = uc + STR_LEN( noper );
1917
1918             U32 state        = 1;         /* required init */
1919
1920             U16 charid       = 0;         /* sanity init */
1921             U32 accept_state = 0;         /* sanity init */
1922             U8 *scan         = (U8*)NULL; /* sanity init */
1923
1924             STRLEN foldlen   = 0;         /* required init */
1925             U32 wordlen      = 0;         /* required init */
1926             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1927
1928             if ( OP(noper) != NOTHING ) {
1929                 for ( ; uc < e ; uc += len ) {
1930
1931                     TRIE_READ_CHAR;
1932
1933                     if ( uvc < 256 ) {
1934                         charid = trie->charmap[ uvc ];
1935                     } else {
1936                         SV* const * const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
1937                         charid = svpp ? (U16)SvIV(*svpp) : 0;
1938                     }
1939                     if ( charid ) {
1940                         charid--;
1941                         if ( !trie->trans[ state + charid ].next ) {
1942                             trie->trans[ state + charid ].next = next_alloc;
1943                             trie->trans[ state ].check++;
1944                             prev_states[TRIE_NODENUM(next_alloc)]
1945                                     = TRIE_NODENUM(state);
1946                             next_alloc += trie->uniquecharcount;
1947                         }
1948                         state = trie->trans[ state + charid ].next;
1949                     } else {
1950                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1951                     }
1952                     /* charid is now 0 if we dont know the char read, or nonzero if we do */
1953                 }
1954             }
1955             accept_state = TRIE_NODENUM( state );
1956             TRIE_HANDLE_WORD(accept_state);
1957
1958         } /* end second pass */
1959
1960         /* and now dump it out before we compress it */
1961         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
1962                                                           revcharmap,
1963                                                           next_alloc, depth+1));
1964
1965         {
1966         /*
1967            * Inplace compress the table.*
1968
1969            For sparse data sets the table constructed by the trie algorithm will
1970            be mostly 0/FAIL transitions or to put it another way mostly empty.
1971            (Note that leaf nodes will not contain any transitions.)
1972
1973            This algorithm compresses the tables by eliminating most such
1974            transitions, at the cost of a modest bit of extra work during lookup:
1975
1976            - Each states[] entry contains a .base field which indicates the
1977            index in the state[] array wheres its transition data is stored.
1978
1979            - If .base is 0 there are no valid transitions from that node.
1980
1981            - If .base is nonzero then charid is added to it to find an entry in
1982            the trans array.
1983
1984            -If trans[states[state].base+charid].check!=state then the
1985            transition is taken to be a 0/Fail transition. Thus if there are fail
1986            transitions at the front of the node then the .base offset will point
1987            somewhere inside the previous nodes data (or maybe even into a node
1988            even earlier), but the .check field determines if the transition is
1989            valid.
1990
1991            XXX - wrong maybe?
1992            The following process inplace converts the table to the compressed
1993            table: We first do not compress the root node 1,and mark all its
1994            .check pointers as 1 and set its .base pointer as 1 as well. This
1995            allows us to do a DFA construction from the compressed table later,
1996            and ensures that any .base pointers we calculate later are greater
1997            than 0.
1998
1999            - We set 'pos' to indicate the first entry of the second node.
2000
2001            - We then iterate over the columns of the node, finding the first and
2002            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
2003            and set the .check pointers accordingly, and advance pos
2004            appropriately and repreat for the next node. Note that when we copy
2005            the next pointers we have to convert them from the original
2006            NODEIDX form to NODENUM form as the former is not valid post
2007            compression.
2008
2009            - If a node has no transitions used we mark its base as 0 and do not
2010            advance the pos pointer.
2011
2012            - If a node only has one transition we use a second pointer into the
2013            structure to fill in allocated fail transitions from other states.
2014            This pointer is independent of the main pointer and scans forward
2015            looking for null transitions that are allocated to a state. When it
2016            finds one it writes the single transition into the "hole".  If the
2017            pointer doesnt find one the single transition is appended as normal.
2018
2019            - Once compressed we can Renew/realloc the structures to release the
2020            excess space.
2021
2022            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
2023            specifically Fig 3.47 and the associated pseudocode.
2024
2025            demq
2026         */
2027         const U32 laststate = TRIE_NODENUM( next_alloc );
2028         U32 state, charid;
2029         U32 pos = 0, zp=0;
2030         trie->statecount = laststate;
2031
2032         for ( state = 1 ; state < laststate ; state++ ) {
2033             U8 flag = 0;
2034             const U32 stateidx = TRIE_NODEIDX( state );
2035             const U32 o_used = trie->trans[ stateidx ].check;
2036             U32 used = trie->trans[ stateidx ].check;
2037             trie->trans[ stateidx ].check = 0;
2038
2039             for ( charid = 0 ; used && charid < trie->uniquecharcount ; charid++ ) {
2040                 if ( flag || trie->trans[ stateidx + charid ].next ) {
2041                     if ( trie->trans[ stateidx + charid ].next ) {
2042                         if (o_used == 1) {
2043                             for ( ; zp < pos ; zp++ ) {
2044                                 if ( ! trie->trans[ zp ].next ) {
2045                                     break;
2046                                 }
2047                             }
2048                             trie->states[ state ].trans.base = zp + trie->uniquecharcount - charid ;
2049                             trie->trans[ zp ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2050                             trie->trans[ zp ].check = state;
2051                             if ( ++zp > pos ) pos = zp;
2052                             break;
2053                         }
2054                         used--;
2055                     }
2056                     if ( !flag ) {
2057                         flag = 1;
2058                         trie->states[ state ].trans.base = pos + trie->uniquecharcount - charid ;
2059                     }
2060                     trie->trans[ pos ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2061                     trie->trans[ pos ].check = state;
2062                     pos++;
2063                 }
2064             }
2065         }
2066         trie->lasttrans = pos + 1;
2067         trie->states = (reg_trie_state *)
2068             PerlMemShared_realloc( trie->states, laststate
2069                                    * sizeof(reg_trie_state) );
2070         DEBUG_TRIE_COMPILE_MORE_r(
2071                 PerlIO_printf( Perl_debug_log,
2072                     "%*sAlloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n",
2073                     (int)depth * 2 + 2,"",
2074                     (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1 ),
2075                     (IV)next_alloc,
2076                     (IV)pos,
2077                     ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
2078             );
2079
2080         } /* end table compress */
2081     }
2082     DEBUG_TRIE_COMPILE_MORE_r(
2083             PerlIO_printf(Perl_debug_log, "%*sStatecount:%"UVxf" Lasttrans:%"UVxf"\n",
2084                 (int)depth * 2 + 2, "",
2085                 (UV)trie->statecount,
2086                 (UV)trie->lasttrans)
2087     );
2088     /* resize the trans array to remove unused space */
2089     trie->trans = (reg_trie_trans *)
2090         PerlMemShared_realloc( trie->trans, trie->lasttrans
2091                                * sizeof(reg_trie_trans) );
2092
2093     {   /* Modify the program and insert the new TRIE node */ 
2094         U8 nodetype =(U8)(flags & 0xFF);
2095         char *str=NULL;
2096         
2097 #ifdef DEBUGGING
2098         regnode *optimize = NULL;
2099 #ifdef RE_TRACK_PATTERN_OFFSETS
2100
2101         U32 mjd_offset = 0;
2102         U32 mjd_nodelen = 0;
2103 #endif /* RE_TRACK_PATTERN_OFFSETS */
2104 #endif /* DEBUGGING */
2105         /*
2106            This means we convert either the first branch or the first Exact,
2107            depending on whether the thing following (in 'last') is a branch
2108            or not and whther first is the startbranch (ie is it a sub part of
2109            the alternation or is it the whole thing.)
2110            Assuming its a sub part we convert the EXACT otherwise we convert
2111            the whole branch sequence, including the first.
2112          */
2113         /* Find the node we are going to overwrite */
2114         if ( first != startbranch || OP( last ) == BRANCH ) {
2115             /* branch sub-chain */
2116             NEXT_OFF( first ) = (U16)(last - first);
2117 #ifdef RE_TRACK_PATTERN_OFFSETS
2118             DEBUG_r({
2119                 mjd_offset= Node_Offset((convert));
2120                 mjd_nodelen= Node_Length((convert));
2121             });
2122 #endif
2123             /* whole branch chain */
2124         }
2125 #ifdef RE_TRACK_PATTERN_OFFSETS
2126         else {
2127             DEBUG_r({
2128                 const  regnode *nop = NEXTOPER( convert );
2129                 mjd_offset= Node_Offset((nop));
2130                 mjd_nodelen= Node_Length((nop));
2131             });
2132         }
2133         DEBUG_OPTIMISE_r(
2134             PerlIO_printf(Perl_debug_log, "%*sMJD offset:%"UVuf" MJD length:%"UVuf"\n",
2135                 (int)depth * 2 + 2, "",
2136                 (UV)mjd_offset, (UV)mjd_nodelen)
2137         );
2138 #endif
2139         /* But first we check to see if there is a common prefix we can 
2140            split out as an EXACT and put in front of the TRIE node.  */
2141         trie->startstate= 1;
2142         if ( trie->bitmap && !widecharmap && !trie->jump  ) {
2143             U32 state;
2144             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
2145                 U32 ofs = 0;
2146                 I32 idx = -1;
2147                 U32 count = 0;
2148                 const U32 base = trie->states[ state ].trans.base;
2149
2150                 if ( trie->states[state].wordnum )
2151                         count = 1;
2152
2153                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2154                     if ( ( base + ofs >= trie->uniquecharcount ) &&
2155                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
2156                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
2157                     {
2158                         if ( ++count > 1 ) {
2159                             SV **tmp = av_fetch( revcharmap, ofs, 0);
2160                             const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
2161                             if ( state == 1 ) break;
2162                             if ( count == 2 ) {
2163                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
2164                                 DEBUG_OPTIMISE_r(
2165                                     PerlIO_printf(Perl_debug_log,
2166                                         "%*sNew Start State=%"UVuf" Class: [",
2167                                         (int)depth * 2 + 2, "",
2168                                         (UV)state));
2169                                 if (idx >= 0) {
2170                                     SV ** const tmp = av_fetch( revcharmap, idx, 0);
2171                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
2172
2173                                     TRIE_BITMAP_SET(trie,*ch);
2174                                     if ( folder )
2175                                         TRIE_BITMAP_SET(trie, folder[ *ch ]);
2176                                     DEBUG_OPTIMISE_r(
2177                                         PerlIO_printf(Perl_debug_log, "%s", (char*)ch)
2178                                     );
2179                                 }
2180                             }
2181                             TRIE_BITMAP_SET(trie,*ch);
2182                             if ( folder )
2183                                 TRIE_BITMAP_SET(trie,folder[ *ch ]);
2184                             DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"%s", ch));
2185                         }
2186                         idx = ofs;
2187                     }
2188                 }
2189                 if ( count == 1 ) {
2190                     SV **tmp = av_fetch( revcharmap, idx, 0);
2191                     STRLEN len;
2192                     char *ch = SvPV( *tmp, len );
2193                     DEBUG_OPTIMISE_r({
2194                         SV *sv=sv_newmortal();
2195                         PerlIO_printf( Perl_debug_log,
2196                             "%*sPrefix State: %"UVuf" Idx:%"UVuf" Char='%s'\n",
2197                             (int)depth * 2 + 2, "",
2198                             (UV)state, (UV)idx, 
2199                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6, 
2200                                 PL_colors[0], PL_colors[1],
2201                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2202                                 PERL_PV_ESCAPE_FIRSTCHAR 
2203                             )
2204                         );
2205                     });
2206                     if ( state==1 ) {
2207                         OP( convert ) = nodetype;
2208                         str=STRING(convert);
2209                         STR_LEN(convert)=0;
2210                     }
2211                     STR_LEN(convert) += len;
2212                     while (len--)
2213                         *str++ = *ch++;
2214                 } else {
2215 #ifdef DEBUGGING            
2216                     if (state>1)
2217                         DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"]\n"));
2218 #endif
2219                     break;
2220                 }
2221             }
2222             trie->prefixlen = (state-1);
2223             if (str) {
2224                 regnode *n = convert+NODE_SZ_STR(convert);
2225                 NEXT_OFF(convert) = NODE_SZ_STR(convert);
2226                 trie->startstate = state;
2227                 trie->minlen -= (state - 1);
2228                 trie->maxlen -= (state - 1);
2229 #ifdef DEBUGGING
2230                /* At least the UNICOS C compiler choked on this
2231                 * being argument to DEBUG_r(), so let's just have
2232                 * it right here. */
2233                if (
2234 #ifdef PERL_EXT_RE_BUILD
2235                    1
2236 #else
2237                    DEBUG_r_TEST
2238 #endif
2239                    ) {
2240                    regnode *fix = convert;
2241                    U32 word = trie->wordcount;
2242                    mjd_nodelen++;
2243                    Set_Node_Offset_Length(convert, mjd_offset, state - 1);
2244                    while( ++fix < n ) {
2245                        Set_Node_Offset_Length(fix, 0, 0);
2246                    }
2247                    while (word--) {
2248                        SV ** const tmp = av_fetch( trie_words, word, 0 );
2249                        if (tmp) {
2250                            if ( STR_LEN(convert) <= SvCUR(*tmp) )
2251                                sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
2252                            else
2253                                sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
2254                        }
2255                    }
2256                }
2257 #endif
2258                 if (trie->maxlen) {
2259                     convert = n;
2260                 } else {
2261                     NEXT_OFF(convert) = (U16)(tail - convert);
2262                     DEBUG_r(optimize= n);
2263                 }
2264             }
2265         }
2266         if (!jumper) 
2267             jumper = last; 
2268         if ( trie->maxlen ) {
2269             NEXT_OFF( convert ) = (U16)(tail - convert);
2270             ARG_SET( convert, data_slot );
2271             /* Store the offset to the first unabsorbed branch in 
2272                jump[0], which is otherwise unused by the jump logic. 
2273                We use this when dumping a trie and during optimisation. */
2274             if (trie->jump) 
2275                 trie->jump[0] = (U16)(nextbranch - convert);
2276             
2277             /* If the start state is not accepting (meaning there is no empty string/NOTHING)
2278              *   and there is a bitmap
2279              *   and the first "jump target" node we found leaves enough room
2280              * then convert the TRIE node into a TRIEC node, with the bitmap
2281              * embedded inline in the opcode - this is hypothetically faster.
2282              */
2283             if ( !trie->states[trie->startstate].wordnum
2284                  && trie->bitmap
2285                  && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
2286             {
2287                 OP( convert ) = TRIEC;
2288                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
2289                 PerlMemShared_free(trie->bitmap);
2290                 trie->bitmap= NULL;
2291             } else 
2292                 OP( convert ) = TRIE;
2293
2294             /* store the type in the flags */
2295             convert->flags = nodetype;
2296             DEBUG_r({
2297             optimize = convert 
2298                       + NODE_STEP_REGNODE 
2299                       + regarglen[ OP( convert ) ];
2300             });
2301             /* XXX We really should free up the resource in trie now, 
2302                    as we won't use them - (which resources?) dmq */
2303         }
2304         /* needed for dumping*/
2305         DEBUG_r(if (optimize) {
2306             regnode *opt = convert;
2307
2308             while ( ++opt < optimize) {
2309                 Set_Node_Offset_Length(opt,0,0);
2310             }
2311             /* 
2312                 Try to clean up some of the debris left after the 
2313                 optimisation.
2314              */
2315             while( optimize < jumper ) {
2316                 mjd_nodelen += Node_Length((optimize));
2317                 OP( optimize ) = OPTIMIZED;
2318                 Set_Node_Offset_Length(optimize,0,0);
2319                 optimize++;
2320             }
2321             Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
2322         });
2323     } /* end node insert */
2324     REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, convert);
2325
2326     /*  Finish populating the prev field of the wordinfo array.  Walk back
2327      *  from each accept state until we find another accept state, and if
2328      *  so, point the first word's .prev field at the second word. If the
2329      *  second already has a .prev field set, stop now. This will be the
2330      *  case either if we've already processed that word's accept state,
2331      *  or that state had multiple words, and the overspill words were
2332      *  already linked up earlier.
2333      */
2334     {
2335         U16 word;
2336         U32 state;
2337         U16 prev;
2338
2339         for (word=1; word <= trie->wordcount; word++) {
2340             prev = 0;
2341             if (trie->wordinfo[word].prev)
2342                 continue;
2343             state = trie->wordinfo[word].accept;
2344             while (state) {
2345                 state = prev_states[state];
2346                 if (!state)
2347                     break;
2348                 prev = trie->states[state].wordnum;
2349                 if (prev)
2350                     break;
2351             }
2352             trie->wordinfo[word].prev = prev;
2353         }
2354         Safefree(prev_states);
2355     }
2356
2357
2358     /* and now dump out the compressed format */
2359     DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
2360
2361     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
2362 #ifdef DEBUGGING
2363     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
2364     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
2365 #else
2366     SvREFCNT_dec(revcharmap);
2367 #endif
2368     return trie->jump 
2369            ? MADE_JUMP_TRIE 
2370            : trie->startstate>1 
2371              ? MADE_EXACT_TRIE 
2372              : MADE_TRIE;
2373 }
2374
2375 STATIC void
2376 S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source,  regnode *stclass, U32 depth)
2377 {
2378 /* The Trie is constructed and compressed now so we can build a fail array if it's needed
2379
2380    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and 3.32 in the
2381    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi, Ullman 1985/88
2382    ISBN 0-201-10088-6
2383
2384    We find the fail state for each state in the trie, this state is the longest proper
2385    suffix of the current state's 'word' that is also a proper prefix of another word in our
2386    trie. State 1 represents the word '' and is thus the default fail state. This allows
2387    the DFA not to have to restart after its tried and failed a word at a given point, it
2388    simply continues as though it had been matching the other word in the first place.
2389    Consider
2390       'abcdgu'=~/abcdefg|cdgu/
2391    When we get to 'd' we are still matching the first word, we would encounter 'g' which would
2392    fail, which would bring us to the state representing 'd' in the second word where we would
2393    try 'g' and succeed, proceeding to match 'cdgu'.
2394  */
2395  /* add a fail transition */
2396     const U32 trie_offset = ARG(source);
2397     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
2398     U32 *q;
2399     const U32 ucharcount = trie->uniquecharcount;
2400     const U32 numstates = trie->statecount;
2401     const U32 ubound = trie->lasttrans + ucharcount;
2402     U32 q_read = 0;
2403     U32 q_write = 0;
2404     U32 charid;
2405     U32 base = trie->states[ 1 ].trans.base;
2406     U32 *fail;
2407     reg_ac_data *aho;
2408     const U32 data_slot = add_data( pRExC_state, 1, "T" );
2409     GET_RE_DEBUG_FLAGS_DECL;
2410
2411     PERL_ARGS_ASSERT_MAKE_TRIE_FAILTABLE;
2412 #ifndef DEBUGGING
2413     PERL_UNUSED_ARG(depth);
2414 #endif
2415
2416
2417     ARG_SET( stclass, data_slot );
2418     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
2419     RExC_rxi->data->data[ data_slot ] = (void*)aho;
2420     aho->trie=trie_offset;
2421     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
2422     Copy( trie->states, aho->states, numstates, reg_trie_state );
2423     Newxz( q, numstates, U32);
2424     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
2425     aho->refcount = 1;
2426     fail = aho->fail;
2427     /* initialize fail[0..1] to be 1 so that we always have
2428        a valid final fail state */
2429     fail[ 0 ] = fail[ 1 ] = 1;
2430
2431     for ( charid = 0; charid < ucharcount ; charid++ ) {
2432         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
2433         if ( newstate ) {
2434             q[ q_write ] = newstate;
2435             /* set to point at the root */
2436             fail[ q[ q_write++ ] ]=1;
2437         }
2438     }
2439     while ( q_read < q_write) {
2440         const U32 cur = q[ q_read++ % numstates ];
2441         base = trie->states[ cur ].trans.base;
2442
2443         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
2444             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
2445             if (ch_state) {
2446                 U32 fail_state = cur;
2447                 U32 fail_base;
2448                 do {
2449                     fail_state = fail[ fail_state ];
2450                     fail_base = aho->states[ fail_state ].trans.base;
2451                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
2452
2453                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
2454                 fail[ ch_state ] = fail_state;
2455                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
2456                 {
2457                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
2458                 }
2459                 q[ q_write++ % numstates] = ch_state;
2460             }
2461         }
2462     }
2463     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
2464        when we fail in state 1, this allows us to use the
2465        charclass scan to find a valid start char. This is based on the principle
2466        that theres a good chance the string being searched contains lots of stuff
2467        that cant be a start char.
2468      */
2469     fail[ 0 ] = fail[ 1 ] = 0;
2470     DEBUG_TRIE_COMPILE_r({
2471         PerlIO_printf(Perl_debug_log,
2472                       "%*sStclass Failtable (%"UVuf" states): 0", 
2473                       (int)(depth * 2), "", (UV)numstates
2474         );
2475         for( q_read=1; q_read<numstates; q_read++ ) {
2476             PerlIO_printf(Perl_debug_log, ", %"UVuf, (UV)fail[q_read]);
2477         }
2478         PerlIO_printf(Perl_debug_log, "\n");
2479     });
2480     Safefree(q);
2481     /*RExC_seen |= REG_SEEN_TRIEDFA;*/
2482 }
2483
2484
2485 /*
2486  * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2487  * These need to be revisited when a newer toolchain becomes available.
2488  */
2489 #if defined(__sparc64__) && defined(__GNUC__)
2490 #   if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2491 #       undef  SPARC64_GCC_WORKAROUND
2492 #       define SPARC64_GCC_WORKAROUND 1
2493 #   endif
2494 #endif
2495
2496 #define DEBUG_PEEP(str,scan,depth) \
2497     DEBUG_OPTIMISE_r({if (scan){ \
2498        SV * const mysv=sv_newmortal(); \
2499        regnode *Next = regnext(scan); \
2500        regprop(RExC_rx, mysv, scan); \
2501        PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s (%d)\n", \
2502        (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\
2503        Next ? (REG_NODE_NUM(Next)) : 0 ); \
2504    }});
2505
2506
2507
2508
2509
2510 #define JOIN_EXACT(scan,min,flags) \
2511     if (PL_regkind[OP(scan)] == EXACT) \
2512         join_exact(pRExC_state,(scan),(min),(flags),NULL,depth+1)
2513
2514 STATIC U32
2515 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, I32 *min, U32 flags,regnode *val, U32 depth) {
2516     /* Merge several consecutive EXACTish nodes into one. */
2517     regnode *n = regnext(scan);
2518     U32 stringok = 1;
2519     regnode *next = scan + NODE_SZ_STR(scan);
2520     U32 merged = 0;
2521     U32 stopnow = 0;
2522 #ifdef DEBUGGING
2523     regnode *stop = scan;
2524     GET_RE_DEBUG_FLAGS_DECL;
2525 #else
2526     PERL_UNUSED_ARG(depth);
2527 #endif
2528
2529     PERL_ARGS_ASSERT_JOIN_EXACT;
2530 #ifndef EXPERIMENTAL_INPLACESCAN
2531     PERL_UNUSED_ARG(flags);
2532     PERL_UNUSED_ARG(val);
2533 #endif
2534     DEBUG_PEEP("join",scan,depth);
2535     
2536     /* Skip NOTHING, merge EXACT*. */
2537     while (n &&
2538            ( PL_regkind[OP(n)] == NOTHING ||
2539              (stringok && (OP(n) == OP(scan))))
2540            && NEXT_OFF(n)
2541            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX) {
2542         
2543         if (OP(n) == TAIL || n > next)
2544             stringok = 0;
2545         if (PL_regkind[OP(n)] == NOTHING) {
2546             DEBUG_PEEP("skip:",n,depth);
2547             NEXT_OFF(scan) += NEXT_OFF(n);
2548             next = n + NODE_STEP_REGNODE;
2549 #ifdef DEBUGGING
2550             if (stringok)
2551                 stop = n;
2552 #endif
2553             n = regnext(n);
2554         }
2555         else if (stringok) {
2556             const unsigned int oldl = STR_LEN(scan);
2557             regnode * const nnext = regnext(n);
2558             
2559             DEBUG_PEEP("merg",n,depth);
2560             
2561             merged++;
2562             if (oldl + STR_LEN(n) > U8_MAX)
2563                 break;
2564             NEXT_OFF(scan) += NEXT_OFF(n);
2565             STR_LEN(scan) += STR_LEN(n);
2566             next = n + NODE_SZ_STR(n);
2567             /* Now we can overwrite *n : */
2568             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
2569 #ifdef DEBUGGING
2570             stop = next - 1;
2571 #endif
2572             n = nnext;
2573             if (stopnow) break;
2574         }
2575
2576 #ifdef EXPERIMENTAL_INPLACESCAN
2577         if (flags && !NEXT_OFF(n)) {
2578             DEBUG_PEEP("atch", val, depth);
2579             if (reg_off_by_arg[OP(n)]) {
2580                 ARG_SET(n, val - n);
2581             }
2582             else {
2583                 NEXT_OFF(n) = val - n;
2584             }
2585             stopnow = 1;
2586         }
2587 #endif
2588     }
2589 #define GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS   0x0390
2590 #define IOTA_D_T        GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS
2591 #define GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS     0x03B0
2592 #define UPSILON_D_T     GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS
2593
2594     if (UTF
2595         && ( OP(scan) == EXACTF || OP(scan) == EXACTFU || OP(scan) == EXACTFA)
2596         && ( STR_LEN(scan) >= 6 ) )
2597     {
2598     /*
2599     Two problematic code points in Unicode casefolding of EXACT nodes:
2600     
2601     U+0390 - GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
2602     U+03B0 - GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
2603     
2604     which casefold to
2605     
2606     Unicode                      UTF-8
2607     
2608     U+03B9 U+0308 U+0301         0xCE 0xB9 0xCC 0x88 0xCC 0x81
2609     U+03C5 U+0308 U+0301         0xCF 0x85 0xCC 0x88 0xCC 0x81
2610     
2611     This means that in case-insensitive matching (or "loose matching",
2612     as Unicode calls it), an EXACTF of length six (the UTF-8 encoded byte
2613     length of the above casefolded versions) can match a target string
2614     of length two (the byte length of UTF-8 encoded U+0390 or U+03B0).
2615     This would rather mess up the minimum length computation.
2616     
2617     What we'll do is to look for the tail four bytes, and then peek
2618     at the preceding two bytes to see whether we need to decrease
2619     the minimum length by four (six minus two).
2620     
2621     Thanks to the design of UTF-8, there cannot be false matches:
2622     A sequence of valid UTF-8 bytes cannot be a subsequence of
2623     another valid sequence of UTF-8 bytes.
2624     
2625     */
2626          char * const s0 = STRING(scan), *s, *t;
2627          char * const s1 = s0 + STR_LEN(scan) - 1;
2628          char * const s2 = s1 - 4;
2629 #ifdef EBCDIC /* RD tunifold greek 0390 and 03B0 */
2630          const char t0[] = "\xaf\x49\xaf\x42";
2631 #else
2632          const char t0[] = "\xcc\x88\xcc\x81";
2633 #endif
2634          const char * const t1 = t0 + 3;
2635     
2636          for (s = s0 + 2;
2637               s < s2 && (t = ninstr(s, s1, t0, t1));
2638               s = t + 4) {
2639 #ifdef EBCDIC
2640               if (((U8)t[-1] == 0x68 && (U8)t[-2] == 0xB4) ||
2641                   ((U8)t[-1] == 0x46 && (U8)t[-2] == 0xB5))
2642 #else
2643               if (((U8)t[-1] == 0xB9 && (U8)t[-2] == 0xCE) ||
2644                   ((U8)t[-1] == 0x85 && (U8)t[-2] == 0xCF))
2645 #endif
2646                    *min -= 4;
2647          }
2648     }
2649     
2650 #ifdef DEBUGGING
2651     /* Allow dumping but overwriting the collection of skipped
2652      * ops and/or strings with fake optimized ops */
2653     n = scan + NODE_SZ_STR(scan);
2654     while (n <= stop) {
2655         OP(n) = OPTIMIZED;
2656         FLAGS(n) = 0;
2657         NEXT_OFF(n) = 0;
2658         n++;
2659     }
2660 #endif
2661     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
2662     return stopnow;
2663 }
2664
2665 /* REx optimizer.  Converts nodes into quicker variants "in place".
2666    Finds fixed substrings.  */
2667
2668 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
2669    to the position after last scanned or to NULL. */
2670
2671 #define INIT_AND_WITHP \
2672     assert(!and_withp); \
2673     Newx(and_withp,1,struct regnode_charclass_class); \
2674     SAVEFREEPV(and_withp)
2675
2676 /* this is a chain of data about sub patterns we are processing that
2677    need to be handled separately/specially in study_chunk. Its so
2678    we can simulate recursion without losing state.  */
2679 struct scan_frame;
2680 typedef struct scan_frame {
2681     regnode *last;  /* last node to process in this frame */
2682     regnode *next;  /* next node to process when last is reached */
2683     struct scan_frame *prev; /*previous frame*/
2684     I32 stop; /* what stopparen do we use */
2685 } scan_frame;
2686
2687
2688 #define SCAN_COMMIT(s, data, m) scan_commit(s, data, m, is_inf)
2689
2690 #define CASE_SYNST_FNC(nAmE)                                       \
2691 case nAmE:                                                         \
2692     if (flags & SCF_DO_STCLASS_AND) {                              \
2693             for (value = 0; value < 256; value++)                  \
2694                 if (!is_ ## nAmE ## _cp(value))                       \
2695                     ANYOF_BITMAP_CLEAR(data->start_class, value);  \
2696     }                                                              \
2697     else {                                                         \
2698             for (value = 0; value < 256; value++)                  \
2699                 if (is_ ## nAmE ## _cp(value))                        \
2700                     ANYOF_BITMAP_SET(data->start_class, value);    \
2701     }                                                              \
2702     break;                                                         \
2703 case N ## nAmE:                                                    \
2704     if (flags & SCF_DO_STCLASS_AND) {                              \
2705             for (value = 0; value < 256; value++)                   \
2706                 if (is_ ## nAmE ## _cp(value))                         \
2707                     ANYOF_BITMAP_CLEAR(data->start_class, value);   \
2708     }                                                               \
2709     else {                                                          \
2710             for (value = 0; value < 256; value++)                   \
2711                 if (!is_ ## nAmE ## _cp(value))                        \
2712                     ANYOF_BITMAP_SET(data->start_class, value);     \
2713     }                                                               \
2714     break
2715
2716
2717
2718 STATIC I32
2719 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
2720                         I32 *minlenp, I32 *deltap,
2721                         regnode *last,
2722                         scan_data_t *data,
2723                         I32 stopparen,
2724                         U8* recursed,
2725                         struct regnode_charclass_class *and_withp,
2726                         U32 flags, U32 depth)
2727                         /* scanp: Start here (read-write). */
2728                         /* deltap: Write maxlen-minlen here. */
2729                         /* last: Stop before this one. */
2730                         /* data: string data about the pattern */
2731                         /* stopparen: treat close N as END */
2732                         /* recursed: which subroutines have we recursed into */
2733                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
2734 {
2735     dVAR;
2736     I32 min = 0, pars = 0, code;
2737     regnode *scan = *scanp, *next;
2738     I32 delta = 0;
2739     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
2740     int is_inf_internal = 0;            /* The studied chunk is infinite */
2741     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
2742     scan_data_t data_fake;
2743     SV *re_trie_maxbuff = NULL;
2744     regnode *first_non_open = scan;
2745     I32 stopmin = I32_MAX;
2746     scan_frame *frame = NULL;
2747     GET_RE_DEBUG_FLAGS_DECL;
2748
2749     PERL_ARGS_ASSERT_STUDY_CHUNK;
2750
2751 #ifdef DEBUGGING
2752     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
2753 #endif
2754
2755     if ( depth == 0 ) {
2756         while (first_non_open && OP(first_non_open) == OPEN)
2757             first_non_open=regnext(first_non_open);
2758     }
2759
2760
2761   fake_study_recurse:
2762     while ( scan && OP(scan) != END && scan < last ){
2763         /* Peephole optimizer: */
2764         DEBUG_STUDYDATA("Peep:", data,depth);
2765         DEBUG_PEEP("Peep",scan,depth);
2766         JOIN_EXACT(scan,&min,0);
2767
2768         /* Follow the next-chain of the current node and optimize
2769            away all the NOTHINGs from it.  */
2770         if (OP(scan) != CURLYX) {
2771             const int max = (reg_off_by_arg[OP(scan)]
2772                        ? I32_MAX
2773                        /* I32 may be smaller than U16 on CRAYs! */
2774                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
2775             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
2776             int noff;
2777             regnode *n = scan;
2778         
2779             /* Skip NOTHING and LONGJMP. */
2780             while ((n = regnext(n))
2781                    && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
2782                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
2783                    && off + noff < max)
2784                 off += noff;
2785             if (reg_off_by_arg[OP(scan)])
2786                 ARG(scan) = off;
2787             else
2788                 NEXT_OFF(scan) = off;
2789         }
2790
2791
2792
2793         /* The principal pseudo-switch.  Cannot be a switch, since we
2794            look into several different things.  */
2795         if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
2796                    || OP(scan) == IFTHEN) {
2797             next = regnext(scan);
2798             code = OP(scan);
2799             /* demq: the op(next)==code check is to see if we have "branch-branch" AFAICT */
2800         
2801             if (OP(next) == code || code == IFTHEN) {
2802                 /* NOTE - There is similar code to this block below for handling
2803                    TRIE nodes on a re-study.  If you change stuff here check there
2804                    too. */
2805                 I32 max1 = 0, min1 = I32_MAX, num = 0;
2806                 struct regnode_charclass_class accum;
2807                 regnode * const startbranch=scan;
2808                 
2809                 if (flags & SCF_DO_SUBSTR)
2810                     SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot merge strings after this. */
2811                 if (flags & SCF_DO_STCLASS)
2812                     cl_init_zero(pRExC_state, &accum);
2813
2814                 while (OP(scan) == code) {
2815                     I32 deltanext, minnext, f = 0, fake;
2816                     struct regnode_charclass_class this_class;
2817
2818                     num++;
2819                     data_fake.flags = 0;
2820                     if (data) {
2821                         data_fake.whilem_c = data->whilem_c;
2822                         data_fake.last_closep = data->last_closep;
2823                     }
2824                     else
2825                         data_fake.last_closep = &fake;
2826
2827                     data_fake.pos_delta = delta;
2828                     next = regnext(scan);
2829                     scan = NEXTOPER(scan);
2830                     if (code != BRANCH)
2831                         scan = NEXTOPER(scan);
2832                     if (flags & SCF_DO_STCLASS) {
2833                         cl_init(pRExC_state, &this_class);
2834                         data_fake.start_class = &this_class;
2835                         f = SCF_DO_STCLASS_AND;
2836                     }
2837                     if (flags & SCF_WHILEM_VISITED_POS)
2838                         f |= SCF_WHILEM_VISITED_POS;
2839
2840                     /* we suppose the run is continuous, last=next...*/
2841                     minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
2842                                           next, &data_fake,
2843                                           stopparen, recursed, NULL, f,depth+1);
2844                     if (min1 > minnext)
2845                         min1 = minnext;
2846                     if (max1 < minnext + deltanext)
2847                         max1 = minnext + deltanext;
2848                     if (deltanext == I32_MAX)
2849                         is_inf = is_inf_internal = 1;
2850                     scan = next;
2851                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
2852                         pars++;
2853                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
2854                         if ( stopmin > minnext) 
2855                             stopmin = min + min1;
2856                         flags &= ~SCF_DO_SUBSTR;
2857                         if (data)
2858                             data->flags |= SCF_SEEN_ACCEPT;
2859                     }
2860                     if (data) {
2861                         if (data_fake.flags & SF_HAS_EVAL)
2862                             data->flags |= SF_HAS_EVAL;
2863                         data->whilem_c = data_fake.whilem_c;
2864                     }
2865                     if (flags & SCF_DO_STCLASS)
2866                         cl_or(pRExC_state, &accum, &this_class);
2867                 }
2868                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
2869                     min1 = 0;
2870                 if (flags & SCF_DO_SUBSTR) {
2871                     data->pos_min += min1;
2872                     data->pos_delta += max1 - min1;
2873                     if (max1 != min1 || is_inf)
2874                         data->longest = &(data->longest_float);
2875                 }
2876                 min += min1;
2877                 delta += max1 - min1;
2878                 if (flags & SCF_DO_STCLASS_OR) {
2879                     cl_or(pRExC_state, data->start_class, &accum);
2880                     if (min1) {
2881                         cl_and(data->start_class, and_withp);
2882                         flags &= ~SCF_DO_STCLASS;
2883                     }
2884                 }
2885                 else if (flags & SCF_DO_STCLASS_AND) {
2886                     if (min1) {
2887                         cl_and(data->start_class, &accum);
2888                         flags &= ~SCF_DO_STCLASS;
2889                     }
2890                     else {
2891                         /* Switch to OR mode: cache the old value of
2892                          * data->start_class */
2893                         INIT_AND_WITHP;
2894                         StructCopy(data->start_class, and_withp,
2895                                    struct regnode_charclass_class);
2896                         flags &= ~SCF_DO_STCLASS_AND;
2897                         StructCopy(&accum, data->start_class,
2898                                    struct regnode_charclass_class);
2899                         flags |= SCF_DO_STCLASS_OR;
2900                         data->start_class->flags |= ANYOF_EOS;
2901                     }
2902                 }
2903
2904                 if (PERL_ENABLE_TRIE_OPTIMISATION && OP( startbranch ) == BRANCH ) {
2905                 /* demq.
2906
2907                    Assuming this was/is a branch we are dealing with: 'scan' now
2908                    points at the item that follows the branch sequence, whatever
2909                    it is. We now start at the beginning of the sequence and look
2910                    for subsequences of
2911
2912                    BRANCH->EXACT=>x1
2913                    BRANCH->EXACT=>x2
2914                    tail
2915
2916                    which would be constructed from a pattern like /A|LIST|OF|WORDS/
2917
2918                    If we can find such a subsequence we need to turn the first
2919                    element into a trie and then add the subsequent branch exact
2920                    strings to the trie.
2921
2922                    We have two cases
2923
2924                      1. patterns where the whole set of branches can be converted. 
2925
2926                      2. patterns where only a subset can be converted.
2927
2928                    In case 1 we can replace the whole set with a single regop
2929                    for the trie. In case 2 we need to keep the start and end
2930                    branches so
2931
2932                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
2933                      becomes BRANCH TRIE; BRANCH X;
2934
2935                   There is an additional case, that being where there is a 
2936                   common prefix, which gets split out into an EXACT like node
2937                   preceding the TRIE node.
2938
2939                   If x(1..n)==tail then we can do a simple trie, if not we make
2940                   a "jump" trie, such that when we match the appropriate word
2941                   we "jump" to the appropriate tail node. Essentially we turn
2942                   a nested if into a case structure of sorts.
2943
2944                 */
2945                 
2946                     int made=0;
2947                     if (!re_trie_maxbuff) {
2948                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
2949                         if (!SvIOK(re_trie_maxbuff))
2950                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
2951                     }
2952                     if ( SvIV(re_trie_maxbuff)>=0  ) {
2953                         regnode *cur;
2954                         regnode *first = (regnode *)NULL;
2955                         regnode *last = (regnode *)NULL;
2956                         regnode *tail = scan;
2957                         U8 optype = 0;
2958                         U32 count=0;
2959
2960 #ifdef DEBUGGING
2961                         SV * const mysv = sv_newmortal();       /* for dumping */
2962 #endif
2963                         /* var tail is used because there may be a TAIL
2964                            regop in the way. Ie, the exacts will point to the
2965                            thing following the TAIL, but the last branch will
2966                            point at the TAIL. So we advance tail. If we
2967                            have nested (?:) we may have to move through several
2968                            tails.
2969                          */
2970
2971                         while ( OP( tail ) == TAIL ) {
2972                             /* this is the TAIL generated by (?:) */
2973                             tail = regnext( tail );
2974                         }
2975
2976                         
2977                         DEBUG_OPTIMISE_r({
2978                             regprop(RExC_rx, mysv, tail );
2979                             PerlIO_printf( Perl_debug_log, "%*s%s%s\n",
2980                                 (int)depth * 2 + 2, "", 
2981                                 "Looking for TRIE'able sequences. Tail node is: ", 
2982                                 SvPV_nolen_const( mysv )
2983                             );
2984                         });
2985                         
2986                         /*
2987
2988                            step through the branches, cur represents each
2989                            branch, noper is the first thing to be matched
2990                            as part of that branch and noper_next is the
2991                            regnext() of that node. if noper is an EXACT
2992                            and noper_next is the same as scan (our current
2993                            position in the regex) then the EXACT branch is
2994                            a possible optimization target. Once we have
2995                            two or more consecutive such branches we can
2996                            create a trie of the EXACT's contents and stich
2997                            it in place. If the sequence represents all of
2998                            the branches we eliminate the whole thing and
2999                            replace it with a single TRIE. If it is a
3000                            subsequence then we need to stitch it in. This
3001                            means the first branch has to remain, and needs
3002                            to be repointed at the item on the branch chain
3003                            following the last branch optimized. This could
3004                            be either a BRANCH, in which case the
3005                            subsequence is internal, or it could be the
3006                            item following the branch sequence in which
3007                            case the subsequence is at the end.
3008
3009                         */
3010
3011                         /* dont use tail as the end marker for this traverse */
3012                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
3013                             regnode * const noper = NEXTOPER( cur );
3014 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
3015                             regnode * const noper_next = regnext( noper );
3016 #endif
3017
3018                             DEBUG_OPTIMISE_r({
3019                                 regprop(RExC_rx, mysv, cur);
3020                                 PerlIO_printf( Perl_debug_log, "%*s- %s (%d)",
3021                                    (int)depth * 2 + 2,"", SvPV_nolen_const( mysv ), REG_NODE_NUM(cur) );
3022
3023                                 regprop(RExC_rx, mysv, noper);
3024                                 PerlIO_printf( Perl_debug_log, " -> %s",
3025                                     SvPV_nolen_const(mysv));
3026
3027                                 if ( noper_next ) {
3028                                   regprop(RExC_rx, mysv, noper_next );
3029                                   PerlIO_printf( Perl_debug_log,"\t=> %s\t",
3030                                     SvPV_nolen_const(mysv));
3031                                 }
3032                                 PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d)\n",
3033                                    REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur) );
3034                             });
3035                             if ( (((first && optype!=NOTHING) ? OP( noper ) == optype
3036                                          : PL_regkind[ OP( noper ) ] == EXACT )
3037                                   || OP(noper) == NOTHING )
3038 #ifdef NOJUMPTRIE
3039                                   && noper_next == tail
3040 #endif
3041                                   && count < U16_MAX)
3042                             {
3043                                 count++;
3044                                 if ( !first || optype == NOTHING ) {
3045                                     if (!first) first = cur;
3046                                     optype = OP( noper );
3047                                 } else {
3048                                     last = cur;
3049                                 }
3050                             } else {
3051 /* 
3052     Currently the trie logic handles case insensitive matching properly only
3053     when the pattern is UTF-8 and the node is EXACTFU (thus forcing unicode
3054     semantics).
3055
3056     If/when this is fixed the following define can be swapped
3057     in below to fully enable trie logic.
3058
3059 #define TRIE_TYPE_IS_SAFE 1
3060
3061 */
3062 #define TRIE_TYPE_IS_SAFE ((UTF && optype == EXACTFU) || optype==EXACT)
3063
3064                                 if ( last && TRIE_TYPE_IS_SAFE ) {
3065                                     make_trie( pRExC_state, 
3066                                             startbranch, first, cur, tail, count, 
3067                                             optype, depth+1 );
3068                                 }
3069                                 if ( PL_regkind[ OP( noper ) ] == EXACT
3070 #ifdef NOJUMPTRIE
3071                                      && noper_next == tail
3072 #endif
3073                                 ){
3074                                     count = 1;
3075                                     first = cur;
3076                                     optype = OP( noper );
3077                                 } else {
3078                                     count = 0;
3079                                     first = NULL;
3080                                     optype = 0;
3081                                 }
3082                                 last = NULL;
3083                             }
3084                         }
3085                         DEBUG_OPTIMISE_r({
3086                             regprop(RExC_rx, mysv, cur);
3087                             PerlIO_printf( Perl_debug_log,
3088                               "%*s- %s (%d) <SCAN FINISHED>\n", (int)depth * 2 + 2,
3089                               "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
3090
3091                         });
3092                         
3093                         if ( last && TRIE_TYPE_IS_SAFE ) {
3094                             made= make_trie( pRExC_state, startbranch, first, scan, tail, count, optype, depth+1 );
3095 #ifdef TRIE_STUDY_OPT   
3096                             if ( ((made == MADE_EXACT_TRIE && 
3097                                  startbranch == first) 
3098                                  || ( first_non_open == first )) && 
3099                                  depth==0 ) {
3100                                 flags |= SCF_TRIE_RESTUDY;
3101                                 if ( startbranch == first 
3102                                      && scan == tail ) 
3103                                 {
3104                                     RExC_seen &=~REG_TOP_LEVEL_BRANCHES;
3105                                 }
3106                             }
3107 #endif
3108                         }
3109                     }
3110                     
3111                 } /* do trie */
3112                 
3113             }
3114             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
3115                 scan = NEXTOPER(NEXTOPER(scan));
3116             } else                      /* single branch is optimized. */
3117                 scan = NEXTOPER(scan);
3118             continue;
3119         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB || OP(scan) == GOSTART) {
3120             scan_frame *newframe = NULL;
3121             I32 paren;
3122             regnode *start;
3123             regnode *end;
3124
3125             if (OP(scan) != SUSPEND) {
3126             /* set the pointer */
3127                 if (OP(scan) == GOSUB) {
3128                     paren = ARG(scan);
3129                     RExC_recurse[ARG2L(scan)] = scan;
3130                     start = RExC_open_parens[paren-1];
3131                     end   = RExC_close_parens[paren-1];
3132                 } else {
3133                     paren = 0;
3134                     start = RExC_rxi->program + 1;
3135                     end   = RExC_opend;
3136                 }
3137                 if (!recursed) {
3138                     Newxz(recursed, (((RExC_npar)>>3) +1), U8);
3139                     SAVEFREEPV(recursed);
3140                 }
3141                 if (!PAREN_TEST(recursed,paren+1)) {
3142                     PAREN_SET(recursed,paren+1);
3143                     Newx(newframe,1,scan_frame);
3144                 } else {
3145                     if (flags & SCF_DO_SUBSTR) {
3146                         SCAN_COMMIT(pRExC_state,data,minlenp);
3147                         data->longest = &(data->longest_float);
3148                     }
3149                     is_inf = is_inf_internal = 1;
3150                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3151                         cl_anything(pRExC_state, data->start_class);
3152                     flags &= ~SCF_DO_STCLASS;
3153                 }
3154             } else {
3155                 Newx(newframe,1,scan_frame);
3156                 paren = stopparen;
3157                 start = scan+2;
3158                 end = regnext(scan);
3159             }
3160             if (newframe) {
3161                 assert(start);
3162                 assert(end);
3163                 SAVEFREEPV(newframe);
3164                 newframe->next = regnext(scan);
3165                 newframe->last = last;
3166                 newframe->stop = stopparen;
3167                 newframe->prev = frame;
3168
3169                 frame = newframe;
3170                 scan =  start;
3171                 stopparen = paren;
3172                 last = end;
3173
3174                 continue;
3175             }
3176         }
3177         else if (OP(scan) == EXACT) {
3178             I32 l = STR_LEN(scan);
3179             UV uc;
3180             if (UTF) {
3181                 const U8 * const s = (U8*)STRING(scan);
3182                 l = utf8_length(s, s + l);
3183                 uc = utf8_to_uvchr(s, NULL);
3184             } else {
3185                 uc = *((U8*)STRING(scan));
3186             }
3187             min += l;
3188             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
3189                 /* The code below prefers earlier match for fixed
3190                    offset, later match for variable offset.  */
3191                 if (data->last_end == -1) { /* Update the start info. */
3192                     data->last_start_min = data->pos_min;
3193                     data->last_start_max = is_inf
3194                         ? I32_MAX : data->pos_min + data->pos_delta;
3195                 }
3196                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
3197                 if (UTF)
3198                     SvUTF8_on(data->last_found);
3199                 {
3200                     SV * const sv = data->last_found;
3201                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3202                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
3203                     if (mg && mg->mg_len >= 0)
3204                         mg->mg_len += utf8_length((U8*)STRING(scan),
3205                                                   (U8*)STRING(scan)+STR_LEN(scan));
3206                 }
3207                 data->last_end = data->pos_min + l;
3208                 data->pos_min += l; /* As in the first entry. */
3209                 data->flags &= ~SF_BEFORE_EOL;
3210             }
3211             if (flags & SCF_DO_STCLASS_AND) {
3212                 /* Check whether it is compatible with what we know already! */
3213                 int compat = 1;
3214
3215
3216                 /* If compatible, we or it in below.  It is compatible if is
3217                  * in the bitmp and either 1) its bit or its fold is set, or 2)
3218                  * it's for a locale.  Even if there isn't unicode semantics
3219                  * here, at runtime there may be because of matching against a
3220                  * utf8 string, so accept a possible false positive for
3221                  * latin1-range folds */
3222                 if (uc >= 0x100 ||
3223                     (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3224                     && !ANYOF_BITMAP_TEST(data->start_class, uc)
3225                     && (!(data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD)
3226                         || !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3227                     )
3228                 {
3229                     compat = 0;
3230                 }
3231                 ANYOF_CLASS_ZERO(data->start_class);
3232                 ANYOF_BITMAP_ZERO(data->start_class);
3233                 if (compat)
3234                     ANYOF_BITMAP_SET(data->start_class, uc);
3235                 else if (uc >= 0x100) {
3236                     int i;
3237
3238                     /* Some Unicode code points fold to the Latin1 range; as
3239                      * XXX temporary code, instead of figuring out if this is
3240                      * one, just assume it is and set all the start class bits
3241                      * that could be some such above 255 code point's fold
3242                      * which will generate fals positives.  As the code
3243                      * elsewhere that does compute the fold settles down, it
3244                      * can be extracted out and re-used here */
3245                     for (i = 0; i < 256; i++){
3246                         if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
3247                             ANYOF_BITMAP_SET(data->start_class, i);
3248                         }
3249                     }
3250                 }
3251                 data->start_class->flags &= ~ANYOF_EOS;
3252                 if (uc < 0x100)
3253                   data->start_class->flags &= ~ANYOF_UNICODE_ALL;
3254             }
3255             else if (flags & SCF_DO_STCLASS_OR) {
3256                 /* false positive possible if the class is case-folded */
3257                 if (uc < 0x100)
3258                     ANYOF_BITMAP_SET(data->start_class, uc);
3259                 else
3260                     data->start_class->flags |= ANYOF_UNICODE_ALL;
3261                 data->start_class->flags &= ~ANYOF_EOS;
3262                 cl_and(data->start_class, and_withp);
3263             }
3264             flags &= ~SCF_DO_STCLASS;
3265         }
3266         else if (PL_regkind[OP(scan)] == EXACT) { /* But OP != EXACT! */
3267             I32 l = STR_LEN(scan);
3268             UV uc = *((U8*)STRING(scan));
3269
3270             /* Search for fixed substrings supports EXACT only. */
3271             if (flags & SCF_DO_SUBSTR) {
3272                 assert(data);
3273                 SCAN_COMMIT(pRExC_state, data, minlenp);
3274             }
3275             if (UTF) {
3276                 const U8 * const s = (U8 *)STRING(scan);
3277                 l = utf8_length(s, s + l);
3278                 uc = utf8_to_uvchr(s, NULL);
3279             }
3280             min += l;
3281             if (flags & SCF_DO_SUBSTR)
3282                 data->pos_min += l;
3283             if (flags & SCF_DO_STCLASS_AND) {
3284                 /* Check whether it is compatible with what we know already! */
3285                 int compat = 1;
3286                 if (uc >= 0x100 ||
3287                  (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3288                   && !ANYOF_BITMAP_TEST(data->start_class, uc)
3289                   && !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3290                 {
3291                     compat = 0;
3292                 }
3293                 ANYOF_CLASS_ZERO(data->start_class);
3294                 ANYOF_BITMAP_ZERO(data->start_class);
3295                 if (compat) {
3296                     ANYOF_BITMAP_SET(data->start_class, uc);
3297                     data->start_class->flags &= ~ANYOF_EOS;
3298                     data->start_class->flags |= ANYOF_LOC_NONBITMAP_FOLD;
3299                     if (OP(scan) == EXACTFL) {
3300                         /* XXX This set is probably no longer necessary, and
3301                          * probably wrong as LOCALE now is on in the initial
3302                          * state */
3303                         data->start_class->flags |= ANYOF_LOCALE;
3304                     }
3305                     else {
3306
3307                         /* Also set the other member of the fold pair.  In case
3308                          * that unicode semantics is called for at runtime, use
3309                          * the full latin1 fold.  (Can't do this for locale,
3310                          * because not known until runtime */
3311                         ANYOF_BITMAP_SET(data->start_class, PL_fold_latin1[uc]);
3312                     }
3313                 }
3314                 else if (uc >= 0x100) {
3315                     int i;
3316                     for (i = 0; i < 256; i++){
3317                         if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
3318                             ANYOF_BITMAP_SET(data->start_class, i);
3319                         }
3320                     }
3321                 }
3322             }
3323             else if (flags & SCF_DO_STCLASS_OR) {
3324                 if (data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD) {
3325                     /* false positive possible if the class is case-folded.
3326                        Assume that the locale settings are the same... */
3327                     if (uc < 0x100) {
3328                         ANYOF_BITMAP_SET(data->start_class, uc);
3329                         if (OP(scan) != EXACTFL) {
3330
3331                             /* And set the other member of the fold pair, but
3332                              * can't do that in locale because not known until
3333                              * run-time */
3334                             ANYOF_BITMAP_SET(data->start_class,
3335                                              PL_fold_latin1[uc]);
3336                         }
3337                     }
3338                     data->start_class->flags &= ~ANYOF_EOS;
3339                 }
3340                 cl_and(data->start_class, and_withp);
3341             }
3342             flags &= ~SCF_DO_STCLASS;
3343         }
3344         else if (REGNODE_VARIES(OP(scan))) {
3345             I32 mincount, maxcount, minnext, deltanext, fl = 0;
3346             I32 f = flags, pos_before = 0;
3347             regnode * const oscan = scan;
3348             struct regnode_charclass_class this_class;
3349             struct regnode_charclass_class *oclass = NULL;
3350             I32 next_is_eval = 0;
3351
3352             switch (PL_regkind[OP(scan)]) {
3353             case WHILEM:                /* End of (?:...)* . */
3354                 scan = NEXTOPER(scan);
3355                 goto finish;
3356             case PLUS:
3357                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
3358                     next = NEXTOPER(scan);
3359                     if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
3360                         mincount = 1;
3361                         maxcount = REG_INFTY;
3362                         next = regnext(scan);
3363                         scan = NEXTOPER(scan);
3364                         goto do_curly;
3365                     }
3366                 }
3367                 if (flags & SCF_DO_SUBSTR)
3368                     data->pos_min++;
3369                 min++;
3370                 /* Fall through. */
3371             case STAR:
3372                 if (flags & SCF_DO_STCLASS) {
3373                     mincount = 0;
3374                     maxcount = REG_INFTY;
3375                     next = regnext(scan);
3376                     scan = NEXTOPER(scan);
3377                     goto do_curly;
3378                 }
3379                 is_inf = is_inf_internal = 1;
3380                 scan = regnext(scan);
3381                 if (flags & SCF_DO_SUBSTR) {
3382                     SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot extend fixed substrings */
3383                     data->longest = &(data->longest_float);
3384                 }
3385                 goto optimize_curly_tail;
3386             case CURLY:
3387                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
3388                     && (scan->flags == stopparen))
3389                 {
3390                     mincount = 1;
3391                     maxcount = 1;
3392                 } else {
3393                     mincount = ARG1(scan);
3394                     maxcount = ARG2(scan);
3395                 }
3396                 next = regnext(scan);
3397                 if (OP(scan) == CURLYX) {
3398                     I32 lp = (data ? *(data->last_closep) : 0);
3399                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
3400                 }
3401                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3402                 next_is_eval = (OP(scan) == EVAL);
3403               do_curly:
3404                 if (flags & SCF_DO_SUBSTR) {
3405                     if (mincount == 0) SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot extend fixed substrings */
3406                     pos_before = data->pos_min;
3407                 }
3408                 if (data) {
3409                     fl = data->flags;
3410                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
3411                     if (is_inf)
3412                         data->flags |= SF_IS_INF;
3413                 }
3414                 if (flags & SCF_DO_STCLASS) {
3415                     cl_init(pRExC_state, &this_class);
3416                     oclass = data->start_class;
3417                     data->start_class = &this_class;
3418                     f |= SCF_DO_STCLASS_AND;
3419                     f &= ~SCF_DO_STCLASS_OR;
3420                 }
3421                 /* Exclude from super-linear cache processing any {n,m}
3422                    regops for which the combination of input pos and regex
3423                    pos is not enough information to determine if a match
3424                    will be possible.
3425
3426                    For example, in the regex /foo(bar\s*){4,8}baz/ with the
3427                    regex pos at the \s*, the prospects for a match depend not
3428                    only on the input position but also on how many (bar\s*)
3429                    repeats into the {4,8} we are. */
3430                if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
3431                     f &= ~SCF_WHILEM_VISITED_POS;
3432
3433                 /* This will finish on WHILEM, setting scan, or on NULL: */
3434                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, 
3435                                       last, data, stopparen, recursed, NULL,
3436                                       (mincount == 0
3437                                         ? (f & ~SCF_DO_SUBSTR) : f),depth+1);
3438
3439                 if (flags & SCF_DO_STCLASS)
3440                     data->start_class = oclass;
3441                 if (mincount == 0 || minnext == 0) {
3442                     if (flags & SCF_DO_STCLASS_OR) {
3443                         cl_or(pRExC_state, data->start_class, &this_class);
3444                     }
3445                     else if (flags & SCF_DO_STCLASS_AND) {
3446                         /* Switch to OR mode: cache the old value of
3447                          * data->start_class */
3448                         INIT_AND_WITHP;
3449                         StructCopy(data->start_class, and_withp,
3450                                    struct regnode_charclass_class);
3451                         flags &= ~SCF_DO_STCLASS_AND;
3452                         StructCopy(&this_class, data->start_class,
3453                                    struct regnode_charclass_class);
3454                         flags |= SCF_DO_STCLASS_OR;
3455                         data->start_class->flags |= ANYOF_EOS;
3456                     }
3457                 } else {                /* Non-zero len */
3458                     if (flags & SCF_DO_STCLASS_OR) {
3459                         cl_or(pRExC_state, data->start_class, &this_class);
3460                         cl_and(data->start_class, and_withp);
3461                     }
3462                     else if (flags & SCF_DO_STCLASS_AND)
3463                         cl_and(data->start_class, &this_class);
3464                     flags &= ~SCF_DO_STCLASS;
3465                 }
3466                 if (!scan)              /* It was not CURLYX, but CURLY. */
3467                     scan = next;
3468                 if ( /* ? quantifier ok, except for (?{ ... }) */
3469                     (next_is_eval || !(mincount == 0 && maxcount == 1))
3470                     && (minnext == 0) && (deltanext == 0)
3471                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
3472                     && maxcount <= REG_INFTY/3) /* Complement check for big count */
3473                 {
3474                     ckWARNreg(RExC_parse,
3475                               "Quantifier unexpected on zero-length expression");
3476                 }
3477
3478                 min += minnext * mincount;
3479                 is_inf_internal |= ((maxcount == REG_INFTY
3480                                      && (minnext + deltanext) > 0)
3481                                     || deltanext == I32_MAX);
3482                 is_inf |= is_inf_internal;
3483                 delta += (minnext + deltanext) * maxcount - minnext * mincount;
3484
3485                 /* Try powerful optimization CURLYX => CURLYN. */
3486                 if (  OP(oscan) == CURLYX && data
3487                       && data->flags & SF_IN_PAR
3488                       && !(data->flags & SF_HAS_EVAL)
3489                       && !deltanext && minnext == 1 ) {
3490                     /* Try to optimize to CURLYN.  */
3491                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
3492                     regnode * const nxt1 = nxt;
3493 #ifdef DEBUGGING
3494                     regnode *nxt2;
3495 #endif
3496
3497                     /* Skip open. */
3498                     nxt = regnext(nxt);
3499                     if (!REGNODE_SIMPLE(OP(nxt))
3500                         && !(PL_regkind[OP(nxt)] == EXACT
3501                              && STR_LEN(nxt) == 1))
3502                         goto nogo;
3503 #ifdef DEBUGGING
3504                     nxt2 = nxt;
3505 #endif
3506                     nxt = regnext(nxt);
3507                     if (OP(nxt) != CLOSE)
3508                         goto nogo;
3509                     if (RExC_open_parens) {
3510                         RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3511                         RExC_close_parens[ARG(nxt1)-1]=nxt+2; /*close->while*/
3512                     }
3513                     /* Now we know that nxt2 is the only contents: */
3514                     oscan->flags = (U8)ARG(nxt);
3515                     OP(oscan) = CURLYN;
3516                     OP(nxt1) = NOTHING; /* was OPEN. */
3517
3518 #ifdef DEBUGGING
3519                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3520                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
3521                     NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
3522                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
3523                     OP(nxt + 1) = OPTIMIZED; /* was count. */
3524                     NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
3525 #endif
3526                 }
3527               nogo:
3528
3529                 /* Try optimization CURLYX => CURLYM. */
3530                 if (  OP(oscan) == CURLYX && data
3531                       && !(data->flags & SF_HAS_PAR)
3532                       && !(data->flags & SF_HAS_EVAL)
3533                       && !deltanext     /* atom is fixed width */
3534                       && minnext != 0   /* CURLYM can't handle zero width */
3535                 ) {
3536                     /* XXXX How to optimize if data == 0? */
3537                     /* Optimize to a simpler form.  */
3538                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
3539                     regnode *nxt2;
3540
3541                     OP(oscan) = CURLYM;
3542                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
3543                             && (OP(nxt2) != WHILEM))
3544                         nxt = nxt2;
3545                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
3546                     /* Need to optimize away parenths. */
3547                     if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
3548                         /* Set the parenth number.  */
3549                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
3550
3551                         oscan->flags = (U8)ARG(nxt);
3552                         if (RExC_open_parens) {
3553                             RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3554                             RExC_close_parens[ARG(nxt1)-1]=nxt2+1; /*close->NOTHING*/
3555                         }
3556                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
3557                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
3558
3559 #ifdef DEBUGGING
3560                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3561                         OP(nxt + 1) = OPTIMIZED; /* was count. */
3562                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
3563                         NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
3564 #endif
3565 #if 0
3566                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
3567                             regnode *nnxt = regnext(nxt1);
3568                             if (nnxt == nxt) {
3569                                 if (reg_off_by_arg[OP(nxt1)])
3570                                     ARG_SET(nxt1, nxt2 - nxt1);
3571                                 else if (nxt2 - nxt1 < U16_MAX)
3572                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
3573                                 else
3574                                     OP(nxt) = NOTHING;  /* Cannot beautify */
3575                             }
3576                             nxt1 = nnxt;
3577                         }
3578 #endif
3579                         /* Optimize again: */
3580                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
3581                                     NULL, stopparen, recursed, NULL, 0,depth+1);
3582                     }
3583                     else
3584                         oscan->flags = 0;
3585                 }
3586                 else if ((OP(oscan) == CURLYX)
3587                          && (flags & SCF_WHILEM_VISITED_POS)
3588                          /* See the comment on a similar expression above.
3589                             However, this time it's not a subexpression
3590                             we care about, but the expression itself. */
3591                          && (maxcount == REG_INFTY)
3592                          && data && ++data->whilem_c < 16) {
3593                     /* This stays as CURLYX, we can put the count/of pair. */
3594                     /* Find WHILEM (as in regexec.c) */
3595                     regnode *nxt = oscan + NEXT_OFF(oscan);
3596
3597                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
3598                         nxt += ARG(nxt);
3599                     PREVOPER(nxt)->flags = (U8)(data->whilem_c
3600                         | (RExC_whilem_seen << 4)); /* On WHILEM */
3601                 }
3602                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
3603                     pars++;
3604                 if (flags & SCF_DO_SUBSTR) {
3605                     SV *last_str = NULL;
3606                     int counted = mincount != 0;
3607
3608                     if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
3609 #if defined(SPARC64_GCC_WORKAROUND)
3610                         I32 b = 0;
3611                         STRLEN l = 0;
3612                         const char *s = NULL;
3613                         I32 old = 0;
3614
3615                         if (pos_before >= data->last_start_min)
3616                             b = pos_before;
3617                         else
3618                             b = data->last_start_min;
3619
3620                         l = 0;
3621                         s = SvPV_const(data->last_found, l);
3622                         old = b - data->last_start_min;
3623
3624 #else
3625                         I32 b = pos_before >= data->last_start_min
3626                             ? pos_before : data->last_start_min;
3627                         STRLEN l;
3628                         const char * const s = SvPV_const(data->last_found, l);
3629                         I32 old = b - data->last_start_min;
3630 #endif
3631
3632                         if (UTF)
3633                             old = utf8_hop((U8*)s, old) - (U8*)s;
3634                         l -= old;
3635                         /* Get the added string: */
3636                         last_str = newSVpvn_utf8(s  + old, l, UTF);
3637                         if (deltanext == 0 && pos_before == b) {
3638                             /* What was added is a constant string */
3639                             if (mincount > 1) {
3640                                 SvGROW(last_str, (mincount * l) + 1);
3641                                 repeatcpy(SvPVX(last_str) + l,
3642                                           SvPVX_const(last_str), l, mincount - 1);
3643                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
3644                                 /* Add additional parts. */
3645                                 SvCUR_set(data->last_found,
3646                                           SvCUR(data->last_found) - l);
3647                                 sv_catsv(data->last_found, last_str);
3648                                 {
3649                                     SV * sv = data->last_found;
3650                                     MAGIC *mg =
3651                                         SvUTF8(sv) && SvMAGICAL(sv) ?
3652                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
3653                                     if (mg && mg->mg_len >= 0)
3654                                         mg->mg_len += CHR_SVLEN(last_str) - l;
3655                                 }
3656                                 data->last_end += l * (mincount - 1);
3657                             }
3658                         } else {
3659                             /* start offset must point into the last copy */
3660                             data->last_start_min += minnext * (mincount - 1);
3661                             data->last_start_max += is_inf ? I32_MAX
3662                                 : (maxcount - 1) * (minnext + data->pos_delta);
3663                         }
3664                     }
3665                     /* It is counted once already... */
3666                     data->pos_min += minnext * (mincount - counted);
3667                     data->pos_delta += - counted * deltanext +
3668                         (minnext + deltanext) * maxcount - minnext * mincount;
3669                     if (mincount != maxcount) {
3670                          /* Cannot extend fixed substrings found inside
3671                             the group.  */
3672                         SCAN_COMMIT(pRExC_state,data,minlenp);
3673                         if (mincount && last_str) {
3674                             SV * const sv = data->last_found;
3675                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3676                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
3677
3678                             if (mg)
3679                                 mg->mg_len = -1;
3680                             sv_setsv(sv, last_str);
3681                             data->last_end = data->pos_min;
3682                             data->last_start_min =
3683                                 data->pos_min - CHR_SVLEN(last_str);
3684                             data->last_start_max = is_inf
3685                                 ? I32_MAX
3686                                 : data->pos_min + data->pos_delta
3687                                 - CHR_SVLEN(last_str);
3688                         }
3689                         data->longest = &(data->longest_float);
3690                     }
3691                     SvREFCNT_dec(last_str);
3692                 }
3693                 if (data && (fl & SF_HAS_EVAL))
3694                     data->flags |= SF_HAS_EVAL;
3695               optimize_curly_tail:
3696                 if (OP(oscan) != CURLYX) {
3697                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
3698                            && NEXT_OFF(next))
3699                         NEXT_OFF(oscan) += NEXT_OFF(next);
3700                 }
3701                 continue;
3702             default:                    /* REF, ANYOFV, and CLUMP only? */
3703                 if (flags & SCF_DO_SUBSTR) {
3704                     SCAN_COMMIT(pRExC_state,data,minlenp);      /* Cannot expect anything... */
3705                     data->longest = &(data->longest_float);
3706                 }
3707                 is_inf = is_inf_internal = 1;
3708                 if (flags & SCF_DO_STCLASS_OR)
3709                     cl_anything(pRExC_state, data->start_class);
3710                 flags &= ~SCF_DO_STCLASS;
3711                 break;
3712             }
3713         }
3714         else if (OP(scan) == LNBREAK) {
3715             if (flags & SCF_DO_STCLASS) {
3716                 int value = 0;
3717                 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
3718                 if (flags & SCF_DO_STCLASS_AND) {
3719                     for (value = 0; value < 256; value++)
3720                         if (!is_VERTWS_cp(value))
3721                             ANYOF_BITMAP_CLEAR(data->start_class, value);
3722                 }
3723                 else {
3724                     for (value = 0; value < 256; value++)
3725                         if (is_VERTWS_cp(value))
3726                             ANYOF_BITMAP_SET(data->start_class, value);
3727                 }
3728                 if (flags & SCF_DO_STCLASS_OR)
3729                     cl_and(data->start_class, and_withp);
3730                 flags &= ~SCF_DO_STCLASS;
3731             }
3732             min += 1;
3733             delta += 1;
3734             if (flags & SCF_DO_SUBSTR) {
3735                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
3736                 data->pos_min += 1;
3737                 data->pos_delta += 1;
3738                 data->longest = &(data->longest_float);
3739             }
3740         }
3741         else if (OP(scan) == FOLDCHAR) {
3742             int d = ARG(scan) == LATIN_SMALL_LETTER_SHARP_S ? 1 : 2;
3743             flags &= ~SCF_DO_STCLASS;
3744             min += 1;
3745             delta += d;
3746             if (flags & SCF_DO_SUBSTR) {
3747                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
3748                 data->pos_min += 1;
3749                 data->pos_delta += d;
3750                 data->longest = &(data->longest_float);
3751             }
3752         }
3753         else if (REGNODE_SIMPLE(OP(scan))) {
3754             int value = 0;
3755
3756             if (flags & SCF_DO_SUBSTR) {
3757                 SCAN_COMMIT(pRExC_state,data,minlenp);
3758                 data->pos_min++;
3759             }
3760             min++;
3761             if (flags & SCF_DO_STCLASS) {
3762                 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
3763
3764                 /* Some of the logic below assumes that switching
3765                    locale on will only add false positives. */
3766                 switch (PL_regkind[OP(scan)]) {
3767                 case SANY:
3768                 default:
3769                   do_default:
3770                     /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */
3771                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3772                         cl_anything(pRExC_state, data->start_class);
3773                     break;
3774                 case REG_ANY:
3775                     if (OP(scan) == SANY)
3776                         goto do_default;
3777                     if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
3778                         value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
3779                                  || ANYOF_CLASS_TEST_ANY_SET(data->start_class));
3780                         cl_anything(pRExC_state, data->start_class);
3781                     }
3782                     if (flags & SCF_DO_STCLASS_AND || !value)
3783                         ANYOF_BITMAP_CLEAR(data->start_class,'\n');
3784                     break;
3785                 case ANYOF:
3786                     if (flags & SCF_DO_STCLASS_AND)
3787                         cl_and(data->start_class,
3788                                (struct regnode_charclass_class*)scan);
3789                     else
3790                         cl_or(pRExC_state, data->start_class,
3791                               (struct regnode_charclass_class*)scan);
3792                     break;
3793                 case ALNUM:
3794                     if (flags & SCF_DO_STCLASS_AND) {
3795                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3796                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
3797                             if (OP(scan) == ALNUMU) {
3798                                 for (value = 0; value < 256; value++) {
3799                                     if (!isWORDCHAR_L1(value)) {
3800                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3801                                     }
3802                                 }
3803                             } else {
3804                                 for (value = 0; value < 256; value++) {
3805                                     if (!isALNUM(value)) {
3806                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3807                                     }
3808                                 }
3809                             }
3810                         }
3811                     }
3812                     else {
3813                         if (data->start_class->flags & ANYOF_LOCALE)
3814                             ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
3815
3816                         /* Even if under locale, set the bits for non-locale
3817                          * in case it isn't a true locale-node.  This will
3818                          * create false positives if it truly is locale */
3819                         if (OP(scan) == ALNUMU) {
3820                             for (value = 0; value < 256; value++) {
3821                                 if (isWORDCHAR_L1(value)) {
3822                                     ANYOF_BITMAP_SET(data->start_class, value);
3823                                 }
3824                             }
3825                         } else {
3826                             for (value = 0; value < 256; value++) {
3827                                 if (isALNUM(value)) {
3828                                     ANYOF_BITMAP_SET(data->start_class, value);
3829                                 }
3830                             }
3831                         }
3832                     }
3833                     break;
3834                 case NALNUM:
3835                     if (flags & SCF_DO_STCLASS_AND) {
3836                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3837                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
3838                             if (OP(scan) == NALNUMU) {
3839                                 for (value = 0; value < 256; value++) {
3840                                     if (isWORDCHAR_L1(value)) {
3841                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3842                                     }
3843                                 }
3844                             } else {
3845                                 for (value = 0; value < 256; value++) {
3846                                     if (isALNUM(value)) {
3847                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3848                                     }
3849                                 }
3850                             }
3851                         }
3852                     }
3853                     else {
3854                         if (data->start_class->flags & ANYOF_LOCALE)
3855                             ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
3856
3857                         /* Even if under locale, set the bits for non-locale in
3858                          * case it isn't a true locale-node.  This will create
3859                          * false positives if it truly is locale */
3860                         if (OP(scan) == NALNUMU) {
3861                             for (value = 0; value < 256; value++) {
3862                                 if (! isWORDCHAR_L1(value)) {
3863                                     ANYOF_BITMAP_SET(data->start_class, value);
3864                                 }
3865                             }
3866                         } else {
3867                             for (value = 0; value < 256; value++) {
3868                                 if (! isALNUM(value)) {
3869                                     ANYOF_BITMAP_SET(data->start_class, value);
3870                                 }
3871                             }
3872                         }
3873                     }
3874                     break;
3875                 case SPACE:
3876                     if (flags & SCF_DO_STCLASS_AND) {
3877                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3878                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
3879                             if (OP(scan) == SPACEU) {
3880                                 for (value = 0; value < 256; value++) {
3881                                     if (!isSPACE_L1(value)) {
3882                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3883                                     }
3884                                 }
3885                             } else {
3886                                 for (value = 0; value < 256; value++) {
3887                                     if (!isSPACE(value)) {
3888                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3889                                     }
3890                                 }
3891                             }
3892                         }
3893                     }
3894                     else {
3895                         if (data->start_class->flags & ANYOF_LOCALE) {
3896                             ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
3897                         }
3898                         if (OP(scan) == SPACEU) {
3899                             for (value = 0; value < 256; value++) {
3900                                 if (isSPACE_L1(value)) {
3901                                     ANYOF_BITMAP_SET(data->start_class, value);
3902                                 }
3903                             }
3904                         } else {
3905                             for (value = 0; value < 256; value++) {
3906                                 if (isSPACE(value)) {
3907                                     ANYOF_BITMAP_SET(data->start_class, value);
3908                                 }
3909                             }
3910                         }
3911                     }
3912                     break;
3913                 case NSPACE:
3914                     if (flags & SCF_DO_STCLASS_AND) {
3915                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3916                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
3917                             if (OP(scan) == NSPACEU) {
3918                                 for (value = 0; value < 256; value++) {
3919                                     if (isSPACE_L1(value)) {
3920                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3921                                     }
3922                                 }
3923                             } else {
3924                                 for (value = 0; value < 256; value++) {
3925                                     if (isSPACE(value)) {
3926                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3927                                     }
3928                                 }
3929                             }
3930                         }
3931                     }
3932                     else {
3933                         if (data->start_class->flags & ANYOF_LOCALE)
3934                             ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
3935                         if (OP(scan) == NSPACEU) {
3936                             for (value = 0; value < 256; value++) {
3937                                 if (!isSPACE_L1(value)) {
3938                                     ANYOF_BITMAP_SET(data->start_class, value);
3939                                 }
3940                             }
3941                         }
3942                         else {
3943                             for (value = 0; value < 256; value++) {
3944                                 if (!isSPACE(value)) {
3945                                     ANYOF_BITMAP_SET(data->start_class, value);
3946                                 }
3947                             }
3948                         }
3949                     }
3950                     break;
3951                 case DIGIT:
3952                     if (flags & SCF_DO_STCLASS_AND) {
3953                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3954                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NDIGIT);
3955                             for (value = 0; value < 256; value++)
3956                                 if (!isDIGIT(value))
3957                                     ANYOF_BITMAP_CLEAR(data->start_class, value);
3958                         }
3959                     }
3960                     else {
3961                         if (data->start_class->flags & ANYOF_LOCALE)
3962                             ANYOF_CLASS_SET(data->start_class,ANYOF_DIGIT);
3963                         for (value = 0; value < 256; value++)
3964                             if (isDIGIT(value))
3965                                 ANYOF_BITMAP_SET(data->start_class, value);
3966                     }
3967                     break;
3968                 case NDIGIT:
3969                     if (flags & SCF_DO_STCLASS_AND) {
3970                         if (!(data->start_class->flags & ANYOF_LOCALE))
3971                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_DIGIT);
3972                         for (value = 0; value < 256; value++)
3973                             if (isDIGIT(value))
3974                                 ANYOF_BITMAP_CLEAR(data->start_class, value);
3975                     }
3976                     else {
3977                         if (data->start_class->flags & ANYOF_LOCALE)
3978                             ANYOF_CLASS_SET(data->start_class,ANYOF_NDIGIT);
3979                         for (value = 0; value < 256; value++)
3980                             if (!isDIGIT(value))
3981                                 ANYOF_BITMAP_SET(data->start_class, value);
3982                     }
3983                     break;
3984                 CASE_SYNST_FNC(VERTWS);
3985                 CASE_SYNST_FNC(HORIZWS);
3986                 
3987                 }
3988                 if (flags & SCF_DO_STCLASS_OR)
3989                     cl_and(data->start_class, and_withp);
3990                 flags &= ~SCF_DO_STCLASS;
3991             }
3992         }
3993         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
3994             data->flags |= (OP(scan) == MEOL
3995                             ? SF_BEFORE_MEOL
3996                             : SF_BEFORE_SEOL);
3997         }
3998         else if (  PL_regkind[OP(scan)] == BRANCHJ
3999                  /* Lookbehind, or need to calculate parens/evals/stclass: */
4000                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
4001                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
4002             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY 
4003                 || OP(scan) == UNLESSM )
4004             {
4005                 /* Negative Lookahead/lookbehind
4006                    In this case we can't do fixed string optimisation.
4007                 */
4008
4009                 I32 deltanext, minnext, fake = 0;
4010                 regnode *nscan;
4011                 struct regnode_charclass_class intrnl;
4012                 int f = 0;
4013
4014                 data_fake.flags = 0;
4015                 if (data) {
4016                     data_fake.whilem_c = data->whilem_c;
4017                     data_fake.last_closep = data->last_closep;
4018                 }
4019                 else
4020                     data_fake.last_closep = &fake;
4021                 data_fake.pos_delta = delta;
4022                 if ( flags & SCF_DO_STCLASS && !scan->flags
4023                      && OP(scan) == IFMATCH ) { /* Lookahead */
4024                     cl_init(pRExC_state, &intrnl);
4025                     data_fake.start_class = &intrnl;
4026                     f |= SCF_DO_STCLASS_AND;
4027                 }
4028                 if (flags & SCF_WHILEM_VISITED_POS)
4029                     f |= SCF_WHILEM_VISITED_POS;
4030                 next = regnext(scan);
4031                 nscan = NEXTOPER(NEXTOPER(scan));
4032                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext, 
4033                     last, &data_fake, stopparen, recursed, NULL, f, depth+1);
4034                 if (scan->flags) {
4035                     if (deltanext) {
4036                         FAIL("Variable length lookbehind not implemented");
4037                     }
4038                     else if (minnext > (I32)U8_MAX) {
4039                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4040                     }
4041                     scan->flags = (U8)minnext;
4042                 }
4043                 if (data) {
4044                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4045                         pars++;
4046                     if (data_fake.flags & SF_HAS_EVAL)
4047                         data->flags |= SF_HAS_EVAL;
4048                     data->whilem_c = data_fake.whilem_c;
4049                 }
4050                 if (f & SCF_DO_STCLASS_AND) {
4051                     if (flags & SCF_DO_STCLASS_OR) {
4052                         /* OR before, AND after: ideally we would recurse with
4053                          * data_fake to get the AND applied by study of the
4054                          * remainder of the pattern, and then derecurse;
4055                          * *** HACK *** for now just treat as "no information".
4056                          * See [perl #56690].
4057                          */
4058                         cl_init(pRExC_state, data->start_class);
4059                     }  else {
4060                         /* AND before and after: combine and continue */
4061                         const int was = (data->start_class->flags & ANYOF_EOS);
4062
4063                         cl_and(data->start_class, &intrnl);
4064                         if (was)
4065                             data->start_class->flags |= ANYOF_EOS;
4066                     }
4067                 }
4068             }
4069 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
4070             else {
4071                 /* Positive Lookahead/lookbehind
4072                    In this case we can do fixed string optimisation,
4073                    but we must be careful about it. Note in the case of
4074                    lookbehind the positions will be offset by the minimum
4075                    length of the pattern, something we won't know about
4076                    until after the recurse.
4077                 */
4078                 I32 deltanext, fake = 0;
4079                 regnode *nscan;
4080                 struct regnode_charclass_class intrnl;
4081                 int f = 0;
4082                 /* We use SAVEFREEPV so that when the full compile 
4083                     is finished perl will clean up the allocated 
4084                     minlens when it's all done. This way we don't
4085                     have to worry about freeing them when we know
4086                     they wont be used, which would be a pain.
4087                  */
4088                 I32 *minnextp;
4089                 Newx( minnextp, 1, I32 );
4090                 SAVEFREEPV(minnextp);
4091
4092                 if (data) {
4093                     StructCopy(data, &data_fake, scan_data_t);
4094                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
4095                         f |= SCF_DO_SUBSTR;
4096                         if (scan->flags) 
4097                             SCAN_COMMIT(pRExC_state, &data_fake,minlenp);
4098                         data_fake.last_found=newSVsv(data->last_found);
4099                     }
4100                 }
4101                 else
4102                     data_fake.last_closep = &fake;
4103                 data_fake.flags = 0;
4104                 data_fake.pos_delta = delta;
4105                 if (is_inf)
4106                     data_fake.flags |= SF_IS_INF;
4107                 if ( flags & SCF_DO_STCLASS && !scan->flags
4108                      && OP(scan) == IFMATCH ) { /* Lookahead */
4109                     cl_init(pRExC_state, &intrnl);
4110                     data_fake.start_class = &intrnl;
4111                     f |= SCF_DO_STCLASS_AND;
4112                 }
4113                 if (flags & SCF_WHILEM_VISITED_POS)
4114                     f |= SCF_WHILEM_VISITED_POS;
4115                 next = regnext(scan);
4116                 nscan = NEXTOPER(NEXTOPER(scan));
4117
4118                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp, &deltanext, 
4119                     last, &data_fake, stopparen, recursed, NULL, f,depth+1);
4120                 if (scan->flags) {
4121                     if (deltanext) {
4122                         FAIL("Variable length lookbehind not implemented");
4123                     }
4124                     else if (*minnextp > (I32)U8_MAX) {
4125                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4126                     }
4127                     scan->flags = (U8)*minnextp;
4128                 }
4129
4130                 *minnextp += min;
4131
4132                 if (f & SCF_DO_STCLASS_AND) {
4133                     const int was = (data->start_class->flags & ANYOF_EOS);
4134
4135                     cl_and(data->start_class, &intrnl);
4136                     if (was)
4137                         data->start_class->flags |= ANYOF_EOS;
4138                 }
4139                 if (data) {
4140                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4141                         pars++;
4142                     if (data_fake.flags & SF_HAS_EVAL)
4143                         data->flags |= SF_HAS_EVAL;
4144                     data->whilem_c = data_fake.whilem_c;
4145                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
4146                         if (RExC_rx->minlen<*minnextp)
4147                             RExC_rx->minlen=*minnextp;
4148                         SCAN_COMMIT(pRExC_state, &data_fake, minnextp);
4149                         SvREFCNT_dec(data_fake.last_found);
4150                         
4151                         if ( data_fake.minlen_fixed != minlenp ) 
4152                         {
4153                             data->offset_fixed= data_fake.offset_fixed;
4154                             data->minlen_fixed= data_fake.minlen_fixed;
4155                             data->lookbehind_fixed+= scan->flags;
4156                         }
4157                         if ( data_fake.minlen_float != minlenp )
4158                         {
4159                             data->minlen_float= data_fake.minlen_float;
4160                             data->offset_float_min=data_fake.offset_float_min;
4161                             data->offset_float_max=data_fake.offset_float_max;
4162                             data->lookbehind_float+= scan->flags;
4163                         }
4164                     }
4165                 }
4166
4167
4168             }
4169 #endif
4170         }
4171         else if (OP(scan) == OPEN) {
4172             if (stopparen != (I32)ARG(scan))
4173                 pars++;
4174         }
4175         else if (OP(scan) == CLOSE) {
4176             if (stopparen == (I32)ARG(scan)) {
4177                 break;
4178             }
4179             if ((I32)ARG(scan) == is_par) {
4180                 next = regnext(scan);
4181
4182                 if ( next && (OP(next) != WHILEM) && next < last)
4183                     is_par = 0;         /* Disable optimization */
4184             }
4185             if (data)
4186                 *(data->last_closep) = ARG(scan);
4187         }
4188         else if (OP(scan) == EVAL) {
4189                 if (data)
4190                     data->flags |= SF_HAS_EVAL;
4191         }
4192         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
4193             if (flags & SCF_DO_SUBSTR) {
4194                 SCAN_COMMIT(pRExC_state,data,minlenp);
4195                 flags &= ~SCF_DO_SUBSTR;
4196             }
4197             if (data && OP(scan)==ACCEPT) {
4198                 data->flags |= SCF_SEEN_ACCEPT;
4199                 if (stopmin > min)
4200                     stopmin = min;
4201             }
4202         }
4203         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
4204         {
4205                 if (flags & SCF_DO_SUBSTR) {
4206                     SCAN_COMMIT(pRExC_state,data,minlenp);
4207                     data->longest = &(data->longest_float);
4208                 }
4209                 is_inf = is_inf_internal = 1;
4210                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4211                     cl_anything(pRExC_state, data->start_class);
4212                 flags &= ~SCF_DO_STCLASS;
4213         }
4214         else if (OP(scan) == GPOS) {
4215             if (!(RExC_rx->extflags & RXf_GPOS_FLOAT) &&
4216                 !(delta || is_inf || (data && data->pos_delta))) 
4217             {
4218                 if (!(RExC_rx->extflags & RXf_ANCH) && (flags & SCF_DO_SUBSTR))
4219                     RExC_rx->extflags |= RXf_ANCH_GPOS;
4220                 if (RExC_rx->gofs < (U32)min)
4221                     RExC_rx->gofs = min;
4222             } else {
4223                 RExC_rx->extflags |= RXf_GPOS_FLOAT;
4224                 RExC_rx->gofs = 0;
4225             }       
4226         }
4227 #ifdef TRIE_STUDY_OPT
4228 #ifdef FULL_TRIE_STUDY
4229         else if (PL_regkind[OP(scan)] == TRIE) {
4230             /* NOTE - There is similar code to this block above for handling
4231                BRANCH nodes on the initial study.  If you change stuff here
4232                check there too. */
4233             regnode *trie_node= scan;
4234             regnode *tail= regnext(scan);
4235             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4236             I32 max1 = 0, min1 = I32_MAX;
4237             struct regnode_charclass_class accum;
4238
4239             if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
4240                 SCAN_COMMIT(pRExC_state, data,minlenp); /* Cannot merge strings after this. */
4241             if (flags & SCF_DO_STCLASS)
4242                 cl_init_zero(pRExC_state, &accum);
4243                 
4244             if (!trie->jump) {
4245                 min1= trie->minlen;
4246                 max1= trie->maxlen;
4247             } else {
4248                 const regnode *nextbranch= NULL;
4249                 U32 word;
4250                 
4251                 for ( word=1 ; word <= trie->wordcount ; word++) 
4252                 {
4253                     I32 deltanext=0, minnext=0, f = 0, fake;
4254                     struct regnode_charclass_class this_class;
4255                     
4256                     data_fake.flags = 0;
4257                     if (data) {
4258                         data_fake.whilem_c = data->whilem_c;
4259                         data_fake.last_closep = data->last_closep;
4260                     }
4261                     else
4262                         data_fake.last_closep = &fake;
4263                     data_fake.pos_delta = delta;
4264                     if (flags & SCF_DO_STCLASS) {
4265                         cl_init(pRExC_state, &this_class);
4266                         data_fake.start_class = &this_class;
4267                         f = SCF_DO_STCLASS_AND;
4268                     }
4269                     if (flags & SCF_WHILEM_VISITED_POS)
4270                         f |= SCF_WHILEM_VISITED_POS;
4271     
4272                     if (trie->jump[word]) {
4273                         if (!nextbranch)
4274                             nextbranch = trie_node + trie->jump[0];
4275                         scan= trie_node + trie->jump[word];
4276                         /* We go from the jump point to the branch that follows
4277                            it. Note this means we need the vestigal unused branches
4278                            even though they arent otherwise used.
4279                          */
4280                         minnext = study_chunk(pRExC_state, &scan, minlenp, 
4281                             &deltanext, (regnode *)nextbranch, &data_fake, 
4282                             stopparen, recursed, NULL, f,depth+1);
4283                     }
4284                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
4285                         nextbranch= regnext((regnode*)nextbranch);
4286                     
4287                     if (min1 > (I32)(minnext + trie->minlen))
4288                         min1 = minnext + trie->minlen;
4289                     if (max1 < (I32)(minnext + deltanext + trie->maxlen))
4290                         max1 = minnext + deltanext + trie->maxlen;
4291                     if (deltanext == I32_MAX)
4292                         is_inf = is_inf_internal = 1;
4293                     
4294                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4295                         pars++;
4296                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
4297                         if ( stopmin > min + min1) 
4298                             stopmin = min + min1;
4299                         flags &= ~SCF_DO_SUBSTR;
4300                         if (data)
4301                             data->flags |= SCF_SEEN_ACCEPT;
4302                     }
4303                     if (data) {
4304                         if (data_fake.flags & SF_HAS_EVAL)
4305                             data->flags |= SF_HAS_EVAL;
4306                         data->whilem_c = data_fake.whilem_c;
4307                     }
4308                     if (flags & SCF_DO_STCLASS)
4309                         cl_or(pRExC_state, &accum, &this_class);
4310                 }
4311             }
4312             if (flags & SCF_DO_SUBSTR) {
4313                 data->pos_min += min1;
4314                 data->pos_delta += max1 - min1;
4315                 if (max1 != min1 || is_inf)
4316                     data->longest = &(data->longest_float);
4317             }
4318             min += min1;
4319             delta += max1 - min1;
4320             if (flags & SCF_DO_STCLASS_OR) {
4321                 cl_or(pRExC_state, data->start_class, &accum);
4322                 if (min1) {
4323                     cl_and(data->start_class, and_withp);
4324                     flags &= ~SCF_DO_STCLASS;
4325                 }
4326             }
4327             else if (flags & SCF_DO_STCLASS_AND) {
4328                 if (min1) {
4329                     cl_and(data->start_class, &accum);
4330                     flags &= ~SCF_DO_STCLASS;
4331                 }
4332                 else {
4333                     /* Switch to OR mode: cache the old value of
4334                      * data->start_class */
4335                     INIT_AND_WITHP;
4336                     StructCopy(data->start_class, and_withp,
4337                                struct regnode_charclass_class);
4338                     flags &= ~SCF_DO_STCLASS_AND;
4339                     StructCopy(&accum, data->start_class,
4340                                struct regnode_charclass_class);
4341                     flags |= SCF_DO_STCLASS_OR;
4342                     data->start_class->flags |= ANYOF_EOS;
4343                 }
4344             }
4345             scan= tail;
4346             continue;
4347         }
4348 #else
4349         else if (PL_regkind[OP(scan)] == TRIE) {
4350             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4351             U8*bang=NULL;
4352             
4353             min += trie->minlen;
4354             delta += (trie->maxlen - trie->minlen);
4355             flags &= ~SCF_DO_STCLASS; /* xxx */
4356             if (flags & SCF_DO_SUBSTR) {
4357                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
4358                 data->pos_min += trie->minlen;
4359                 data->pos_delta += (trie->maxlen - trie->minlen);
4360                 if (trie->maxlen != trie->minlen)
4361                     data->longest = &(data->longest_float);
4362             }
4363             if (trie->jump) /* no more substrings -- for now /grr*/
4364                 flags &= ~SCF_DO_SUBSTR; 
4365         }
4366 #endif /* old or new */
4367 #endif /* TRIE_STUDY_OPT */     
4368
4369         /* Else: zero-length, ignore. */
4370         scan = regnext(scan);
4371     }
4372     if (frame) {
4373         last = frame->last;
4374         scan = frame->next;
4375         stopparen = frame->stop;
4376         frame = frame->prev;
4377         goto fake_study_recurse;
4378     }
4379
4380   finish:
4381     assert(!frame);
4382     DEBUG_STUDYDATA("pre-fin:",data,depth);
4383
4384     *scanp = scan;
4385     *deltap = is_inf_internal ? I32_MAX : delta;
4386     if (flags & SCF_DO_SUBSTR && is_inf)
4387         data->pos_delta = I32_MAX - data->pos_min;
4388     if (is_par > (I32)U8_MAX)
4389         is_par = 0;
4390     if (is_par && pars==1 && data) {
4391         data->flags |= SF_IN_PAR;
4392         data->flags &= ~SF_HAS_PAR;
4393     }
4394     else if (pars && data) {
4395         data->flags |= SF_HAS_PAR;
4396         data->flags &= ~SF_IN_PAR;
4397     }
4398     if (flags & SCF_DO_STCLASS_OR)
4399         cl_and(data->start_class, and_withp);
4400     if (flags & SCF_TRIE_RESTUDY)
4401         data->flags |=  SCF_TRIE_RESTUDY;
4402     
4403     DEBUG_STUDYDATA("post-fin:",data,depth);
4404     
4405     return min < stopmin ? min : stopmin;
4406 }
4407
4408 STATIC U32
4409 S_add_data(RExC_state_t *pRExC_state, U32 n, const char *s)
4410 {
4411     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
4412
4413     PERL_ARGS_ASSERT_ADD_DATA;
4414
4415     Renewc(RExC_rxi->data,
4416            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
4417            char, struct reg_data);
4418     if(count)
4419         Renew(RExC_rxi->data->what, count + n, U8);
4420     else
4421         Newx(RExC_rxi->data->what, n, U8);
4422     RExC_rxi->data->count = count + n;
4423     Copy(s, RExC_rxi->data->what + count, n, U8);
4424     return count;
4425 }
4426
4427 /*XXX: todo make this not included in a non debugging perl */
4428 #ifndef PERL_IN_XSUB_RE
4429 void
4430 Perl_reginitcolors(pTHX)
4431 {
4432     dVAR;
4433     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
4434     if (s) {
4435         char *t = savepv(s);
4436         int i = 0;
4437         PL_colors[0] = t;
4438         while (++i < 6) {
4439             t = strchr(t, '\t');
4440             if (t) {
4441                 *t = '\0';
4442                 PL_colors[i] = ++t;
4443             }
4444             else
4445                 PL_colors[i] = t = (char *)"";
4446         }
4447     } else {
4448         int i = 0;
4449         while (i < 6)
4450             PL_colors[i++] = (char *)"";
4451     }
4452     PL_colorset = 1;
4453 }
4454 #endif
4455
4456
4457 #ifdef TRIE_STUDY_OPT
4458 #define CHECK_RESTUDY_GOTO                                  \
4459         if (                                                \
4460               (data.flags & SCF_TRIE_RESTUDY)               \
4461               && ! restudied++                              \
4462         )     goto reStudy
4463 #else
4464 #define CHECK_RESTUDY_GOTO
4465 #endif        
4466
4467 /*
4468  - pregcomp - compile a regular expression into internal code
4469  *
4470  * We can't allocate space until we know how big the compiled form will be,
4471  * but we can't compile it (and thus know how big it is) until we've got a
4472  * place to put the code.  So we cheat:  we compile it twice, once with code
4473  * generation turned off and size counting turned on, and once "for real".
4474  * This also means that we don't allocate space until we are sure that the
4475  * thing really will compile successfully, and we never have to move the
4476  * code and thus invalidate pointers into it.  (Note that it has to be in
4477  * one piece because free() must be able to free it all.) [NB: not true in perl]
4478  *
4479  * Beware that the optimization-preparation code in here knows about some
4480  * of the structure of the compiled regexp.  [I'll say.]
4481  */
4482
4483
4484
4485 #ifndef PERL_IN_XSUB_RE
4486 #define RE_ENGINE_PTR &PL_core_reg_engine
4487 #else
4488 extern const struct regexp_engine my_reg_engine;
4489 #define RE_ENGINE_PTR &my_reg_engine
4490 #endif
4491
4492 #ifndef PERL_IN_XSUB_RE 
4493 REGEXP *
4494 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
4495 {
4496     dVAR;
4497     HV * const table = GvHV(PL_hintgv);
4498
4499     PERL_ARGS_ASSERT_PREGCOMP;
4500
4501     /* Dispatch a request to compile a regexp to correct 
4502        regexp engine. */
4503     if (table) {
4504         SV **ptr= hv_fetchs(table, "regcomp", FALSE);
4505         GET_RE_DEBUG_FLAGS_DECL;
4506         if (ptr && SvIOK(*ptr) && SvIV(*ptr)) {
4507             const regexp_engine *eng=INT2PTR(regexp_engine*,SvIV(*ptr));
4508             DEBUG_COMPILE_r({
4509                 PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
4510                     SvIV(*ptr));
4511             });            
4512             return CALLREGCOMP_ENG(eng, pattern, flags);
4513         } 
4514     }
4515     return Perl_re_compile(aTHX_ pattern, flags);
4516 }
4517 #endif
4518
4519 REGEXP *
4520 Perl_re_compile(pTHX_ SV * const pattern, U32 orig_pm_flags)
4521 {
4522     dVAR;
4523     REGEXP *rx;
4524     struct regexp *r;
4525     register regexp_internal *ri;
4526     STRLEN plen;
4527     char* VOL exp;
4528     char* xend;
4529     regnode *scan;
4530     I32 flags;
4531     I32 minlen = 0;
4532     U32 pm_flags;
4533
4534     /* these are all flags - maybe they should be turned
4535      * into a single int with different bit masks */
4536     I32 sawlookahead = 0;
4537     I32 sawplus = 0;
4538     I32 sawopen = 0;
4539     bool used_setjump = FALSE;
4540     regex_charset initial_charset = get_regex_charset(orig_pm_flags);
4541
4542     U8 jump_ret = 0;
4543     dJMPENV;
4544     scan_data_t data;
4545     RExC_state_t RExC_state;
4546     RExC_state_t * const pRExC_state = &RExC_state;
4547 #ifdef TRIE_STUDY_OPT    
4548     int restudied;
4549     RExC_state_t copyRExC_state;
4550 #endif    
4551     GET_RE_DEBUG_FLAGS_DECL;
4552
4553     PERL_ARGS_ASSERT_RE_COMPILE;
4554
4555     DEBUG_r(if (!PL_colorset) reginitcolors());
4556
4557     exp = SvPV(pattern, plen);
4558
4559     if (plen == 0) { /* ignore the utf8ness if the pattern is 0 length */
4560         RExC_utf8 = RExC_orig_utf8 = 0;
4561     }
4562     else {
4563         RExC_utf8 = RExC_orig_utf8 = SvUTF8(pattern);
4564     }
4565     RExC_uni_semantics = 0;
4566     RExC_contains_locale = 0;
4567
4568     /****************** LONG JUMP TARGET HERE***********************/
4569     /* Longjmp back to here if have to switch in midstream to utf8 */
4570     if (! RExC_orig_utf8) {
4571         JMPENV_PUSH(jump_ret);
4572         used_setjump = TRUE;
4573     }
4574
4575     if (jump_ret == 0) {    /* First time through */
4576         xend = exp + plen;
4577
4578         DEBUG_COMPILE_r({
4579             SV *dsv= sv_newmortal();
4580             RE_PV_QUOTED_DECL(s, RExC_utf8,
4581                 dsv, exp, plen, 60);
4582             PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
4583                            PL_colors[4],PL_colors[5],s);
4584         });
4585     }
4586     else {  /* longjumped back */
4587         STRLEN len = plen;
4588
4589         /* If the cause for the longjmp was other than changing to utf8, pop
4590          * our own setjmp, and longjmp to the correct handler */
4591         if (jump_ret != UTF8_LONGJMP) {
4592             JMPENV_POP;
4593             JMPENV_JUMP(jump_ret);
4594         }
4595
4596         GET_RE_DEBUG_FLAGS;
4597
4598         /* It's possible to write a regexp in ascii that represents Unicode
4599         codepoints outside of the byte range, such as via \x{100}. If we
4600         detect such a sequence we have to convert the entire pattern to utf8
4601         and then recompile, as our sizing calculation will have been based
4602         on 1 byte == 1 character, but we will need to use utf8 to encode
4603         at least some part of the pattern, and therefore must convert the whole
4604         thing.
4605         -- dmq */
4606         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
4607             "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
4608         exp = (char*)Perl_bytes_to_utf8(aTHX_
4609                                         (U8*)SvPV_nomg(pattern, plen),
4610                                         &len);
4611         xend = exp + len;
4612         RExC_orig_utf8 = RExC_utf8 = 1;
4613         SAVEFREEPV(exp);
4614     }
4615
4616 #ifdef TRIE_STUDY_OPT
4617     restudied = 0;
4618 #endif
4619
4620     pm_flags = orig_pm_flags;
4621
4622     if (initial_charset == REGEX_LOCALE_CHARSET) {
4623         RExC_contains_locale = 1;
4624     }
4625     else if (RExC_utf8 && initial_charset == REGEX_DEPENDS_CHARSET) {
4626
4627         /* Set to use unicode semantics if the pattern is in utf8 and has the
4628          * 'depends' charset specified, as it means unicode when utf8  */
4629         set_regex_charset(&pm_flags, REGEX_UNICODE_CHARSET);
4630     }
4631
4632     RExC_precomp = exp;
4633     RExC_flags = pm_flags;
4634     RExC_sawback = 0;
4635
4636     RExC_seen = 0;
4637     RExC_in_lookbehind = 0;
4638     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
4639     RExC_seen_evals = 0;
4640     RExC_extralen = 0;
4641     RExC_override_recoding = 0;
4642
4643     /* First pass: determine size, legality. */
4644     RExC_parse = exp;
4645     RExC_start = exp;
4646     RExC_end = xend;
4647     RExC_naughty = 0;
4648     RExC_npar = 1;
4649     RExC_nestroot = 0;
4650     RExC_size = 0L;
4651     RExC_emit = &PL_regdummy;
4652     RExC_whilem_seen = 0;
4653     RExC_open_parens = NULL;
4654     RExC_close_parens = NULL;
4655     RExC_opend = NULL;
4656     RExC_paren_names = NULL;
4657 #ifdef DEBUGGING
4658     RExC_paren_name_list = NULL;
4659 #endif
4660     RExC_recurse = NULL;
4661     RExC_recurse_count = 0;
4662
4663 #if 0 /* REGC() is (currently) a NOP at the first pass.
4664        * Clever compilers notice this and complain. --jhi */
4665     REGC((U8)REG_MAGIC, (char*)RExC_emit);
4666 #endif
4667     DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n"));
4668     if (reg(pRExC_state, 0, &flags,1) == NULL) {
4669         RExC_precomp = NULL;
4670         return(NULL);
4671     }
4672
4673     /* Here, finished first pass.  Get rid of any added setjmp */
4674     if (used_setjump) {
4675         JMPENV_POP;
4676     }
4677
4678     DEBUG_PARSE_r({
4679         PerlIO_printf(Perl_debug_log, 
4680             "Required size %"IVdf" nodes\n"
4681             "Starting second pass (creation)\n", 
4682             (IV)RExC_size);
4683         RExC_lastnum=0; 
4684         RExC_lastparse=NULL; 
4685     });
4686
4687     /* The first pass could have found things that force Unicode semantics */
4688     if ((RExC_utf8 || RExC_uni_semantics)
4689          && get_regex_charset(pm_flags) == REGEX_DEPENDS_CHARSET)
4690     {
4691         set_regex_charset(&pm_flags, REGEX_UNICODE_CHARSET);
4692     }
4693
4694     /* Small enough for pointer-storage convention?
4695        If extralen==0, this means that we will not need long jumps. */
4696     if (RExC_size >= 0x10000L && RExC_extralen)
4697         RExC_size += RExC_extralen;
4698     else
4699         RExC_extralen = 0;
4700     if (RExC_whilem_seen > 15)
4701         RExC_whilem_seen = 15;
4702
4703     /* Allocate space and zero-initialize. Note, the two step process 
4704        of zeroing when in debug mode, thus anything assigned has to 
4705        happen after that */
4706     rx = (REGEXP*) newSV_type(SVt_REGEXP);
4707     r = (struct regexp*)SvANY(rx);
4708     Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
4709          char, regexp_internal);
4710     if ( r == NULL || ri == NULL )
4711         FAIL("Regexp out of space");
4712 #ifdef DEBUGGING
4713     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
4714     Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode), char);
4715 #else 
4716     /* bulk initialize base fields with 0. */
4717     Zero(ri, sizeof(regexp_internal), char);        
4718 #endif
4719
4720     /* non-zero initialization begins here */
4721     RXi_SET( r, ri );
4722     r->engine= RE_ENGINE_PTR;
4723     r->extflags = pm_flags;
4724     {
4725         bool has_p     = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
4726         bool has_charset = (get_regex_charset(r->extflags) != REGEX_DEPENDS_CHARSET);
4727
4728         /* The caret is output if there are any defaults: if not all the STD
4729          * flags are set, or if no character set specifier is needed */
4730         bool has_default =
4731                     (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
4732                     || ! has_charset);
4733         bool has_runon = ((RExC_seen & REG_SEEN_RUN_ON_COMMENT)==REG_SEEN_RUN_ON_COMMENT);
4734         U16 reganch = (U16)((r->extflags & RXf_PMf_STD_PMMOD)
4735                             >> RXf_PMf_STD_PMMOD_SHIFT);
4736         const char *fptr = STD_PAT_MODS;        /*"msix"*/
4737         char *p;
4738         /* Allocate for the worst case, which is all the std flags are turned
4739          * on.  If more precision is desired, we could do a population count of
4740          * the flags set.  This could be done with a small lookup table, or by
4741          * shifting, masking and adding, or even, when available, assembly
4742          * language for a machine-language population count.
4743          * We never output a minus, as all those are defaults, so are
4744          * covered by the caret */
4745         const STRLEN wraplen = plen + has_p + has_runon
4746             + has_default       /* If needs a caret */
4747
4748                 /* If needs a character set specifier */
4749             + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
4750             + (sizeof(STD_PAT_MODS) - 1)
4751             + (sizeof("(?:)") - 1);
4752
4753         p = sv_grow(MUTABLE_SV(rx), wraplen + 1); /* +1 for the ending NUL */
4754         SvPOK_on(rx);
4755         SvFLAGS(rx) |= SvUTF8(pattern);
4756         *p++='('; *p++='?';
4757
4758         /* If a default, cover it using the caret */
4759         if (has_default) {
4760             *p++= DEFAULT_PAT_MOD;
4761         }
4762         if (has_charset) {
4763             STRLEN len;
4764             const char* const name = get_regex_charset_name(r->extflags, &len);
4765             Copy(name, p, len, char);
4766             p += len;
4767         }
4768         if (has_p)
4769             *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
4770         {
4771             char ch;
4772             while((ch = *fptr++)) {
4773                 if(reganch & 1)
4774                     *p++ = ch;
4775                 reganch >>= 1;
4776             }
4777         }
4778
4779         *p++ = ':';
4780         Copy(RExC_precomp, p, plen, char);
4781         assert ((RX_WRAPPED(rx) - p) < 16);
4782         r->pre_prefix = p - RX_WRAPPED(rx);
4783         p += plen;
4784         if (has_runon)
4785             *p++ = '\n';
4786         *p++ = ')';
4787         *p = 0;
4788         SvCUR_set(rx, p - SvPVX_const(rx));
4789     }
4790
4791     r->intflags = 0;
4792     r->nparens = RExC_npar - 1; /* set early to validate backrefs */
4793     
4794     if (RExC_seen & REG_SEEN_RECURSE) {
4795         Newxz(RExC_open_parens, RExC_npar,regnode *);
4796         SAVEFREEPV(RExC_open_parens);
4797         Newxz(RExC_close_parens,RExC_npar,regnode *);
4798         SAVEFREEPV(RExC_close_parens);
4799     }
4800
4801     /* Useful during FAIL. */
4802 #ifdef RE_TRACK_PATTERN_OFFSETS
4803     Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
4804     DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log,
4805                           "%s %"UVuf" bytes for offset annotations.\n",
4806                           ri->u.offsets ? "Got" : "Couldn't get",
4807                           (UV)((2*RExC_size+1) * sizeof(U32))));
4808 #endif
4809     SetProgLen(ri,RExC_size);
4810     RExC_rx_sv = rx;
4811     RExC_rx = r;
4812     RExC_rxi = ri;
4813     REH_CALL_COMP_BEGIN_HOOK(pRExC_state->rx);
4814
4815     /* Second pass: emit code. */
4816     RExC_flags = pm_flags;      /* don't let top level (?i) bleed */
4817     RExC_parse = exp;
4818     RExC_end = xend;
4819     RExC_naughty = 0;
4820     RExC_npar = 1;
4821     RExC_emit_start = ri->program;
4822     RExC_emit = ri->program;
4823     RExC_emit_bound = ri->program + RExC_size + 1;
4824
4825     /* Store the count of eval-groups for security checks: */
4826     RExC_rx->seen_evals = RExC_seen_evals;
4827     REGC((U8)REG_MAGIC, (char*) RExC_emit++);
4828     if (reg(pRExC_state, 0, &flags,1) == NULL) {
4829         ReREFCNT_dec(rx);   
4830         return(NULL);
4831     }
4832     /* XXXX To minimize changes to RE engine we always allocate
4833        3-units-long substrs field. */
4834     Newx(r->substrs, 1, struct reg_substr_data);
4835     if (RExC_recurse_count) {
4836         Newxz(RExC_recurse,RExC_recurse_count,regnode *);
4837         SAVEFREEPV(RExC_recurse);
4838     }
4839
4840 reStudy:
4841     r->minlen = minlen = sawlookahead = sawplus = sawopen = 0;
4842     Zero(r->substrs, 1, struct reg_substr_data);
4843
4844 #ifdef TRIE_STUDY_OPT
4845     if (!restudied) {
4846         StructCopy(&zero_scan_data, &data, scan_data_t);
4847         copyRExC_state = RExC_state;
4848     } else {
4849         U32 seen=RExC_seen;
4850         DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n"));
4851         
4852         RExC_state = copyRExC_state;
4853         if (seen & REG_TOP_LEVEL_BRANCHES) 
4854             RExC_seen |= REG_TOP_LEVEL_BRANCHES;
4855         else
4856             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES;
4857         if (data.last_found) {
4858             SvREFCNT_dec(data.longest_fixed);
4859             SvREFCNT_dec(data.longest_float);
4860             SvREFCNT_dec(data.last_found);
4861         }
4862         StructCopy(&zero_scan_data, &data, scan_data_t);
4863     }
4864 #else
4865     StructCopy(&zero_scan_data, &data, scan_data_t);
4866 #endif    
4867
4868     /* Dig out information for optimizations. */
4869     r->extflags = RExC_flags; /* was pm_op */
4870     /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
4871  
4872     if (UTF)
4873         SvUTF8_on(rx);  /* Unicode in it? */
4874     ri->regstclass = NULL;
4875     if (RExC_naughty >= 10)     /* Probably an expensive pattern. */
4876         r->intflags |= PREGf_NAUGHTY;
4877     scan = ri->program + 1;             /* First BRANCH. */
4878
4879     /* testing for BRANCH here tells us whether there is "must appear"
4880        data in the pattern. If there is then we can use it for optimisations */
4881     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES)) { /*  Only one top-level choice. */
4882         I32 fake;
4883         STRLEN longest_float_length, longest_fixed_length;
4884         struct regnode_charclass_class ch_class; /* pointed to by data */
4885         int stclass_flag;
4886         I32 last_close = 0; /* pointed to by data */
4887         regnode *first= scan;
4888         regnode *first_next= regnext(first);
4889         /*
4890          * Skip introductions and multiplicators >= 1
4891          * so that we can extract the 'meat' of the pattern that must 
4892          * match in the large if() sequence following.
4893          * NOTE that EXACT is NOT covered here, as it is normally
4894          * picked up by the optimiser separately. 
4895          *
4896          * This is unfortunate as the optimiser isnt handling lookahead
4897          * properly currently.
4898          *
4899          */
4900         while ((OP(first) == OPEN && (sawopen = 1)) ||
4901                /* An OR of *one* alternative - should not happen now. */
4902             (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
4903             /* for now we can't handle lookbehind IFMATCH*/
4904             (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
4905             (OP(first) == PLUS) ||
4906             (OP(first) == MINMOD) ||
4907                /* An {n,m} with n>0 */
4908             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
4909             (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
4910         {
4911                 /* 
4912                  * the only op that could be a regnode is PLUS, all the rest
4913                  * will be regnode_1 or regnode_2.
4914                  *
4915                  */
4916                 if (OP(first) == PLUS)
4917                     sawplus = 1;
4918                 else
4919                     first += regarglen[OP(first)];
4920                 
4921                 first = NEXTOPER(first);
4922                 first_next= regnext(first);
4923         }
4924
4925         /* Starting-point info. */
4926       again:
4927         DEBUG_PEEP("first:",first,0);
4928         /* Ignore EXACT as we deal with it later. */
4929         if (PL_regkind[OP(first)] == EXACT) {
4930             if (OP(first) == EXACT)
4931                 NOOP;   /* Empty, get anchored substr later. */
4932             else
4933                 ri->regstclass = first;
4934         }
4935 #ifdef TRIE_STCLASS     
4936         else if (PL_regkind[OP(first)] == TRIE &&
4937                 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0) 
4938         {
4939             regnode *trie_op;
4940             /* this can happen only on restudy */
4941             if ( OP(first) == TRIE ) {
4942                 struct regnode_1 *trieop = (struct regnode_1 *)
4943                     PerlMemShared_calloc(1, sizeof(struct regnode_1));
4944                 StructCopy(first,trieop,struct regnode_1);
4945                 trie_op=(regnode *)trieop;
4946             } else {
4947                 struct regnode_charclass *trieop = (struct regnode_charclass *)
4948                     PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
4949                 StructCopy(first,trieop,struct regnode_charclass);
4950                 trie_op=(regnode *)trieop;
4951             }
4952             OP(trie_op)+=2;
4953             make_trie_failtable(pRExC_state, (regnode *)first, trie_op, 0);
4954             ri->regstclass = trie_op;
4955         }
4956 #endif  
4957         else if (REGNODE_SIMPLE(OP(first)))
4958             ri->regstclass = first;
4959         else if (PL_regkind[OP(first)] == BOUND ||
4960                  PL_regkind[OP(first)] == NBOUND)
4961             ri->regstclass = first;
4962         else if (PL_regkind[OP(first)] == BOL) {
4963             r->extflags |= (OP(first) == MBOL
4964                            ? RXf_ANCH_MBOL
4965                            : (OP(first) == SBOL
4966                               ? RXf_ANCH_SBOL
4967                               : RXf_ANCH_BOL));
4968             first = NEXTOPER(first);
4969             goto again;
4970         }
4971         else if (OP(first) == GPOS) {
4972             r->extflags |= RXf_ANCH_GPOS;
4973             first = NEXTOPER(first);
4974             goto again;
4975         }
4976         else if ((!sawopen || !RExC_sawback) &&
4977             (OP(first) == STAR &&
4978             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
4979             !(r->extflags & RXf_ANCH) && !(RExC_seen & REG_SEEN_EVAL))
4980         {
4981             /* turn .* into ^.* with an implied $*=1 */
4982             const int type =
4983                 (OP(NEXTOPER(first)) == REG_ANY)
4984                     ? RXf_ANCH_MBOL
4985                     : RXf_ANCH_SBOL;
4986             r->extflags |= type;
4987             r->intflags |= PREGf_IMPLICIT;
4988             first = NEXTOPER(first);
4989             goto again;
4990         }
4991         if (sawplus && !sawlookahead && (!sawopen || !RExC_sawback)
4992             && !(RExC_seen & REG_SEEN_EVAL)) /* May examine pos and $& */
4993             /* x+ must match at the 1st pos of run of x's */
4994             r->intflags |= PREGf_SKIP;
4995
4996         /* Scan is after the zeroth branch, first is atomic matcher. */
4997 #ifdef TRIE_STUDY_OPT
4998         DEBUG_PARSE_r(
4999             if (!restudied)
5000                 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
5001                               (IV)(first - scan + 1))
5002         );
5003 #else
5004         DEBUG_PARSE_r(
5005             PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
5006                 (IV)(first - scan + 1))
5007         );
5008 #endif
5009
5010
5011         /*
5012         * If there's something expensive in the r.e., find the
5013         * longest literal string that must appear and make it the
5014         * regmust.  Resolve ties in favor of later strings, since
5015         * the regstart check works with the beginning of the r.e.
5016         * and avoiding duplication strengthens checking.  Not a
5017         * strong reason, but sufficient in the absence of others.
5018         * [Now we resolve ties in favor of the earlier string if
5019         * it happens that c_offset_min has been invalidated, since the
5020         * earlier string may buy us something the later one won't.]
5021         */
5022         
5023         data.longest_fixed = newSVpvs("");
5024         data.longest_float = newSVpvs("");
5025         data.last_found = newSVpvs("");
5026         data.longest = &(data.longest_fixed);
5027         first = scan;
5028         if (!ri->regstclass) {
5029             cl_init(pRExC_state, &ch_class);
5030             data.start_class = &ch_class;
5031             stclass_flag = SCF_DO_STCLASS_AND;
5032         } else                          /* XXXX Check for BOUND? */
5033             stclass_flag = 0;
5034         data.last_closep = &last_close;
5035         
5036         minlen = study_chunk(pRExC_state, &first, &minlen, &fake, scan + RExC_size, /* Up to end */
5037             &data, -1, NULL, NULL,
5038             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0);
5039
5040         
5041         CHECK_RESTUDY_GOTO;
5042
5043
5044         if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
5045              && data.last_start_min == 0 && data.last_end > 0
5046              && !RExC_seen_zerolen
5047              && !(RExC_seen & REG_SEEN_VERBARG)
5048              && (!(RExC_seen & REG_SEEN_GPOS) || (r->extflags & RXf_ANCH_GPOS)))
5049             r->extflags |= RXf_CHECK_ALL;
5050         scan_commit(pRExC_state, &data,&minlen,0);
5051         SvREFCNT_dec(data.last_found);
5052
5053         /* Note that code very similar to this but for anchored string 
5054            follows immediately below, changes may need to be made to both. 
5055            Be careful. 
5056          */
5057         longest_float_length = CHR_SVLEN(data.longest_float);
5058         if (longest_float_length
5059             || (data.flags & SF_FL_BEFORE_EOL
5060                 && (!(data.flags & SF_FL_BEFORE_MEOL)
5061                     || (RExC_flags & RXf_PMf_MULTILINE)))) 
5062         {
5063             I32 t,ml;
5064
5065             if (SvCUR(data.longest_fixed)  /* ok to leave SvCUR */
5066                 && data.offset_fixed == data.offset_float_min
5067                 && SvCUR(data.longest_fixed) == SvCUR(data.longest_float))
5068                     goto remove_float;          /* As in (a)+. */
5069
5070             /* copy the information about the longest float from the reg_scan_data
5071                over to the program. */
5072             if (SvUTF8(data.longest_float)) {
5073                 r->float_utf8 = data.longest_float;
5074                 r->float_substr = NULL;
5075             } else {
5076                 r->float_substr = data.longest_float;
5077                 r->float_utf8 = NULL;
5078             }
5079             /* float_end_shift is how many chars that must be matched that 
5080                follow this item. We calculate it ahead of time as once the
5081                lookbehind offset is added in we lose the ability to correctly
5082                calculate it.*/
5083             ml = data.minlen_float ? *(data.minlen_float) 
5084                                    : (I32)longest_float_length;
5085             r->float_end_shift = ml - data.offset_float_min
5086                 - longest_float_length + (SvTAIL(data.longest_float) != 0)
5087                 + data.lookbehind_float;
5088             r->float_min_offset = data.offset_float_min - data.lookbehind_float;
5089             r->float_max_offset = data.offset_float_max;
5090             if (data.offset_float_max < I32_MAX) /* Don't offset infinity */
5091                 r->float_max_offset -= data.lookbehind_float;
5092             
5093             t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */
5094                        && (!(data.flags & SF_FL_BEFORE_MEOL)
5095                            || (RExC_flags & RXf_PMf_MULTILINE)));
5096             fbm_compile(data.longest_float, t ? FBMcf_TAIL : 0);
5097         }
5098         else {
5099           remove_float:
5100             r->float_substr = r->float_utf8 = NULL;
5101             SvREFCNT_dec(data.longest_float);
5102             longest_float_length = 0;
5103         }
5104
5105         /* Note that code very similar to this but for floating string 
5106            is immediately above, changes may need to be made to both. 
5107            Be careful. 
5108          */
5109         longest_fixed_length = CHR_SVLEN(data.longest_fixed);
5110         if (longest_fixed_length
5111             || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
5112                 && (!(data.flags & SF_FIX_BEFORE_MEOL)
5113                     || (RExC_flags & RXf_PMf_MULTILINE)))) 
5114         {
5115             I32 t,ml;
5116
5117             /* copy the information about the longest fixed 
5118                from the reg_scan_data over to the program. */
5119             if (SvUTF8(data.longest_fixed)) {
5120                 r->anchored_utf8 = data.longest_fixed;
5121                 r->anchored_substr = NULL;
5122             } else {
5123                 r->anchored_substr = data.longest_fixed;
5124                 r->anchored_utf8 = NULL;
5125             }
5126             /* fixed_end_shift is how many chars that must be matched that 
5127                follow this item. We calculate it ahead of time as once the
5128                lookbehind offset is added in we lose the ability to correctly
5129                calculate it.*/
5130             ml = data.minlen_fixed ? *(data.minlen_fixed) 
5131                                    : (I32)longest_fixed_length;
5132             r->anchored_end_shift = ml - data.offset_fixed
5133                 - longest_fixed_length + (SvTAIL(data.longest_fixed) != 0)
5134                 + data.lookbehind_fixed;
5135             r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
5136
5137             t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */
5138                  && (!(data.flags & SF_FIX_BEFORE_MEOL)
5139                      || (RExC_flags & RXf_PMf_MULTILINE)));
5140             fbm_compile(data.longest_fixed, t ? FBMcf_TAIL : 0);
5141         }
5142         else {
5143             r->anchored_substr = r->anchored_utf8 = NULL;
5144             SvREFCNT_dec(data.longest_fixed);
5145             longest_fixed_length = 0;
5146         }
5147         if (ri->regstclass
5148             && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
5149             ri->regstclass = NULL;
5150
5151         if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
5152             && stclass_flag
5153             && !(data.start_class->flags & ANYOF_EOS)
5154             && !cl_is_anything(data.start_class))
5155         {
5156             const U32 n = add_data(pRExC_state, 1, "f");
5157             data.start_class->flags |= ANYOF_IS_SYNTHETIC;
5158
5159             Newx(RExC_rxi->data->data[n], 1,
5160                 struct regnode_charclass_class);
5161             StructCopy(data.start_class,
5162                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
5163                        struct regnode_charclass_class);
5164             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
5165             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
5166             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
5167                       regprop(r, sv, (regnode*)data.start_class);
5168                       PerlIO_printf(Perl_debug_log,
5169                                     "synthetic stclass \"%s\".\n",
5170                                     SvPVX_const(sv));});
5171         }
5172
5173         /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
5174         if (longest_fixed_length > longest_float_length) {
5175             r->check_end_shift = r->anchored_end_shift;
5176             r->check_substr = r->anchored_substr;
5177             r->check_utf8 = r->anchored_utf8;
5178             r->check_offset_min = r->check_offset_max = r->anchored_offset;
5179             if (r->extflags & RXf_ANCH_SINGLE)
5180                 r->extflags |= RXf_NOSCAN;
5181         }
5182         else {
5183             r->check_end_shift = r->float_end_shift;
5184             r->check_substr = r->float_substr;
5185             r->check_utf8 = r->float_utf8;
5186             r->check_offset_min = r->float_min_offset;
5187             r->check_offset_max = r->float_max_offset;
5188         }
5189         /* XXXX Currently intuiting is not compatible with ANCH_GPOS.
5190            This should be changed ASAP!  */
5191         if ((r->check_substr || r->check_utf8) && !(r->extflags & RXf_ANCH_GPOS)) {
5192             r->extflags |= RXf_USE_INTUIT;
5193             if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
5194                 r->extflags |= RXf_INTUIT_TAIL;
5195         }
5196         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
5197         if ( (STRLEN)minlen < longest_float_length )
5198             minlen= longest_float_length;
5199         if ( (STRLEN)minlen < longest_fixed_length )
5200             minlen= longest_fixed_length;     
5201         */
5202     }
5203     else {
5204         /* Several toplevels. Best we can is to set minlen. */
5205         I32 fake;
5206         struct regnode_charclass_class ch_class;
5207         I32 last_close = 0;
5208         
5209         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n"));
5210
5211         scan = ri->program + 1;
5212         cl_init(pRExC_state, &ch_class);
5213         data.start_class = &ch_class;
5214         data.last_closep = &last_close;
5215
5216         
5217         minlen = study_chunk(pRExC_state, &scan, &minlen, &fake, scan + RExC_size,
5218             &data, -1, NULL, NULL, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0);
5219         
5220         CHECK_RESTUDY_GOTO;
5221
5222         r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
5223                 = r->float_substr = r->float_utf8 = NULL;
5224
5225         if (!(data.start_class->flags & ANYOF_EOS)
5226             && !cl_is_anything(data.start_class))
5227         {
5228             const U32 n = add_data(pRExC_state, 1, "f");
5229             data.start_class->flags |= ANYOF_IS_SYNTHETIC;
5230
5231             Newx(RExC_rxi->data->data[n], 1,
5232                 struct regnode_charclass_class);
5233             StructCopy(data.start_class,
5234                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
5235                        struct regnode_charclass_class);
5236             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
5237             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
5238             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
5239                       regprop(r, sv, (regnode*)data.start_class);
5240                       PerlIO_printf(Perl_debug_log,
5241                                     "synthetic stclass \"%s\".\n",
5242                                     SvPVX_const(sv));});
5243         }
5244     }
5245
5246     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
5247        the "real" pattern. */
5248     DEBUG_OPTIMISE_r({
5249         PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf"\n",
5250                       (IV)minlen, (IV)r->minlen);
5251     });
5252     r->minlenret = minlen;
5253     if (r->minlen < minlen) 
5254         r->minlen = minlen;
5255     
5256     if (RExC_seen & REG_SEEN_GPOS)
5257         r->extflags |= RXf_GPOS_SEEN;
5258     if (RExC_seen & REG_SEEN_LOOKBEHIND)
5259         r->extflags |= RXf_LOOKBEHIND_SEEN;
5260     if (RExC_seen & REG_SEEN_EVAL)
5261         r->extflags |= RXf_EVAL_SEEN;
5262     if (RExC_seen & REG_SEEN_CANY)
5263         r->extflags |= RXf_CANY_SEEN;
5264     if (RExC_seen & REG_SEEN_VERBARG)
5265         r->intflags |= PREGf_VERBARG_SEEN;
5266     if (RExC_seen & REG_SEEN_CUTGROUP)
5267         r->intflags |= PREGf_CUTGROUP_SEEN;
5268     if (RExC_paren_names)
5269         RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
5270     else
5271         RXp_PAREN_NAMES(r) = NULL;
5272
5273 #ifdef STUPID_PATTERN_CHECKS            
5274     if (RX_PRELEN(rx) == 0)
5275         r->extflags |= RXf_NULL;
5276     if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
5277         /* XXX: this should happen BEFORE we compile */
5278         r->extflags |= (RXf_SKIPWHITE|RXf_WHITE); 
5279     else if (RX_PRELEN(rx) == 3 && memEQ("\\s+", RX_PRECOMP(rx), 3))
5280         r->extflags |= RXf_WHITE;
5281     else if (RX_PRELEN(rx) == 1 && RXp_PRECOMP(rx)[0] == '^')
5282         r->extflags |= RXf_START_ONLY;
5283 #else
5284     if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
5285             /* XXX: this should happen BEFORE we compile */
5286             r->extflags |= (RXf_SKIPWHITE|RXf_WHITE); 
5287     else {
5288         regnode *first = ri->program + 1;
5289         U8 fop = OP(first);
5290
5291         if (PL_regkind[fop] == NOTHING && OP(NEXTOPER(first)) == END)
5292             r->extflags |= RXf_NULL;
5293         else if (PL_regkind[fop] == BOL && OP(NEXTOPER(first)) == END)
5294             r->extflags |= RXf_START_ONLY;
5295         else if (fop == PLUS && OP(NEXTOPER(first)) == SPACE
5296                              && OP(regnext(first)) == END)
5297             r->extflags |= RXf_WHITE;    
5298     }
5299 #endif
5300 #ifdef DEBUGGING
5301     if (RExC_paren_names) {
5302         ri->name_list_idx = add_data( pRExC_state, 1, "a" );
5303         ri->data->data[ri->name_list_idx] = (void*)SvREFCNT_inc(RExC_paren_name_list);
5304     } else
5305 #endif
5306         ri->name_list_idx = 0;
5307
5308     if (RExC_recurse_count) {
5309         for ( ; RExC_recurse_count ; RExC_recurse_count-- ) {
5310             const regnode *scan = RExC_recurse[RExC_recurse_count-1];
5311             ARG2L_SET( scan, RExC_open_parens[ARG(scan)-1] - scan );
5312         }
5313     }
5314     Newxz(r->offs, RExC_npar, regexp_paren_pair);
5315     /* assume we don't need to swap parens around before we match */
5316
5317     DEBUG_DUMP_r({
5318         PerlIO_printf(Perl_debug_log,"Final program:\n");
5319         regdump(r);
5320     });
5321 #ifdef RE_TRACK_PATTERN_OFFSETS
5322     DEBUG_OFFSETS_r(if (ri->u.offsets) {
5323         const U32 len = ri->u.offsets[0];
5324         U32 i;
5325         GET_RE_DEBUG_FLAGS_DECL;
5326         PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)ri->u.offsets[0]);
5327         for (i = 1; i <= len; i++) {
5328             if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
5329                 PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
5330                 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
5331             }
5332         PerlIO_printf(Perl_debug_log, "\n");
5333     });
5334 #endif
5335     return rx;
5336 }
5337
5338 #undef RE_ENGINE_PTR
5339
5340
5341 SV*
5342 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
5343                     const U32 flags)
5344 {
5345     PERL_ARGS_ASSERT_REG_NAMED_BUFF;
5346
5347     PERL_UNUSED_ARG(value);
5348
5349     if (flags & RXapif_FETCH) {
5350         return reg_named_buff_fetch(rx, key, flags);
5351     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
5352         Perl_croak_no_modify(aTHX);
5353         return NULL;
5354     } else if (flags & RXapif_EXISTS) {
5355         return reg_named_buff_exists(rx, key, flags)
5356             ? &PL_sv_yes
5357             : &PL_sv_no;
5358     } else if (flags & RXapif_REGNAMES) {
5359         return reg_named_buff_all(rx, flags);
5360     } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
5361         return reg_named_buff_scalar(rx, flags);
5362     } else {
5363         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
5364         return NULL;
5365     }
5366 }
5367
5368 SV*
5369 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
5370                          const U32 flags)
5371 {
5372     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
5373     PERL_UNUSED_ARG(lastkey);
5374
5375     if (flags & RXapif_FIRSTKEY)
5376         return reg_named_buff_firstkey(rx, flags);
5377     else if (flags & RXapif_NEXTKEY)
5378         return reg_named_buff_nextkey(rx, flags);
5379     else {
5380         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter", (int)flags);
5381         return NULL;
5382     }
5383 }
5384
5385 SV*
5386 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
5387                           const U32 flags)
5388 {
5389     AV *retarray = NULL;
5390     SV *ret;
5391     struct regexp *const rx = (struct regexp *)SvANY(r);
5392
5393     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
5394
5395     if (flags & RXapif_ALL)
5396         retarray=newAV();
5397
5398     if (rx && RXp_PAREN_NAMES(rx)) {
5399         HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
5400         if (he_str) {
5401             IV i;
5402             SV* sv_dat=HeVAL(he_str);
5403             I32 *nums=(I32*)SvPVX(sv_dat);
5404             for ( i=0; i<SvIVX(sv_dat); i++ ) {
5405                 if ((I32)(rx->nparens) >= nums[i]
5406                     && rx->offs[nums[i]].start != -1
5407                     && rx->offs[nums[i]].end != -1)
5408                 {
5409                     ret = newSVpvs("");
5410                     CALLREG_NUMBUF_FETCH(r,nums[i],ret);
5411                     if (!retarray)
5412                         return ret;
5413                 } else {
5414                     if (retarray)
5415                         ret = newSVsv(&PL_sv_undef);
5416                 }
5417                 if (retarray)
5418                     av_push(retarray, ret);
5419             }
5420             if (retarray)
5421                 return newRV_noinc(MUTABLE_SV(retarray));
5422         }
5423     }
5424     return NULL;
5425 }
5426
5427 bool
5428 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
5429                            const U32 flags)
5430 {
5431     struct regexp *const rx = (struct regexp *)SvANY(r);
5432
5433     PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
5434
5435     if (rx && RXp_PAREN_NAMES(rx)) {
5436         if (flags & RXapif_ALL) {
5437             return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
5438         } else {
5439             SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
5440             if (sv) {
5441                 SvREFCNT_dec(sv);
5442                 return TRUE;
5443             } else {
5444                 return FALSE;
5445             }
5446         }
5447     } else {
5448         return FALSE;
5449     }
5450 }
5451
5452 SV*
5453 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
5454 {
5455     struct regexp *const rx = (struct regexp *)SvANY(r);
5456
5457     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
5458
5459     if ( rx && RXp_PAREN_NAMES(rx) ) {
5460         (void)hv_iterinit(RXp_PAREN_NAMES(rx));
5461
5462         return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
5463     } else {
5464         return FALSE;
5465     }
5466 }
5467
5468 SV*
5469 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
5470 {
5471     struct regexp *const rx = (struct regexp *)SvANY(r);
5472     GET_RE_DEBUG_FLAGS_DECL;
5473
5474     PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
5475
5476     if (rx && RXp_PAREN_NAMES(rx)) {
5477         HV *hv = RXp_PAREN_NAMES(rx);
5478         HE *temphe;
5479         while ( (temphe = hv_iternext_flags(hv,0)) ) {
5480             IV i;
5481             IV parno = 0;
5482             SV* sv_dat = HeVAL(temphe);
5483             I32 *nums = (I32*)SvPVX(sv_dat);
5484             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
5485                 if ((I32)(rx->lastparen) >= nums[i] &&
5486                     rx->offs[nums[i]].start != -1 &&
5487                     rx->offs[nums[i]].end != -1)
5488                 {
5489                     parno = nums[i];
5490                     break;
5491                 }
5492             }
5493             if (parno || flags & RXapif_ALL) {
5494                 return newSVhek(HeKEY_hek(temphe));
5495             }
5496         }
5497     }
5498     return NULL;
5499 }
5500
5501 SV*
5502 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
5503 {
5504     SV *ret;
5505     AV *av;
5506     I32 length;
5507     struct regexp *const rx = (struct regexp *)SvANY(r);
5508
5509     PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
5510
5511     if (rx && RXp_PAREN_NAMES(rx)) {
5512         if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
5513             return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
5514         } else if (flags & RXapif_ONE) {
5515             ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
5516             av = MUTABLE_AV(SvRV(ret));
5517             length = av_len(av);
5518             SvREFCNT_dec(ret);
5519             return newSViv(length + 1);
5520         } else {
5521             Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar", (int)flags);
5522             return NULL;
5523         }
5524     }
5525     return &PL_sv_undef;
5526 }
5527
5528 SV*
5529 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
5530 {
5531     struct regexp *const rx = (struct regexp *)SvANY(r);
5532     AV *av = newAV();
5533
5534     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
5535
5536     if (rx && RXp_PAREN_NAMES(rx)) {
5537         HV *hv= RXp_PAREN_NAMES(rx);
5538         HE *temphe;
5539         (void)hv_iterinit(hv);
5540         while ( (temphe = hv_iternext_flags(hv,0)) ) {
5541             IV i;
5542             IV parno = 0;
5543             SV* sv_dat = HeVAL(temphe);
5544             I32 *nums = (I32*)SvPVX(sv_dat);
5545             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
5546                 if ((I32)(rx->lastparen) >= nums[i] &&
5547                     rx->offs[nums[i]].start != -1 &&
5548                     rx->offs[nums[i]].end != -1)
5549                 {
5550                     parno = nums[i];
5551                     break;
5552                 }
5553             }
5554             if (parno || flags & RXapif_ALL) {
5555                 av_push(av, newSVhek(HeKEY_hek(temphe)));
5556             }
5557         }
5558     }
5559
5560     return newRV_noinc(MUTABLE_SV(av));
5561 }
5562
5563 void
5564 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
5565                              SV * const sv)
5566 {
5567     struct regexp *const rx = (struct regexp *)SvANY(r);
5568     char *s = NULL;
5569     I32 i = 0;
5570     I32 s1, t1;
5571
5572     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
5573         
5574     if (!rx->subbeg) {
5575         sv_setsv(sv,&PL_sv_undef);
5576         return;
5577     } 
5578     else               
5579     if (paren == RX_BUFF_IDX_PREMATCH && rx->offs[0].start != -1) {
5580         /* $` */
5581         i = rx->offs[0].start;
5582         s = rx->subbeg;
5583     }
5584     else 
5585     if (paren == RX_BUFF_IDX_POSTMATCH && rx->offs[0].end != -1) {
5586         /* $' */
5587         s = rx->subbeg + rx->offs[0].end;
5588         i = rx->sublen - rx->offs[0].end;
5589     } 
5590     else
5591     if ( 0 <= paren && paren <= (I32)rx->nparens &&
5592         (s1 = rx->offs[paren].start) != -1 &&
5593         (t1 = rx->offs[paren].end) != -1)
5594     {
5595         /* $& $1 ... */
5596         i = t1 - s1;
5597         s = rx->subbeg + s1;
5598     } else {
5599         sv_setsv(sv,&PL_sv_undef);
5600         return;
5601     }          
5602     assert(rx->sublen >= (s - rx->subbeg) + i );
5603     if (i >= 0) {
5604         const int oldtainted = PL_tainted;
5605         TAINT_NOT;
5606         sv_setpvn(sv, s, i);
5607         PL_tainted = oldtainted;
5608         if ( (rx->extflags & RXf_CANY_SEEN)
5609             ? (RXp_MATCH_UTF8(rx)
5610                         && (!i || is_utf8_string((U8*)s, i)))
5611             : (RXp_MATCH_UTF8(rx)) )
5612         {
5613             SvUTF8_on(sv);
5614         }
5615         else
5616             SvUTF8_off(sv);
5617         if (PL_tainting) {
5618             if (RXp_MATCH_TAINTED(rx)) {
5619                 if (SvTYPE(sv) >= SVt_PVMG) {
5620                     MAGIC* const mg = SvMAGIC(sv);
5621                     MAGIC* mgt;
5622                     PL_tainted = 1;
5623                     SvMAGIC_set(sv, mg->mg_moremagic);
5624                     SvTAINT(sv);
5625                     if ((mgt = SvMAGIC(sv))) {
5626                         mg->mg_moremagic = mgt;
5627                         SvMAGIC_set(sv, mg);
5628                     }
5629                 } else {
5630                     PL_tainted = 1;
5631                     SvTAINT(sv);
5632                 }
5633             } else 
5634                 SvTAINTED_off(sv);
5635         }
5636     } else {
5637         sv_setsv(sv,&PL_sv_undef);
5638         return;
5639     }
5640 }
5641
5642 void
5643 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
5644                                                          SV const * const value)
5645 {
5646     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
5647
5648     PERL_UNUSED_ARG(rx);
5649     PERL_UNUSED_ARG(paren);
5650     PERL_UNUSED_ARG(value);
5651
5652     if (!PL_localizing)
5653         Perl_croak_no_modify(aTHX);
5654 }
5655
5656 I32
5657 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
5658                               const I32 paren)
5659 {
5660     struct regexp *const rx = (struct regexp *)SvANY(r);
5661     I32 i;
5662     I32 s1, t1;
5663
5664     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
5665
5666     /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
5667         switch (paren) {
5668       /* $` / ${^PREMATCH} */
5669       case RX_BUFF_IDX_PREMATCH:
5670         if (rx->offs[0].start != -1) {
5671                         i = rx->offs[0].start;
5672                         if (i > 0) {
5673                                 s1 = 0;
5674                                 t1 = i;
5675                                 goto getlen;
5676                         }
5677             }
5678         return 0;
5679       /* $' / ${^POSTMATCH} */
5680       case RX_BUFF_IDX_POSTMATCH:
5681             if (rx->offs[0].end != -1) {
5682                         i = rx->sublen - rx->offs[0].end;
5683                         if (i > 0) {
5684                                 s1 = rx->offs[0].end;
5685                                 t1 = rx->sublen;
5686                                 goto getlen;
5687                         }
5688             }
5689         return 0;
5690       /* $& / ${^MATCH}, $1, $2, ... */
5691       default:
5692             if (paren <= (I32)rx->nparens &&
5693             (s1 = rx->offs[paren].start) != -1 &&
5694             (t1 = rx->offs[paren].end) != -1)
5695             {
5696             i = t1 - s1;
5697             goto getlen;
5698         } else {
5699             if (ckWARN(WARN_UNINITIALIZED))
5700                 report_uninit((const SV *)sv);
5701             return 0;
5702         }
5703     }
5704   getlen:
5705     if (i > 0 && RXp_MATCH_UTF8(rx)) {
5706         const char * const s = rx->subbeg + s1;
5707         const U8 *ep;
5708         STRLEN el;
5709
5710         i = t1 - s1;
5711         if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
5712                         i = el;
5713     }
5714     return i;
5715 }
5716
5717 SV*
5718 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
5719 {
5720     PERL_ARGS_ASSERT_REG_QR_PACKAGE;
5721         PERL_UNUSED_ARG(rx);
5722         if (0)
5723             return NULL;
5724         else
5725             return newSVpvs("Regexp");
5726 }
5727
5728 /* Scans the name of a named buffer from the pattern.
5729  * If flags is REG_RSN_RETURN_NULL returns null.
5730  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
5731  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
5732  * to the parsed name as looked up in the RExC_paren_names hash.
5733  * If there is an error throws a vFAIL().. type exception.
5734  */
5735
5736 #define REG_RSN_RETURN_NULL    0
5737 #define REG_RSN_RETURN_NAME    1
5738 #define REG_RSN_RETURN_DATA    2
5739
5740 STATIC SV*
5741 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
5742 {
5743     char *name_start = RExC_parse;
5744
5745     PERL_ARGS_ASSERT_REG_SCAN_NAME;
5746
5747     if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
5748          /* skip IDFIRST by using do...while */
5749         if (UTF)
5750             do {
5751                 RExC_parse += UTF8SKIP(RExC_parse);
5752             } while (isALNUM_utf8((U8*)RExC_parse));
5753         else
5754             do {
5755                 RExC_parse++;
5756             } while (isALNUM(*RExC_parse));
5757     }
5758
5759     if ( flags ) {
5760         SV* sv_name
5761             = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
5762                              SVs_TEMP | (UTF ? SVf_UTF8 : 0));
5763         if ( flags == REG_RSN_RETURN_NAME)
5764             return sv_name;
5765         else if (flags==REG_RSN_RETURN_DATA) {
5766             HE *he_str = NULL;
5767             SV *sv_dat = NULL;
5768             if ( ! sv_name )      /* should not happen*/
5769                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
5770             if (RExC_paren_names)
5771                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
5772             if ( he_str )
5773                 sv_dat = HeVAL(he_str);
5774             if ( ! sv_dat )
5775                 vFAIL("Reference to nonexistent named group");
5776             return sv_dat;
5777         }
5778         else {
5779             Perl_croak(aTHX_ "panic: bad flag in reg_scan_name");
5780         }
5781         /* NOT REACHED */
5782     }
5783     return NULL;
5784 }
5785
5786 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
5787     int rem=(int)(RExC_end - RExC_parse);                       \
5788     int cut;                                                    \
5789     int num;                                                    \
5790     int iscut=0;                                                \
5791     if (rem>10) {                                               \
5792         rem=10;                                                 \
5793         iscut=1;                                                \
5794     }                                                           \
5795     cut=10-rem;                                                 \
5796     if (RExC_lastparse!=RExC_parse)                             \
5797         PerlIO_printf(Perl_debug_log," >%.*s%-*s",              \
5798             rem, RExC_parse,                                    \
5799             cut + 4,                                            \
5800             iscut ? "..." : "<"                                 \
5801         );                                                      \
5802     else                                                        \
5803         PerlIO_printf(Perl_debug_log,"%16s","");                \
5804                                                                 \
5805     if (SIZE_ONLY)                                              \
5806        num = RExC_size + 1;                                     \
5807     else                                                        \
5808        num=REG_NODE_NUM(RExC_emit);                             \
5809     if (RExC_lastnum!=num)                                      \
5810        PerlIO_printf(Perl_debug_log,"|%4d",num);                \
5811     else                                                        \
5812        PerlIO_printf(Perl_debug_log,"|%4s","");                 \
5813     PerlIO_printf(Perl_debug_log,"|%*s%-4s",                    \
5814         (int)((depth*2)), "",                                   \
5815         (funcname)                                              \
5816     );                                                          \
5817     RExC_lastnum=num;                                           \
5818     RExC_lastparse=RExC_parse;                                  \
5819 })
5820
5821
5822
5823 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
5824     DEBUG_PARSE_MSG((funcname));                            \
5825     PerlIO_printf(Perl_debug_log,"%4s","\n");               \
5826 })
5827 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({           \
5828     DEBUG_PARSE_MSG((funcname));                            \
5829     PerlIO_printf(Perl_debug_log,fmt "\n",args);               \
5830 })
5831
5832 /* This section of code defines the inversion list object and its methods.  The
5833  * interfaces are highly subject to change, so as much as possible is static to
5834  * this file.  An inversion list is here implemented as a malloc'd C UV array
5835  * with some added info that is placed as UVs at the beginning in a header
5836  * portion.  An inversion list for Unicode is an array of code points, sorted
5837  * by ordinal number.  The zeroth element is the first code point in the list.
5838  * The 1th element is the first element beyond that not in the list.  In other
5839  * words, the first range is
5840  *  invlist[0]..(invlist[1]-1)
5841  * The other ranges follow.  Thus every element that is divisible by two marks
5842  * the beginning of a range that is in the list, and every element not
5843  * divisible by two marks the beginning of a range not in the list.  A single
5844  * element inversion list that contains the single code point N generally
5845  * consists of two elements
5846  *  invlist[0] == N
5847  *  invlist[1] == N+1
5848  * (The exception is when N is the highest representable value on the
5849  * machine, in which case the list containing just it would be a single
5850  * element, itself.  By extension, if the last range in the list extends to
5851  * infinity, then the first element of that range will be in the inversion list
5852  * at a position that is divisible by two, and is the final element in the
5853  * list.)
5854  * Taking the complement (inverting) an inversion list is quite simple, if the
5855  * first element is 0, remove it; otherwise add a 0 element at the beginning.
5856  * This implementation reserves an element at the beginning of each inversion list
5857  * to contain 0 when the list contains 0, and contains 1 otherwise.  The actual
5858  * beginning of the list is either that element if 0, or the next one if 1.
5859  *
5860  * More about inversion lists can be found in "Unicode Demystified"
5861  * Chapter 13 by Richard Gillam, published by Addison-Wesley.
5862  * More will be coming when functionality is added later.
5863  *
5864  * The inversion list data structure is currently implemented as an SV pointing
5865  * to an array of UVs that the SV thinks are bytes.  This allows us to have an
5866  * array of UV whose memory management is automatically handled by the existing
5867  * facilities for SV's.
5868  *
5869  * Some of the methods should always be private to the implementation, and some
5870  * should eventually be made public */
5871
5872 #define INVLIST_LEN_OFFSET 0    /* Number of elements in the inversion list */
5873 #define INVLIST_ITER_OFFSET 1   /* Current iteration position */
5874
5875 #define INVLIST_ZERO_OFFSET 2   /* 0 or 1; must be last element in header */
5876 /* The UV at position ZERO contains either 0 or 1.  If 0, the inversion list
5877  * contains the code point U+00000, and begins here.  If 1, the inversion list
5878  * doesn't contain U+0000, and it begins at the next UV in the array.
5879  * Inverting an inversion list consists of adding or removing the 0 at the
5880  * beginning of it.  By reserving a space for that 0, inversion can be made
5881  * very fast */
5882
5883 #define HEADER_LENGTH (INVLIST_ZERO_OFFSET + 1)
5884
5885 /* Internally things are UVs */
5886 #define TO_INTERNAL_SIZE(x) ((x + HEADER_LENGTH) * sizeof(UV))
5887 #define FROM_INTERNAL_SIZE(x) ((x / sizeof(UV)) - HEADER_LENGTH)
5888
5889 #define INVLIST_INITIAL_LEN 10
5890
5891 PERL_STATIC_INLINE UV*
5892 S__invlist_array_init(pTHX_ SV* const invlist, const bool will_have_0)
5893 {
5894     /* Returns a pointer to the first element in the inversion list's array.
5895      * This is called upon initialization of an inversion list.  Where the
5896      * array begins depends on whether the list has the code point U+0000
5897      * in it or not.  The other parameter tells it whether the code that
5898      * follows this call is about to put a 0 in the inversion list or not.
5899      * The first element is either the element with 0, if 0, or the next one,
5900      * if 1 */
5901
5902     UV* zero = get_invlist_zero_addr(invlist);
5903
5904     PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
5905
5906     /* Must be empty */
5907     assert(! *get_invlist_len_addr(invlist));
5908
5909     /* 1^1 = 0; 1^0 = 1 */
5910     *zero = 1 ^ will_have_0;
5911     return zero + *zero;
5912 }
5913
5914 PERL_STATIC_INLINE UV*
5915 S_invlist_array(pTHX_ SV* const invlist)
5916 {
5917     /* Returns the pointer to the inversion list's array.  Every time the
5918      * length changes, this needs to be called in case malloc or realloc moved
5919      * it */
5920
5921     PERL_ARGS_ASSERT_INVLIST_ARRAY;
5922
5923     /* Must not be empty */
5924     assert(*get_invlist_len_addr(invlist));
5925     assert(*get_invlist_zero_addr(invlist) == 0
5926            || *get_invlist_zero_addr(invlist) == 1);
5927
5928     /* The array begins either at the element reserved for zero if the
5929      * list contains 0 (that element will be set to 0), or otherwise the next
5930      * element (in which case the reserved element will be set to 1). */
5931     return (UV *) (get_invlist_zero_addr(invlist)
5932                    + *get_invlist_zero_addr(invlist));
5933 }
5934
5935 PERL_STATIC_INLINE UV*
5936 S_get_invlist_len_addr(pTHX_ SV* invlist)
5937 {
5938     /* Return the address of the UV that contains the current number
5939      * of used elements in the inversion list */
5940
5941     PERL_ARGS_ASSERT_GET_INVLIST_LEN_ADDR;
5942
5943     return (UV *) (SvPVX(invlist) + (INVLIST_LEN_OFFSET * sizeof (UV)));
5944 }
5945
5946 PERL_STATIC_INLINE UV
5947 S_invlist_len(pTHX_ SV* const invlist)
5948 {
5949     /* Returns the current number of elements in the inversion list's array */
5950
5951     PERL_ARGS_ASSERT_INVLIST_LEN;
5952
5953     return *get_invlist_len_addr(invlist);
5954 }
5955
5956 PERL_STATIC_INLINE void
5957 S_invlist_set_len(pTHX_ SV* const invlist, const UV len)
5958 {
5959     /* Sets the current number of elements stored in the inversion list */
5960
5961     PERL_ARGS_ASSERT_INVLIST_SET_LEN;
5962
5963     *get_invlist_len_addr(invlist) = len;
5964
5965     assert(len <= SvLEN(invlist));
5966
5967     SvCUR_set(invlist, TO_INTERNAL_SIZE(len));
5968     /* If the list contains U+0000, that element is part of the header,
5969      * and should not be counted as part of the array.  It will contain
5970      * 0 in that case, and 1 otherwise.  So we could flop 0=>1, 1=>0 and
5971      * subtract:
5972      *  SvCUR_set(invlist,
5973      *            TO_INTERNAL_SIZE(len
5974      *                             - (*get_invlist_zero_addr(inv_list) ^ 1)));
5975      * But, this is only valid if len is not 0.  The consequences of not doing
5976      * this is that the memory allocation code may think that 1 more UV is
5977      * being used than actually is, and so might do an unnecessary grow.  That
5978      * seems worth not bothering to make this the precise amount.
5979      *
5980      * Note that when inverting, SvCUR shouldn't change */
5981 }
5982
5983 PERL_STATIC_INLINE UV
5984 S_invlist_max(pTHX_ SV* const invlist)
5985 {
5986     /* Returns the maximum number of elements storable in the inversion list's
5987      * array, without having to realloc() */
5988
5989     PERL_ARGS_ASSERT_INVLIST_MAX;
5990
5991     return FROM_INTERNAL_SIZE(SvLEN(invlist));
5992 }
5993
5994 PERL_STATIC_INLINE UV*
5995 S_get_invlist_zero_addr(pTHX_ SV* invlist)
5996 {
5997     /* Return the address of the UV that is reserved to hold 0 if the inversion
5998      * list contains 0.  This has to be the last element of the heading, as the
5999      * list proper starts with either it if 0, or the next element if not.
6000      * (But we force it to contain either 0 or 1) */
6001
6002     PERL_ARGS_ASSERT_GET_INVLIST_ZERO_ADDR;
6003
6004     return (UV *) (SvPVX(invlist) + (INVLIST_ZERO_OFFSET * sizeof (UV)));
6005 }
6006
6007 #ifndef PERL_IN_XSUB_RE
6008 SV*
6009 Perl__new_invlist(pTHX_ IV initial_size)
6010 {
6011
6012     /* Return a pointer to a newly constructed inversion list, with enough
6013      * space to store 'initial_size' elements.  If that number is negative, a
6014      * system default is used instead */
6015
6016     SV* new_list;
6017
6018     if (initial_size < 0) {
6019         initial_size = INVLIST_INITIAL_LEN;
6020     }
6021
6022     /* Allocate the initial space */
6023     new_list = newSV(TO_INTERNAL_SIZE(initial_size));
6024     invlist_set_len(new_list, 0);
6025
6026     /* Force iterinit() to be used to get iteration to work */
6027     *get_invlist_iter_addr(new_list) = UV_MAX;
6028
6029     /* This should force a segfault if a method doesn't initialize this
6030      * properly */
6031     *get_invlist_zero_addr(new_list) = UV_MAX;
6032
6033     return new_list;
6034 }
6035 #endif
6036
6037 STATIC void
6038 S_invlist_extend(pTHX_ SV* const invlist, const UV new_max)
6039 {
6040     /* Grow the maximum size of an inversion list */
6041
6042     PERL_ARGS_ASSERT_INVLIST_EXTEND;
6043
6044     SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max));
6045 }
6046
6047 PERL_STATIC_INLINE void
6048 S_invlist_trim(pTHX_ SV* const invlist)
6049 {
6050     PERL_ARGS_ASSERT_INVLIST_TRIM;
6051
6052     /* Change the length of the inversion list to how many entries it currently
6053      * has */
6054
6055     SvPV_shrink_to_cur((SV *) invlist);
6056 }
6057
6058 /* An element is in an inversion list iff its index is even numbered: 0, 2, 4,
6059  * etc */
6060
6061 #define ELEMENT_IN_INVLIST_SET(i) (! ((i) & 1))
6062 #define PREV_ELEMENT_IN_INVLIST_SET(i) (! ELEMENT_IN_INVLIST_SET(i))
6063
6064 #ifndef PERL_IN_XSUB_RE
6065 void
6066 Perl__append_range_to_invlist(pTHX_ SV* const invlist, const UV start, const UV end)
6067 {
6068    /* Subject to change or removal.  Append the range from 'start' to 'end' at
6069     * the end of the inversion list.  The range must be above any existing
6070     * ones. */
6071
6072     UV* array;
6073     UV max = invlist_max(invlist);
6074     UV len = invlist_len(invlist);
6075
6076     PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
6077
6078     if (len == 0) { /* Empty lists must be initialized */
6079         array = _invlist_array_init(invlist, start == 0);
6080     }
6081     else {
6082         /* Here, the existing list is non-empty. The current max entry in the
6083          * list is generally the first value not in the set, except when the
6084          * set extends to the end of permissible values, in which case it is
6085          * the first entry in that final set, and so this call is an attempt to
6086          * append out-of-order */
6087
6088         UV final_element = len - 1;
6089         array = invlist_array(invlist);
6090         if (array[final_element] > start
6091             || ELEMENT_IN_INVLIST_SET(final_element))
6092         {
6093             Perl_croak(aTHX_ "panic: attempting to append to an inversion list, but wasn't at the end of the list");
6094         }
6095
6096         /* Here, it is a legal append.  If the new range begins with the first
6097          * value not in the set, it is extending the set, so the new first
6098          * value not in the set is one greater than the newly extended range.
6099          * */
6100         if (array[final_element] == start) {
6101             if (end != UV_MAX) {
6102                 array[final_element] = end + 1;
6103             }
6104             else {
6105                 /* But if the end is the maximum representable on the machine,
6106                  * just let the range that this would extend have no end */
6107                 invlist_set_len(invlist, len - 1);
6108             }
6109             return;
6110         }
6111     }
6112
6113     /* Here the new range doesn't extend any existing set.  Add it */
6114
6115     len += 2;   /* Includes an element each for the start and end of range */
6116
6117     /* If overflows the existing space, extend, which may cause the array to be
6118      * moved */
6119     if (max < len) {
6120         invlist_extend(invlist, len);
6121         invlist_set_len(invlist, len);  /* Have to set len here to avoid assert
6122                                            failure in invlist_array() */
6123         array = invlist_array(invlist);
6124     }
6125     else {
6126         invlist_set_len(invlist, len);
6127     }
6128
6129     /* The next item on the list starts the range, the one after that is
6130      * one past the new range.  */
6131     array[len - 2] = start;
6132     if (end != UV_MAX) {
6133         array[len - 1] = end + 1;
6134     }
6135     else {
6136         /* But if the end is the maximum representable on the machine, just let
6137          * the range have no end */
6138         invlist_set_len(invlist, len - 1);
6139     }
6140 }
6141
6142 void
6143 Perl__invlist_union(pTHX_ SV* const a, SV* const b, SV** output)
6144 {
6145     /* Take the union of two inversion lists and point 'result' to it.  If
6146      * 'result' on input points to one of the two lists, the reference count to
6147      * that list will be decremented.
6148      * The basis for this comes from "Unicode Demystified" Chapter 13 by
6149      * Richard Gillam, published by Addison-Wesley, and explained at some
6150      * length there.  The preface says to incorporate its examples into your
6151      * code at your own risk.
6152      *
6153      * The algorithm is like a merge sort.
6154      *
6155      * XXX A potential performance improvement is to keep track as we go along
6156      * if only one of the inputs contributes to the result, meaning the other
6157      * is a subset of that one.  In that case, we can skip the final copy and
6158      * return the larger of the input lists, but then outside code might need
6159      * to keep track of whether to free the input list or not */
6160
6161     UV* array_a;    /* a's array */
6162     UV* array_b;
6163     UV len_a;       /* length of a's array */
6164     UV len_b;
6165
6166     SV* u;                      /* the resulting union */
6167     UV* array_u;
6168     UV len_u;
6169
6170     UV i_a = 0;             /* current index into a's array */
6171     UV i_b = 0;
6172     UV i_u = 0;
6173
6174     /* running count, as explained in the algorithm source book; items are
6175      * stopped accumulating and are output when the count changes to/from 0.
6176      * The count is incremented when we start a range that's in the set, and
6177      * decremented when we start a range that's not in the set.  So its range
6178      * is 0 to 2.  Only when the count is zero is something not in the set.
6179      */
6180     UV count = 0;
6181
6182     PERL_ARGS_ASSERT__INVLIST_UNION;
6183
6184     /* If either one is empty, the union is the other one */
6185     len_a = invlist_len(a);
6186     if (len_a == 0) {
6187         if (output == &a) {
6188             SvREFCNT_dec(a);
6189         }
6190         else if (output != &b) {
6191             *output = invlist_clone(b);
6192         }
6193         /* else *output already = b; */
6194         return;
6195     }
6196     else if ((len_b = invlist_len(b)) == 0) {
6197         if (output == &b) {
6198             SvREFCNT_dec(b);
6199         }
6200         else if (output != &a) {
6201             *output = invlist_clone(a);
6202         }
6203         /* else *output already = a; */
6204         return;
6205     }
6206
6207     /* Here both lists exist and are non-empty */
6208     array_a = invlist_array(a);
6209     array_b = invlist_array(b);
6210
6211     /* Size the union for the worst case: that the sets are completely
6212      * disjoint */
6213     u = _new_invlist(len_a + len_b);
6214
6215     /* Will contain U+0000 if either component does */
6216     array_u = _invlist_array_init(u, (len_a > 0 && array_a[0] == 0)
6217                                       || (len_b > 0 && array_b[0] == 0));
6218
6219     /* Go through each list item by item, stopping when exhausted one of
6220      * them */
6221     while (i_a < len_a && i_b < len_b) {
6222         UV cp;      /* The element to potentially add to the union's array */
6223         bool cp_in_set;   /* is it in the the input list's set or not */
6224
6225         /* We need to take one or the other of the two inputs for the union.
6226          * Since we are merging two sorted lists, we take the smaller of the
6227          * next items.  In case of a tie, we take the one that is in its set
6228          * first.  If we took one not in the set first, it would decrement the
6229          * count, possibly to 0 which would cause it to be output as ending the
6230          * range, and the next time through we would take the same number, and
6231          * output it again as beginning the next range.  By doing it the
6232          * opposite way, there is no possibility that the count will be
6233          * momentarily decremented to 0, and thus the two adjoining ranges will
6234          * be seamlessly merged.  (In a tie and both are in the set or both not
6235          * in the set, it doesn't matter which we take first.) */
6236         if (array_a[i_a] < array_b[i_b]
6237             || (array_a[i_a] == array_b[i_b] && ELEMENT_IN_INVLIST_SET(i_a)))
6238         {
6239             cp_in_set = ELEMENT_IN_INVLIST_SET(i_a);
6240             cp= array_a[i_a++];
6241         }
6242         else {
6243             cp_in_set = ELEMENT_IN_INVLIST_SET(i_b);
6244             cp= array_b[i_b++];
6245         }
6246
6247         /* Here, have chosen which of the two inputs to look at.  Only output
6248          * if the running count changes to/from 0, which marks the
6249          * beginning/end of a range in that's in the set */
6250         if (cp_in_set) {
6251             if (count == 0) {
6252                 array_u[i_u++] = cp;
6253             }
6254             count++;
6255         }
6256         else {
6257             count--;
6258             if (count == 0) {
6259                 array_u[i_u++] = cp;
6260             }
6261         }
6262     }
6263
6264     /* Here, we are finished going through at least one of the lists, which
6265      * means there is something remaining in at most one.  We check if the list
6266      * that hasn't been exhausted is positioned such that we are in the middle
6267      * of a range in its set or not.  (i_a and i_b point to the element beyond
6268      * the one we care about.) If in the set, we decrement 'count'; if 0, there
6269      * is potentially more to output.
6270      * There are four cases:
6271      *  1) Both weren't in their sets, count is 0, and remains 0.  What's left
6272      *     in the union is entirely from the non-exhausted set.
6273      *  2) Both were in their sets, count is 2.  Nothing further should
6274      *     be output, as everything that remains will be in the exhausted
6275      *     list's set, hence in the union; decrementing to 1 but not 0 insures
6276      *     that
6277      *  3) the exhausted was in its set, non-exhausted isn't, count is 1.
6278      *     Nothing further should be output because the union includes
6279      *     everything from the exhausted set.  Not decrementing ensures that.
6280      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1;
6281      *     decrementing to 0 insures that we look at the remainder of the
6282      *     non-exhausted set */
6283     if ((i_a != len_a && PREV_ELEMENT_IN_INVLIST_SET(i_a))
6284         || (i_b != len_b && PREV_ELEMENT_IN_INVLIST_SET(i_b)))
6285     {
6286         count--;
6287     }
6288
6289     /* The final length is what we've output so far, plus what else is about to
6290      * be output.  (If 'count' is non-zero, then the input list we exhausted
6291      * has everything remaining up to the machine's limit in its set, and hence
6292      * in the union, so there will be no further output. */
6293     len_u = i_u;
6294     if (count == 0) {
6295         /* At most one of the subexpressions will be non-zero */
6296         len_u += (len_a - i_a) + (len_b - i_b);
6297     }
6298
6299     /* Set result to final length, which can change the pointer to array_u, so
6300      * re-find it */
6301     if (len_u != invlist_len(u)) {
6302         invlist_set_len(u, len_u);
6303         invlist_trim(u);
6304         array_u = invlist_array(u);
6305     }
6306
6307     /* When 'count' is 0, the list that was exhausted (if one was shorter than
6308      * the other) ended with everything above it not in its set.  That means
6309      * that the remaining part of the union is precisely the same as the
6310      * non-exhausted list, so can just copy it unchanged.  (If both list were
6311      * exhausted at the same time, then the operations below will be both 0.)
6312      */
6313     if (count == 0) {
6314         IV copy_count; /* At most one will have a non-zero copy count */
6315         if ((copy_count = len_a - i_a) > 0) {
6316             Copy(array_a + i_a, array_u + i_u, copy_count, UV);
6317         }
6318         else if ((copy_count = len_b - i_b) > 0) {
6319             Copy(array_b + i_b, array_u + i_u, copy_count, UV);
6320         }
6321     }
6322
6323     /*  We may be removing a reference to one of the inputs */
6324     if (&a == output || &b == output) {
6325         SvREFCNT_dec(*output);
6326     }
6327
6328     *output = u;
6329     return;
6330 }
6331
6332 void
6333 Perl__invlist_intersection(pTHX_ SV* const a, SV* const b, SV** i)
6334 {
6335     /* Take the intersection of two inversion lists and point 'i' to it.  If
6336      * 'i' on input points to one of the two lists, the reference count to that
6337      * list will be decremented.
6338      * The basis for this comes from "Unicode Demystified" Chapter 13 by
6339      * Richard Gillam, published by Addison-Wesley, and explained at some
6340      * length there.  The preface says to incorporate its examples into your
6341      * code at your own risk.  In fact, it had bugs
6342      *
6343      * The algorithm is like a merge sort, and is essentially the same as the
6344      * union above
6345      */
6346
6347     UV* array_a;                /* a's array */
6348     UV* array_b;
6349     UV len_a;   /* length of a's array */
6350     UV len_b;
6351
6352     SV* r;                   /* the resulting intersection */
6353     UV* array_r;
6354     UV len_r;
6355
6356     UV i_a = 0;             /* current index into a's array */
6357     UV i_b = 0;
6358     UV i_r = 0;
6359
6360     /* running count, as explained in the algorithm source book; items are
6361      * stopped accumulating and are output when the count changes to/from 2.
6362      * The count is incremented when we start a range that's in the set, and
6363      * decremented when we start a range that's not in the set.  So its range
6364      * is 0 to 2.  Only when the count is 2 is something in the intersection.
6365      */
6366     UV count = 0;
6367
6368     PERL_ARGS_ASSERT__INVLIST_INTERSECTION;
6369
6370     /* If either one is empty, the intersection is null */
6371     len_a = invlist_len(a);
6372     if ((len_a == 0) || ((len_b = invlist_len(b)) == 0)) {
6373         *i = _new_invlist(0);
6374
6375         /* If the result is the same as one of the inputs, the input is being
6376          * overwritten */
6377         if (i == &a) {
6378             SvREFCNT_dec(a);
6379         }
6380         else if (i == &b) {
6381             SvREFCNT_dec(b);
6382         }
6383         return;
6384     }
6385
6386     /* Here both lists exist and are non-empty */
6387     array_a = invlist_array(a);
6388     array_b = invlist_array(b);
6389
6390     /* Size the intersection for the worst case: that the intersection ends up
6391      * fragmenting everything to be completely disjoint */
6392     r= _new_invlist(len_a + len_b);
6393
6394     /* Will contain U+0000 iff both components do */
6395     array_r = _invlist_array_init(r, len_a > 0 && array_a[0] == 0
6396                                      && len_b > 0 && array_b[0] == 0);
6397
6398     /* Go through each list item by item, stopping when exhausted one of
6399      * them */
6400     while (i_a < len_a && i_b < len_b) {
6401         UV cp;      /* The element to potentially add to the intersection's
6402                        array */
6403         bool cp_in_set; /* Is it in the input list's set or not */
6404
6405         /* We need to take one or the other of the two inputs for the
6406          * intersection.  Since we are merging two sorted lists, we take the
6407          * smaller of the next items.  In case of a tie, we take the one that
6408          * is not in its set first (a difference from the union algorithm).  If
6409          * we took one in the set first, it would increment the count, possibly
6410          * to 2 which would cause it to be output as starting a range in the
6411          * intersection, and the next time through we would take that same
6412          * number, and output it again as ending the set.  By doing it the
6413          * opposite of this, there is no possibility that the count will be
6414          * momentarily incremented to 2.  (In a tie and both are in the set or
6415          * both not in the set, it doesn't matter which we take first.) */
6416         if (array_a[i_a] < array_b[i_b]
6417             || (array_a[i_a] == array_b[i_b] && ! ELEMENT_IN_INVLIST_SET(i_a)))
6418         {
6419             cp_in_set = ELEMENT_IN_INVLIST_SET(i_a);
6420             cp= array_a[i_a++];
6421         }
6422         else {
6423             cp_in_set = ELEMENT_IN_INVLIST_SET(i_b);
6424             cp= array_b[i_b++];
6425         }
6426
6427         /* Here, have chosen which of the two inputs to look at.  Only output
6428          * if the running count changes to/from 2, which marks the
6429          * beginning/end of a range that's in the intersection */
6430         if (cp_in_set) {
6431             count++;
6432             if (count == 2) {
6433                 array_r[i_r++] = cp;
6434             }
6435         }
6436         else {
6437             if (count == 2) {
6438                 array_r[i_r++] = cp;
6439             }
6440             count--;
6441         }
6442     }
6443
6444     /* Here, we are finished going through at least one of the lists, which
6445      * means there is something remaining in at most one.  We check if the list
6446      * that has been exhausted is positioned such that we are in the middle
6447      * of a range in its set or not.  (i_a and i_b point to elements 1 beyond
6448      * the ones we care about.)  There are four cases:
6449      *  1) Both weren't in their sets, count is 0, and remains 0.  There's
6450      *     nothing left in the intersection.
6451      *  2) Both were in their sets, count is 2 and perhaps is incremented to
6452      *     above 2.  What should be output is exactly that which is in the
6453      *     non-exhausted set, as everything it has is also in the intersection
6454      *     set, and everything it doesn't have can't be in the intersection
6455      *  3) The exhausted was in its set, non-exhausted isn't, count is 1, and
6456      *     gets incremented to 2.  Like the previous case, the intersection is
6457      *     everything that remains in the non-exhausted set.
6458      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1, and
6459      *     remains 1.  And the intersection has nothing more. */
6460     if ((i_a == len_a && PREV_ELEMENT_IN_INVLIST_SET(i_a))
6461         || (i_b == len_b && PREV_ELEMENT_IN_INVLIST_SET(i_b)))
6462     {
6463         count++;
6464     }
6465
6466     /* The final length is what we've output so far plus what else is in the
6467      * intersection.  At most one of the subexpressions below will be non-zero */
6468     len_r = i_r;
6469     if (count >= 2) {
6470         len_r += (len_a - i_a) + (len_b - i_b);
6471     }
6472
6473     /* Set result to final length, which can change the pointer to array_r, so
6474      * re-find it */
6475     if (len_r != invlist_len(r)) {
6476         invlist_set_len(r, len_r);
6477         invlist_trim(r);
6478         array_r = invlist_array(r);
6479     }
6480
6481     /* Finish outputting any remaining */
6482     if (count >= 2) { /* At most one will have a non-zero copy count */
6483         IV copy_count;
6484         if ((copy_count = len_a - i_a) > 0) {
6485             Copy(array_a + i_a, array_r + i_r, copy_count, UV);
6486         }
6487         else if ((copy_count = len_b - i_b) > 0) {
6488             Copy(array_b + i_b, array_r + i_r, copy_count, UV);
6489         }
6490     }
6491
6492     /*  We may be removing a reference to one of the inputs */
6493     if (&a == i || &b == i) {
6494         SvREFCNT_dec(*i);
6495     }
6496
6497     *i = r;
6498     return;
6499 }
6500
6501 #endif
6502
6503 STATIC SV*
6504 S_add_range_to_invlist(pTHX_ SV* invlist, const UV start, const UV end)
6505 {
6506     /* Add the range from 'start' to 'end' inclusive to the inversion list's
6507      * set.  A pointer to the inversion list is returned.  This may actually be
6508      * a new list, in which case the passed in one has been destroyed.  The
6509      * passed in inversion list can be NULL, in which case a new one is created
6510      * with just the one range in it */
6511
6512     SV* range_invlist;
6513     UV len;
6514
6515     if (invlist == NULL) {
6516         invlist = _new_invlist(2);
6517         len = 0;
6518     }
6519     else {
6520         len = invlist_len(invlist);
6521     }
6522
6523     /* If comes after the final entry, can just append it to the end */
6524     if (len == 0
6525         || start >= invlist_array(invlist)
6526                                     [invlist_len(invlist) - 1])
6527     {
6528         _append_range_to_invlist(invlist, start, end);
6529         return invlist;
6530     }
6531
6532     /* Here, can't just append things, create and return a new inversion list
6533      * which is the union of this range and the existing inversion list */
6534     range_invlist = _new_invlist(2);
6535     _append_range_to_invlist(range_invlist, start, end);
6536
6537     _invlist_union(invlist, range_invlist, &invlist);
6538
6539     /* The temporary can be freed */
6540     SvREFCNT_dec(range_invlist);
6541
6542     return invlist;
6543 }
6544
6545 PERL_STATIC_INLINE SV*
6546 S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) {
6547     return add_range_to_invlist(invlist, cp, cp);
6548 }
6549
6550 #ifndef PERL_IN_XSUB_RE
6551 void
6552 Perl__invlist_invert(pTHX_ SV* const invlist)
6553 {
6554     /* Complement the input inversion list.  This adds a 0 if the list didn't
6555      * have a zero; removes it otherwise.  As described above, the data
6556      * structure is set up so that this is very efficient */
6557
6558     UV* len_pos = get_invlist_len_addr(invlist);
6559
6560     PERL_ARGS_ASSERT__INVLIST_INVERT;
6561
6562     /* The inverse of matching nothing is matching everything */
6563     if (*len_pos == 0) {
6564         _append_range_to_invlist(invlist, 0, UV_MAX);
6565         return;
6566     }
6567
6568     /* The exclusive or complents 0 to 1; and 1 to 0.  If the result is 1, the
6569      * zero element was a 0, so it is being removed, so the length decrements
6570      * by 1; and vice-versa.  SvCUR is unaffected */
6571     if (*get_invlist_zero_addr(invlist) ^= 1) {
6572         (*len_pos)--;
6573     }
6574     else {
6575         (*len_pos)++;
6576     }
6577 }
6578
6579 void
6580 Perl__invlist_invert_prop(pTHX_ SV* const invlist)
6581 {
6582     /* Complement the input inversion list (which must be a Unicode property,
6583      * all of which don't match above the Unicode maximum code point.)  And
6584      * Perl has chosen to not have the inversion match above that either.  This
6585      * adds a 0x110000 if the list didn't end with it, and removes it if it did
6586      */
6587
6588     UV len;
6589     UV* array;
6590
6591     PERL_ARGS_ASSERT__INVLIST_INVERT_PROP;
6592
6593     _invlist_invert(invlist);
6594
6595     len = invlist_len(invlist);
6596
6597     if (len != 0) { /* If empty do nothing */
6598         array = invlist_array(invlist);
6599         if (array[len - 1] != PERL_UNICODE_MAX + 1) {
6600             /* Add 0x110000.  First, grow if necessary */
6601             len++;
6602             if (invlist_max(invlist) < len) {
6603                 invlist_extend(invlist, len);
6604                 array = invlist_array(invlist);
6605             }
6606             invlist_set_len(invlist, len);
6607             array[len - 1] = PERL_UNICODE_MAX + 1;
6608         }
6609         else {  /* Remove the 0x110000 */
6610             invlist_set_len(invlist, len - 1);
6611         }
6612     }
6613
6614     return;
6615 }
6616 #endif
6617
6618 PERL_STATIC_INLINE SV*
6619 S_invlist_clone(pTHX_ SV* const invlist)
6620 {
6621
6622     /* Return a new inversion list that is a copy of the input one, which is
6623      * unchanged */
6624
6625     SV* new_invlist = _new_invlist(SvCUR(invlist));
6626
6627     PERL_ARGS_ASSERT_INVLIST_CLONE;
6628
6629     Copy(SvPVX(invlist), SvPVX(new_invlist), SvCUR(invlist), char);
6630     return new_invlist;
6631 }
6632
6633 #ifndef PERL_IN_XSUB_RE
6634 void
6635 Perl__invlist_subtract(pTHX_ SV* const a, SV* const b, SV** result)
6636 {
6637     /* Point result to an inversion list which consists of all elements in 'a'
6638      * that aren't also in 'b' */
6639
6640     PERL_ARGS_ASSERT__INVLIST_SUBTRACT;
6641
6642     /* Subtracting nothing retains the original */
6643     if (invlist_len(b) == 0) {
6644
6645         /* If the result is not to be the same variable as the original, create
6646          * a copy */
6647         if (result != &a) {
6648             *result = invlist_clone(a);
6649         }
6650     } else {
6651         SV *b_copy = invlist_clone(b);
6652         _invlist_invert(b_copy);        /* Everything not in 'b' */
6653         _invlist_intersection(a, b_copy, result);    /* Everything in 'a' not in
6654                                                        'b' */
6655         SvREFCNT_dec(b_copy);
6656     }
6657
6658     if (result == &b) {
6659         SvREFCNT_dec(b);
6660     }
6661
6662     return;
6663 }
6664 #endif
6665
6666 PERL_STATIC_INLINE UV*
6667 S_get_invlist_iter_addr(pTHX_ SV* invlist)
6668 {
6669     /* Return the address of the UV that contains the current iteration
6670      * position */
6671
6672     PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR;
6673
6674     return (UV *) (SvPVX(invlist) + (INVLIST_ITER_OFFSET * sizeof (UV)));
6675 }
6676
6677 PERL_STATIC_INLINE void
6678 S_invlist_iterinit(pTHX_ SV* invlist)   /* Initialize iterator for invlist */
6679 {
6680     PERL_ARGS_ASSERT_INVLIST_ITERINIT;
6681
6682     *get_invlist_iter_addr(invlist) = 0;
6683 }
6684
6685 STATIC bool
6686 S_invlist_iternext(pTHX_ SV* invlist, UV* start, UV* end)
6687 {
6688     UV* pos = get_invlist_iter_addr(invlist);
6689     UV len = invlist_len(invlist);
6690     UV *array;
6691
6692     PERL_ARGS_ASSERT_INVLIST_ITERNEXT;
6693
6694     if (*pos >= len) {
6695         *pos = UV_MAX;  /* Force iternit() to be required next time */
6696         return FALSE;
6697     }
6698
6699     array = invlist_array(invlist);
6700
6701     *start = array[(*pos)++];
6702
6703     if (*pos >= len) {
6704         *end = UV_MAX;
6705     }
6706     else {
6707         *end = array[(*pos)++] - 1;
6708     }
6709
6710     return TRUE;
6711 }
6712
6713 #if 0
6714 void
6715 S_invlist_dump(pTHX_ SV* const invlist, const char * const header)
6716 {
6717     /* Dumps out the ranges in an inversion list.  The string 'header'
6718      * if present is output on a line before the first range */
6719
6720     UV start, end;
6721
6722     if (header && strlen(header)) {
6723         PerlIO_printf(Perl_debug_log, "%s\n", header);
6724     }
6725     invlist_iterinit(invlist);
6726     while (invlist_iternext(invlist, &start, &end)) {
6727         if (end == UV_MAX) {
6728             PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. INFINITY\n", start);
6729         }
6730         else {
6731             PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. 0x%04"UVXf"\n", start, end);
6732         }
6733     }
6734 }
6735 #endif
6736
6737 #undef HEADER_LENGTH
6738 #undef INVLIST_INITIAL_LENGTH
6739 #undef TO_INTERNAL_SIZE
6740 #undef FROM_INTERNAL_SIZE
6741 #undef INVLIST_LEN_OFFSET
6742 #undef INVLIST_ZERO_OFFSET
6743 #undef INVLIST_ITER_OFFSET
6744
6745 /* End of inversion list object */
6746
6747 /*
6748  - reg - regular expression, i.e. main body or parenthesized thing
6749  *
6750  * Caller must absorb opening parenthesis.
6751  *
6752  * Combining parenthesis handling with the base level of regular expression
6753  * is a trifle forced, but the need to tie the tails of the branches to what
6754  * follows makes it hard to avoid.
6755  */
6756 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
6757 #ifdef DEBUGGING
6758 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
6759 #else
6760 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
6761 #endif
6762
6763 STATIC regnode *
6764 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
6765     /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
6766 {
6767     dVAR;
6768     register regnode *ret;              /* Will be the head of the group. */
6769     register regnode *br;
6770     register regnode *lastbr;
6771     register regnode *ender = NULL;
6772     register I32 parno = 0;
6773     I32 flags;
6774     U32 oregflags = RExC_flags;
6775     bool have_branch = 0;
6776     bool is_open = 0;
6777     I32 freeze_paren = 0;
6778     I32 after_freeze = 0;
6779
6780     /* for (?g), (?gc), and (?o) warnings; warning
6781        about (?c) will warn about (?g) -- japhy    */
6782
6783 #define WASTED_O  0x01
6784 #define WASTED_G  0x02
6785 #define WASTED_C  0x04
6786 #define WASTED_GC (0x02|0x04)
6787     I32 wastedflags = 0x00;
6788
6789     char * parse_start = RExC_parse; /* MJD */
6790     char * const oregcomp_parse = RExC_parse;
6791
6792     GET_RE_DEBUG_FLAGS_DECL;
6793
6794     PERL_ARGS_ASSERT_REG;
6795     DEBUG_PARSE("reg ");
6796
6797     *flagp = 0;                         /* Tentatively. */
6798
6799
6800     /* Make an OPEN node, if parenthesized. */
6801     if (paren) {
6802         if ( *RExC_parse == '*') { /* (*VERB:ARG) */
6803             char *start_verb = RExC_parse;
6804             STRLEN verb_len = 0;
6805             char *start_arg = NULL;
6806             unsigned char op = 0;
6807             int argok = 1;
6808             int internal_argval = 0; /* internal_argval is only useful if !argok */
6809             while ( *RExC_parse && *RExC_parse != ')' ) {
6810                 if ( *RExC_parse == ':' ) {
6811                     start_arg = RExC_parse + 1;
6812                     break;
6813                 }
6814                 RExC_parse++;
6815             }
6816             ++start_verb;
6817             verb_len = RExC_parse - start_verb;
6818             if ( start_arg ) {
6819                 RExC_parse++;
6820                 while ( *RExC_parse && *RExC_parse != ')' ) 
6821                     RExC_parse++;
6822                 if ( *RExC_parse != ')' ) 
6823                     vFAIL("Unterminated verb pattern argument");
6824                 if ( RExC_parse == start_arg )
6825                     start_arg = NULL;
6826             } else {
6827                 if ( *RExC_parse != ')' )
6828                     vFAIL("Unterminated verb pattern");
6829             }
6830             
6831             switch ( *start_verb ) {
6832             case 'A':  /* (*ACCEPT) */
6833                 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
6834                     op = ACCEPT;
6835                     internal_argval = RExC_nestroot;
6836                 }
6837                 break;
6838             case 'C':  /* (*COMMIT) */
6839                 if ( memEQs(start_verb,verb_len,"COMMIT") )
6840                     op = COMMIT;
6841                 break;
6842             case 'F':  /* (*FAIL) */
6843                 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
6844                     op = OPFAIL;
6845                     argok = 0;
6846                 }
6847                 break;
6848             case ':':  /* (*:NAME) */
6849             case 'M':  /* (*MARK:NAME) */
6850                 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
6851                     op = MARKPOINT;
6852                     argok = -1;
6853                 }
6854                 break;
6855             case 'P':  /* (*PRUNE) */
6856                 if ( memEQs(start_verb,verb_len,"PRUNE") )
6857                     op = PRUNE;
6858                 break;
6859             case 'S':   /* (*SKIP) */  
6860                 if ( memEQs(start_verb,verb_len,"SKIP") ) 
6861                     op = SKIP;
6862                 break;
6863             case 'T':  /* (*THEN) */
6864                 /* [19:06] <TimToady> :: is then */
6865                 if ( memEQs(start_verb,verb_len,"THEN") ) {
6866                     op = CUTGROUP;
6867                     RExC_seen |= REG_SEEN_CUTGROUP;
6868                 }
6869                 break;
6870             }
6871             if ( ! op ) {
6872                 RExC_parse++;
6873                 vFAIL3("Unknown verb pattern '%.*s'",
6874                     verb_len, start_verb);
6875             }
6876             if ( argok ) {
6877                 if ( start_arg && internal_argval ) {
6878                     vFAIL3("Verb pattern '%.*s' may not have an argument",
6879                         verb_len, start_verb); 
6880                 } else if ( argok < 0 && !start_arg ) {
6881                     vFAIL3("Verb pattern '%.*s' has a mandatory argument",
6882                         verb_len, start_verb);    
6883                 } else {
6884                     ret = reganode(pRExC_state, op, internal_argval);
6885                     if ( ! internal_argval && ! SIZE_ONLY ) {
6886                         if (start_arg) {
6887                             SV *sv = newSVpvn( start_arg, RExC_parse - start_arg);
6888                             ARG(ret) = add_data( pRExC_state, 1, "S" );
6889                             RExC_rxi->data->data[ARG(ret)]=(void*)sv;
6890                             ret->flags = 0;
6891                         } else {
6892                             ret->flags = 1; 
6893                         }
6894                     }               
6895                 }
6896                 if (!internal_argval)
6897                     RExC_seen |= REG_SEEN_VERBARG;
6898             } else if ( start_arg ) {
6899                 vFAIL3("Verb pattern '%.*s' may not have an argument",
6900                         verb_len, start_verb);    
6901             } else {
6902                 ret = reg_node(pRExC_state, op);
6903             }
6904             nextchar(pRExC_state);
6905             return ret;
6906         } else 
6907         if (*RExC_parse == '?') { /* (?...) */
6908             bool is_logical = 0;
6909             const char * const seqstart = RExC_parse;
6910             bool has_use_defaults = FALSE;
6911
6912             RExC_parse++;
6913             paren = *RExC_parse++;
6914             ret = NULL;                 /* For look-ahead/behind. */
6915             switch (paren) {
6916
6917             case 'P':   /* (?P...) variants for those used to PCRE/Python */
6918                 paren = *RExC_parse++;
6919                 if ( paren == '<')         /* (?P<...>) named capture */
6920                     goto named_capture;
6921                 else if (paren == '>') {   /* (?P>name) named recursion */
6922                     goto named_recursion;
6923                 }
6924                 else if (paren == '=') {   /* (?P=...)  named backref */
6925                     /* this pretty much dupes the code for \k<NAME> in regatom(), if
6926                        you change this make sure you change that */
6927                     char* name_start = RExC_parse;
6928                     U32 num = 0;
6929                     SV *sv_dat = reg_scan_name(pRExC_state,
6930                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6931                     if (RExC_parse == name_start || *RExC_parse != ')')
6932                         vFAIL2("Sequence %.3s... not terminated",parse_start);
6933
6934                     if (!SIZE_ONLY) {
6935                         num = add_data( pRExC_state, 1, "S" );
6936                         RExC_rxi->data->data[num]=(void*)sv_dat;
6937                         SvREFCNT_inc_simple_void(sv_dat);
6938                     }
6939                     RExC_sawback = 1;
6940                     ret = reganode(pRExC_state,
6941                                    ((! FOLD)
6942                                      ? NREF
6943                                      : (MORE_ASCII_RESTRICTED)
6944                                        ? NREFFA
6945                                        : (AT_LEAST_UNI_SEMANTICS)
6946                                          ? NREFFU
6947                                          : (LOC)
6948                                            ? NREFFL
6949                                            : NREFF),
6950                                     num);
6951                     *flagp |= HASWIDTH;
6952
6953                     Set_Node_Offset(ret, parse_start+1);
6954                     Set_Node_Cur_Length(ret); /* MJD */
6955
6956                     nextchar(pRExC_state);
6957                     return ret;
6958                 }
6959                 RExC_parse++;
6960                 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
6961                 /*NOTREACHED*/
6962             case '<':           /* (?<...) */
6963                 if (*RExC_parse == '!')
6964                     paren = ',';
6965                 else if (*RExC_parse != '=') 
6966               named_capture:
6967                 {               /* (?<...>) */
6968                     char *name_start;
6969                     SV *svname;
6970                     paren= '>';
6971             case '\'':          /* (?'...') */
6972                     name_start= RExC_parse;
6973                     svname = reg_scan_name(pRExC_state,
6974                         SIZE_ONLY ?  /* reverse test from the others */
6975                         REG_RSN_RETURN_NAME : 
6976                         REG_RSN_RETURN_NULL);
6977                     if (RExC_parse == name_start) {
6978                         RExC_parse++;
6979                         vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
6980                         /*NOTREACHED*/
6981                     }
6982                     if (*RExC_parse != paren)
6983                         vFAIL2("Sequence (?%c... not terminated",
6984                             paren=='>' ? '<' : paren);
6985                     if (SIZE_ONLY) {
6986                         HE *he_str;
6987                         SV *sv_dat = NULL;
6988                         if (!svname) /* shouldn't happen */
6989                             Perl_croak(aTHX_
6990                                 "panic: reg_scan_name returned NULL");
6991                         if (!RExC_paren_names) {
6992                             RExC_paren_names= newHV();
6993                             sv_2mortal(MUTABLE_SV(RExC_paren_names));
6994 #ifdef DEBUGGING
6995                             RExC_paren_name_list= newAV();
6996                             sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
6997 #endif
6998                         }
6999                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
7000                         if ( he_str )
7001                             sv_dat = HeVAL(he_str);
7002                         if ( ! sv_dat ) {
7003                             /* croak baby croak */
7004                             Perl_croak(aTHX_
7005                                 "panic: paren_name hash element allocation failed");
7006                         } else if ( SvPOK(sv_dat) ) {
7007                             /* (?|...) can mean we have dupes so scan to check
7008                                its already been stored. Maybe a flag indicating
7009                                we are inside such a construct would be useful,
7010                                but the arrays are likely to be quite small, so
7011                                for now we punt -- dmq */
7012                             IV count = SvIV(sv_dat);
7013                             I32 *pv = (I32*)SvPVX(sv_dat);
7014                             IV i;
7015                             for ( i = 0 ; i < count ; i++ ) {
7016                                 if ( pv[i] == RExC_npar ) {
7017                                     count = 0;
7018                                     break;
7019                                 }
7020                             }
7021                             if ( count ) {
7022                                 pv = (I32*)SvGROW(sv_dat, SvCUR(sv_dat) + sizeof(I32)+1);
7023                                 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
7024                                 pv[count] = RExC_npar;
7025                                 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
7026                             }
7027                         } else {
7028                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
7029                             sv_setpvn(sv_dat, (char *)&(RExC_npar), sizeof(I32));
7030                             SvIOK_on(sv_dat);
7031                             SvIV_set(sv_dat, 1);
7032                         }
7033 #ifdef DEBUGGING
7034                         /* Yes this does cause a memory leak in debugging Perls */
7035                         if (!av_store(RExC_paren_name_list, RExC_npar, SvREFCNT_inc(svname)))
7036                             SvREFCNT_dec(svname);
7037 #endif
7038
7039                         /*sv_dump(sv_dat);*/
7040                     }
7041                     nextchar(pRExC_state);
7042                     paren = 1;
7043                     goto capturing_parens;
7044                 }
7045                 RExC_seen |= REG_SEEN_LOOKBEHIND;
7046                 RExC_in_lookbehind++;
7047                 RExC_parse++;
7048             case '=':           /* (?=...) */
7049                 RExC_seen_zerolen++;
7050                 break;
7051             case '!':           /* (?!...) */
7052                 RExC_seen_zerolen++;
7053                 if (*RExC_parse == ')') {
7054                     ret=reg_node(pRExC_state, OPFAIL);
7055                     nextchar(pRExC_state);
7056                     return ret;
7057                 }
7058                 break;
7059             case '|':           /* (?|...) */
7060                 /* branch reset, behave like a (?:...) except that
7061                    buffers in alternations share the same numbers */
7062                 paren = ':'; 
7063                 after_freeze = freeze_paren = RExC_npar;
7064                 break;
7065             case ':':           /* (?:...) */
7066             case '>':           /* (?>...) */
7067                 break;
7068             case '$':           /* (?$...) */
7069             case '@':           /* (?@...) */
7070                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
7071                 break;
7072             case '#':           /* (?#...) */
7073                 while (*RExC_parse && *RExC_parse != ')')
7074                     RExC_parse++;
7075                 if (*RExC_parse != ')')
7076                     FAIL("Sequence (?#... not terminated");
7077                 nextchar(pRExC_state);
7078                 *flagp = TRYAGAIN;
7079                 return NULL;
7080             case '0' :           /* (?0) */
7081             case 'R' :           /* (?R) */
7082                 if (*RExC_parse != ')')
7083                     FAIL("Sequence (?R) not terminated");
7084                 ret = reg_node(pRExC_state, GOSTART);
7085                 *flagp |= POSTPONED;
7086                 nextchar(pRExC_state);
7087                 return ret;
7088                 /*notreached*/
7089             { /* named and numeric backreferences */
7090                 I32 num;
7091             case '&':            /* (?&NAME) */
7092                 parse_start = RExC_parse - 1;
7093               named_recursion:
7094                 {
7095                     SV *sv_dat = reg_scan_name(pRExC_state,
7096                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
7097                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
7098                 }
7099                 goto gen_recurse_regop;
7100                 /* NOT REACHED */
7101             case '+':
7102                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
7103                     RExC_parse++;
7104                     vFAIL("Illegal pattern");
7105                 }
7106                 goto parse_recursion;
7107                 /* NOT REACHED*/
7108             case '-': /* (?-1) */
7109                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
7110                     RExC_parse--; /* rewind to let it be handled later */
7111                     goto parse_flags;
7112                 } 
7113                 /*FALLTHROUGH */
7114             case '1': case '2': case '3': case '4': /* (?1) */
7115             case '5': case '6': case '7': case '8': case '9':
7116                 RExC_parse--;
7117               parse_recursion:
7118                 num = atoi(RExC_parse);
7119                 parse_start = RExC_parse - 1; /* MJD */
7120                 if (*RExC_parse == '-')
7121                     RExC_parse++;
7122                 while (isDIGIT(*RExC_parse))
7123                         RExC_parse++;
7124                 if (*RExC_parse!=')') 
7125                     vFAIL("Expecting close bracket");
7126                         
7127               gen_recurse_regop:
7128                 if ( paren == '-' ) {
7129                     /*
7130                     Diagram of capture buffer numbering.
7131                     Top line is the normal capture buffer numbers
7132                     Bottom line is the negative indexing as from
7133                     the X (the (?-2))
7134
7135                     +   1 2    3 4 5 X          6 7
7136                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
7137                     -   5 4    3 2 1 X          x x
7138
7139                     */
7140                     num = RExC_npar + num;
7141                     if (num < 1)  {
7142                         RExC_parse++;
7143                         vFAIL("Reference to nonexistent group");
7144                     }
7145                 } else if ( paren == '+' ) {
7146                     num = RExC_npar + num - 1;
7147                 }
7148
7149                 ret = reganode(pRExC_state, GOSUB, num);
7150                 if (!SIZE_ONLY) {
7151                     if (num > (I32)RExC_rx->nparens) {
7152                         RExC_parse++;
7153                         vFAIL("Reference to nonexistent group");
7154                     }
7155                     ARG2L_SET( ret, RExC_recurse_count++);
7156                     RExC_emit++;
7157                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
7158                         "Recurse #%"UVuf" to %"IVdf"\n", (UV)ARG(ret), (IV)ARG2L(ret)));
7159                 } else {
7160                     RExC_size++;
7161                 }
7162                 RExC_seen |= REG_SEEN_RECURSE;
7163                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
7164                 Set_Node_Offset(ret, parse_start); /* MJD */
7165
7166                 *flagp |= POSTPONED;
7167                 nextchar(pRExC_state);
7168                 return ret;
7169             } /* named and numeric backreferences */
7170             /* NOT REACHED */
7171
7172             case '?':           /* (??...) */
7173                 is_logical = 1;
7174                 if (*RExC_parse != '{') {
7175                     RExC_parse++;
7176                     vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
7177                     /*NOTREACHED*/
7178                 }
7179                 *flagp |= POSTPONED;
7180                 paren = *RExC_parse++;
7181                 /* FALL THROUGH */
7182             case '{':           /* (?{...}) */
7183             {
7184                 I32 count = 1;
7185                 U32 n = 0;
7186                 char c;
7187                 char *s = RExC_parse;
7188
7189                 RExC_seen_zerolen++;
7190                 RExC_seen |= REG_SEEN_EVAL;
7191                 while (count && (c = *RExC_parse)) {
7192                     if (c == '\\') {
7193                         if (RExC_parse[1])
7194                             RExC_parse++;
7195                     }
7196                     else if (c == '{')
7197                         count++;
7198                     else if (c == '}')
7199                         count--;
7200                     RExC_parse++;
7201                 }
7202                 if (*RExC_parse != ')') {
7203                     RExC_parse = s;             
7204                     vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
7205                 }
7206                 if (!SIZE_ONLY) {
7207                     PAD *pad;
7208                     OP_4tree *sop, *rop;
7209                     SV * const sv = newSVpvn(s, RExC_parse - 1 - s);
7210
7211                     ENTER;
7212                     Perl_save_re_context(aTHX);
7213                     rop = Perl_sv_compile_2op_is_broken(aTHX_ sv, &sop, "re", &pad);
7214                     sop->op_private |= OPpREFCOUNTED;
7215                     /* re_dup will OpREFCNT_inc */
7216                     OpREFCNT_set(sop, 1);
7217                     LEAVE;
7218
7219                     n = add_data(pRExC_state, 3, "nop");
7220                     RExC_rxi->data->data[n] = (void*)rop;
7221                     RExC_rxi->data->data[n+1] = (void*)sop;
7222                     RExC_rxi->data->data[n+2] = (void*)pad;
7223                     SvREFCNT_dec(sv);
7224                 }
7225                 else {                                          /* First pass */
7226                     if (PL_reginterp_cnt < ++RExC_seen_evals
7227                         && IN_PERL_RUNTIME)
7228                         /* No compiled RE interpolated, has runtime
7229                            components ===> unsafe.  */
7230                         FAIL("Eval-group not allowed at runtime, use re 'eval'");
7231                     if (PL_tainting && PL_tainted)
7232                         FAIL("Eval-group in insecure regular expression");
7233 #if PERL_VERSION > 8
7234                     if (IN_PERL_COMPILETIME)
7235                         PL_cv_has_eval = 1;
7236 #endif
7237                 }
7238
7239                 nextchar(pRExC_state);
7240                 if (is_logical) {
7241                     ret = reg_node(pRExC_state, LOGICAL);
7242                     if (!SIZE_ONLY)
7243                         ret->flags = 2;
7244                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, EVAL, n));
7245                     /* deal with the length of this later - MJD */
7246                     return ret;
7247                 }
7248                 ret = reganode(pRExC_state, EVAL, n);
7249                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
7250                 Set_Node_Offset(ret, parse_start);
7251                 return ret;
7252             }
7253             case '(':           /* (?(?{...})...) and (?(?=...)...) */
7254             {
7255                 int is_define= 0;
7256                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
7257                     if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
7258                         || RExC_parse[1] == '<'
7259                         || RExC_parse[1] == '{') { /* Lookahead or eval. */
7260                         I32 flag;
7261                         
7262                         ret = reg_node(pRExC_state, LOGICAL);
7263                         if (!SIZE_ONLY)
7264                             ret->flags = 1;
7265                         REGTAIL(pRExC_state, ret, reg(pRExC_state, 1, &flag,depth+1));
7266                         goto insert_if;
7267                     }
7268                 }
7269                 else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
7270                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
7271                 {
7272                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
7273                     char *name_start= RExC_parse++;
7274                     U32 num = 0;
7275                     SV *sv_dat=reg_scan_name(pRExC_state,
7276                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
7277                     if (RExC_parse == name_start || *RExC_parse != ch)
7278                         vFAIL2("Sequence (?(%c... not terminated",
7279                             (ch == '>' ? '<' : ch));
7280                     RExC_parse++;
7281                     if (!SIZE_ONLY) {
7282                         num = add_data( pRExC_state, 1, "S" );
7283                         RExC_rxi->data->data[num]=(void*)sv_dat;
7284                         SvREFCNT_inc_simple_void(sv_dat);
7285                     }
7286                     ret = reganode(pRExC_state,NGROUPP,num);
7287                     goto insert_if_check_paren;
7288                 }
7289                 else if (RExC_parse[0] == 'D' &&
7290                          RExC_parse[1] == 'E' &&
7291                          RExC_parse[2] == 'F' &&
7292                          RExC_parse[3] == 'I' &&
7293                          RExC_parse[4] == 'N' &&
7294                          RExC_parse[5] == 'E')
7295                 {
7296                     ret = reganode(pRExC_state,DEFINEP,0);
7297                     RExC_parse +=6 ;
7298                     is_define = 1;
7299                     goto insert_if_check_paren;
7300                 }
7301                 else if (RExC_parse[0] == 'R') {
7302                     RExC_parse++;
7303                     parno = 0;
7304                     if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
7305                         parno = atoi(RExC_parse++);
7306                         while (isDIGIT(*RExC_parse))
7307                             RExC_parse++;
7308                     } else if (RExC_parse[0] == '&') {
7309                         SV *sv_dat;
7310                         RExC_parse++;
7311                         sv_dat = reg_scan_name(pRExC_state,
7312                             SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
7313                         parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
7314                     }
7315                     ret = reganode(pRExC_state,INSUBP,parno); 
7316                     goto insert_if_check_paren;
7317                 }
7318                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
7319                     /* (?(1)...) */
7320                     char c;
7321                     parno = atoi(RExC_parse++);
7322
7323                     while (isDIGIT(*RExC_parse))
7324                         RExC_parse++;
7325                     ret = reganode(pRExC_state, GROUPP, parno);
7326
7327                  insert_if_check_paren:
7328                     if ((c = *nextchar(pRExC_state)) != ')')
7329                         vFAIL("Switch condition not recognized");
7330                   insert_if:
7331                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
7332                     br = regbranch(pRExC_state, &flags, 1,depth+1);
7333                     if (br == NULL)
7334                         br = reganode(pRExC_state, LONGJMP, 0);
7335                     else
7336                         REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
7337                     c = *nextchar(pRExC_state);
7338                     if (flags&HASWIDTH)
7339                         *flagp |= HASWIDTH;
7340                     if (c == '|') {
7341                         if (is_define) 
7342                             vFAIL("(?(DEFINE)....) does not allow branches");
7343                         lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
7344                         regbranch(pRExC_state, &flags, 1,depth+1);
7345                         REGTAIL(pRExC_state, ret, lastbr);
7346                         if (flags&HASWIDTH)
7347                             *flagp |= HASWIDTH;
7348                         c = *nextchar(pRExC_state);
7349                     }
7350                     else
7351                         lastbr = NULL;
7352                     if (c != ')')
7353                         vFAIL("Switch (?(condition)... contains too many branches");
7354                     ender = reg_node(pRExC_state, TAIL);
7355                     REGTAIL(pRExC_state, br, ender);
7356                     if (lastbr) {
7357                         REGTAIL(pRExC_state, lastbr, ender);
7358                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
7359                     }
7360                     else
7361                         REGTAIL(pRExC_state, ret, ender);
7362                     RExC_size++; /* XXX WHY do we need this?!!
7363                                     For large programs it seems to be required
7364                                     but I can't figure out why. -- dmq*/
7365                     return ret;
7366                 }
7367                 else {
7368                     vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
7369                 }
7370             }
7371             case 0:
7372                 RExC_parse--; /* for vFAIL to print correctly */
7373                 vFAIL("Sequence (? incomplete");
7374                 break;
7375             case DEFAULT_PAT_MOD:   /* Use default flags with the exceptions
7376                                        that follow */
7377                 has_use_defaults = TRUE;
7378                 STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
7379                 set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
7380                                                 ? REGEX_UNICODE_CHARSET
7381                                                 : REGEX_DEPENDS_CHARSET);
7382                 goto parse_flags;
7383             default:
7384                 --RExC_parse;
7385                 parse_flags:      /* (?i) */  
7386             {
7387                 U32 posflags = 0, negflags = 0;
7388                 U32 *flagsp = &posflags;
7389                 char has_charset_modifier = '\0';
7390                 regex_charset cs = (RExC_utf8 || RExC_uni_semantics)
7391                                     ? REGEX_UNICODE_CHARSET
7392                                     : REGEX_DEPENDS_CHARSET;
7393
7394                 while (*RExC_parse) {
7395                     /* && strchr("iogcmsx", *RExC_parse) */
7396                     /* (?g), (?gc) and (?o) are useless here
7397                        and must be globally applied -- japhy */
7398                     switch (*RExC_parse) {
7399                     CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp);
7400                     case LOCALE_PAT_MOD:
7401                         if (has_charset_modifier) {
7402                             goto excess_modifier;
7403                         }
7404                         else if (flagsp == &negflags) {
7405                             goto neg_modifier;
7406                         }
7407                         cs = REGEX_LOCALE_CHARSET;
7408                         has_charset_modifier = LOCALE_PAT_MOD;
7409                         RExC_contains_locale = 1;
7410                         break;
7411                     case UNICODE_PAT_MOD:
7412                         if (has_charset_modifier) {
7413                             goto excess_modifier;
7414                         }
7415                         else if (flagsp == &negflags) {
7416                             goto neg_modifier;
7417                         }
7418                         cs = REGEX_UNICODE_CHARSET;
7419                         has_charset_modifier = UNICODE_PAT_MOD;
7420                         break;
7421                     case ASCII_RESTRICT_PAT_MOD:
7422                         if (flagsp == &negflags) {
7423                             goto neg_modifier;
7424                         }
7425                         if (has_charset_modifier) {
7426                             if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
7427                                 goto excess_modifier;
7428                             }
7429                             /* Doubled modifier implies more restricted */
7430                             cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
7431                         }
7432                         else {
7433                             cs = REGEX_ASCII_RESTRICTED_CHARSET;
7434                         }
7435                         has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
7436                         break;
7437                     case DEPENDS_PAT_MOD:
7438                         if (has_use_defaults) {
7439                             goto fail_modifiers;
7440                         }
7441                         else if (flagsp == &negflags) {
7442                             goto neg_modifier;
7443                         }
7444                         else if (has_charset_modifier) {
7445                             goto excess_modifier;
7446                         }
7447
7448                         /* The dual charset means unicode semantics if the
7449                          * pattern (or target, not known until runtime) are
7450                          * utf8, or something in the pattern indicates unicode
7451                          * semantics */
7452                         cs = (RExC_utf8 || RExC_uni_semantics)
7453                              ? REGEX_UNICODE_CHARSET
7454                              : REGEX_DEPENDS_CHARSET;
7455                         has_charset_modifier = DEPENDS_PAT_MOD;
7456                         break;
7457                     excess_modifier:
7458                         RExC_parse++;
7459                         if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
7460                             vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
7461                         }
7462                         else if (has_charset_modifier == *(RExC_parse - 1)) {
7463                             vFAIL2("Regexp modifier \"%c\" may not appear twice", *(RExC_parse - 1));
7464                         }
7465                         else {
7466                             vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
7467                         }
7468                         /*NOTREACHED*/
7469                     neg_modifier:
7470                         RExC_parse++;
7471                         vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"", *(RExC_parse - 1));
7472                         /*NOTREACHED*/
7473                     case ONCE_PAT_MOD: /* 'o' */
7474                     case GLOBAL_PAT_MOD: /* 'g' */
7475                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
7476                             const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
7477                             if (! (wastedflags & wflagbit) ) {
7478                                 wastedflags |= wflagbit;
7479                                 vWARN5(
7480                                     RExC_parse + 1,
7481                                     "Useless (%s%c) - %suse /%c modifier",
7482                                     flagsp == &negflags ? "?-" : "?",
7483                                     *RExC_parse,
7484                                     flagsp == &negflags ? "don't " : "",
7485                                     *RExC_parse
7486                                 );
7487                             }
7488                         }
7489                         break;
7490                         
7491                     case CONTINUE_PAT_MOD: /* 'c' */
7492                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
7493                             if (! (wastedflags & WASTED_C) ) {
7494                                 wastedflags |= WASTED_GC;
7495                                 vWARN3(
7496                                     RExC_parse + 1,
7497                                     "Useless (%sc) - %suse /gc modifier",
7498                                     flagsp == &negflags ? "?-" : "?",
7499                                     flagsp == &negflags ? "don't " : ""
7500                                 );
7501                             }
7502                         }
7503                         break;
7504                     case KEEPCOPY_PAT_MOD: /* 'p' */
7505                         if (flagsp == &negflags) {
7506                             if (SIZE_ONLY)
7507                                 ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
7508                         } else {
7509                             *flagsp |= RXf_PMf_KEEPCOPY;
7510                         }
7511                         break;
7512                     case '-':
7513                         /* A flag is a default iff it is following a minus, so
7514                          * if there is a minus, it means will be trying to
7515                          * re-specify a default which is an error */
7516                         if (has_use_defaults || flagsp == &negflags) {
7517             fail_modifiers:
7518                             RExC_parse++;
7519                             vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
7520                             /*NOTREACHED*/
7521                         }
7522                         flagsp = &negflags;
7523                         wastedflags = 0;  /* reset so (?g-c) warns twice */
7524                         break;
7525                     case ':':
7526                         paren = ':';
7527                         /*FALLTHROUGH*/
7528                     case ')':
7529                         RExC_flags |= posflags;
7530                         RExC_flags &= ~negflags;
7531                         set_regex_charset(&RExC_flags, cs);
7532                         if (paren != ':') {
7533                             oregflags |= posflags;
7534                             oregflags &= ~negflags;
7535                             set_regex_charset(&oregflags, cs);
7536                         }
7537                         nextchar(pRExC_state);
7538                         if (paren != ':') {
7539                             *flagp = TRYAGAIN;
7540                             return NULL;
7541                         } else {
7542                             ret = NULL;
7543                             goto parse_rest;
7544                         }
7545                         /*NOTREACHED*/
7546                     default:
7547                         RExC_parse++;
7548                         vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
7549                         /*NOTREACHED*/
7550                     }                           
7551                     ++RExC_parse;
7552                 }
7553             }} /* one for the default block, one for the switch */
7554         }
7555         else {                  /* (...) */
7556           capturing_parens:
7557             parno = RExC_npar;
7558             RExC_npar++;
7559             
7560             ret = reganode(pRExC_state, OPEN, parno);
7561             if (!SIZE_ONLY ){
7562                 if (!RExC_nestroot) 
7563                     RExC_nestroot = parno;
7564                 if (RExC_seen & REG_SEEN_RECURSE
7565                     && !RExC_open_parens[parno-1])
7566                 {
7567                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
7568                         "Setting open paren #%"IVdf" to %d\n", 
7569                         (IV)parno, REG_NODE_NUM(ret)));
7570                     RExC_open_parens[parno-1]= ret;
7571                 }
7572             }
7573             Set_Node_Length(ret, 1); /* MJD */
7574             Set_Node_Offset(ret, RExC_parse); /* MJD */
7575             is_open = 1;
7576         }
7577     }
7578     else                        /* ! paren */
7579         ret = NULL;
7580    
7581    parse_rest:
7582     /* Pick up the branches, linking them together. */
7583     parse_start = RExC_parse;   /* MJD */
7584     br = regbranch(pRExC_state, &flags, 1,depth+1);
7585
7586     /*     branch_len = (paren != 0); */
7587
7588     if (br == NULL)
7589         return(NULL);
7590     if (*RExC_parse == '|') {
7591         if (!SIZE_ONLY && RExC_extralen) {
7592             reginsert(pRExC_state, BRANCHJ, br, depth+1);
7593         }
7594         else {                  /* MJD */
7595             reginsert(pRExC_state, BRANCH, br, depth+1);
7596             Set_Node_Length(br, paren != 0);
7597             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
7598         }
7599         have_branch = 1;
7600         if (SIZE_ONLY)
7601             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
7602     }
7603     else if (paren == ':') {
7604         *flagp |= flags&SIMPLE;
7605     }
7606     if (is_open) {                              /* Starts with OPEN. */
7607         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
7608     }
7609     else if (paren != '?')              /* Not Conditional */
7610         ret = br;
7611     *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
7612     lastbr = br;
7613     while (*RExC_parse == '|') {
7614         if (!SIZE_ONLY && RExC_extralen) {
7615             ender = reganode(pRExC_state, LONGJMP,0);
7616             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
7617         }
7618         if (SIZE_ONLY)
7619             RExC_extralen += 2;         /* Account for LONGJMP. */
7620         nextchar(pRExC_state);
7621         if (freeze_paren) {
7622             if (RExC_npar > after_freeze)
7623                 after_freeze = RExC_npar;
7624             RExC_npar = freeze_paren;       
7625         }
7626         br = regbranch(pRExC_state, &flags, 0, depth+1);
7627
7628         if (br == NULL)
7629             return(NULL);
7630         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
7631         lastbr = br;
7632         *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
7633     }
7634
7635     if (have_branch || paren != ':') {
7636         /* Make a closing node, and hook it on the end. */
7637         switch (paren) {
7638         case ':':
7639             ender = reg_node(pRExC_state, TAIL);
7640             break;
7641         case 1:
7642             ender = reganode(pRExC_state, CLOSE, parno);
7643             if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) {
7644                 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
7645                         "Setting close paren #%"IVdf" to %d\n", 
7646                         (IV)parno, REG_NODE_NUM(ender)));
7647                 RExC_close_parens[parno-1]= ender;
7648                 if (RExC_nestroot == parno) 
7649                     RExC_nestroot = 0;
7650             }       
7651             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
7652             Set_Node_Length(ender,1); /* MJD */
7653             break;
7654         case '<':
7655         case ',':
7656         case '=':
7657         case '!':
7658             *flagp &= ~HASWIDTH;
7659             /* FALL THROUGH */
7660         case '>':
7661             ender = reg_node(pRExC_state, SUCCEED);
7662             break;
7663         case 0:
7664             ender = reg_node(pRExC_state, END);
7665             if (!SIZE_ONLY) {
7666                 assert(!RExC_opend); /* there can only be one! */
7667                 RExC_opend = ender;
7668             }
7669             break;
7670         }
7671         REGTAIL(pRExC_state, lastbr, ender);
7672
7673         if (have_branch && !SIZE_ONLY) {
7674             if (depth==1)
7675                 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
7676
7677             /* Hook the tails of the branches to the closing node. */
7678             for (br = ret; br; br = regnext(br)) {
7679                 const U8 op = PL_regkind[OP(br)];
7680                 if (op == BRANCH) {
7681                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
7682                 }
7683                 else if (op == BRANCHJ) {
7684                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
7685                 }
7686             }
7687         }
7688     }
7689
7690     {
7691         const char *p;
7692         static const char parens[] = "=!<,>";
7693
7694         if (paren && (p = strchr(parens, paren))) {
7695             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
7696             int flag = (p - parens) > 1;
7697
7698             if (paren == '>')
7699                 node = SUSPEND, flag = 0;
7700             reginsert(pRExC_state, node,ret, depth+1);
7701             Set_Node_Cur_Length(ret);
7702             Set_Node_Offset(ret, parse_start + 1);
7703             ret->flags = flag;
7704             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
7705         }
7706     }
7707
7708     /* Check for proper termination. */
7709     if (paren) {
7710         RExC_flags = oregflags;
7711         if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
7712             RExC_parse = oregcomp_parse;
7713             vFAIL("Unmatched (");
7714         }
7715     }
7716     else if (!paren && RExC_parse < RExC_end) {
7717         if (*RExC_parse == ')') {
7718             RExC_parse++;
7719             vFAIL("Unmatched )");
7720         }
7721         else
7722             FAIL("Junk on end of regexp");      /* "Can't happen". */
7723         /* NOTREACHED */
7724     }
7725
7726     if (RExC_in_lookbehind) {
7727         RExC_in_lookbehind--;
7728     }
7729     if (after_freeze > RExC_npar)
7730         RExC_npar = after_freeze;
7731     return(ret);
7732 }
7733
7734 /*
7735  - regbranch - one alternative of an | operator
7736  *
7737  * Implements the concatenation operator.
7738  */
7739 STATIC regnode *
7740 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
7741 {
7742     dVAR;
7743     register regnode *ret;
7744     register regnode *chain = NULL;
7745     register regnode *latest;
7746     I32 flags = 0, c = 0;
7747     GET_RE_DEBUG_FLAGS_DECL;
7748
7749     PERL_ARGS_ASSERT_REGBRANCH;
7750
7751     DEBUG_PARSE("brnc");
7752
7753     if (first)
7754         ret = NULL;
7755     else {
7756         if (!SIZE_ONLY && RExC_extralen)
7757             ret = reganode(pRExC_state, BRANCHJ,0);
7758         else {
7759             ret = reg_node(pRExC_state, BRANCH);
7760             Set_Node_Length(ret, 1);
7761         }
7762     }
7763         
7764     if (!first && SIZE_ONLY)
7765         RExC_extralen += 1;                     /* BRANCHJ */
7766
7767     *flagp = WORST;                     /* Tentatively. */
7768
7769     RExC_parse--;
7770     nextchar(pRExC_state);
7771     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
7772         flags &= ~TRYAGAIN;
7773         latest = regpiece(pRExC_state, &flags,depth+1);
7774         if (latest == NULL) {
7775             if (flags & TRYAGAIN)
7776                 continue;
7777             return(NULL);
7778         }
7779         else if (ret == NULL)
7780             ret = latest;
7781         *flagp |= flags&(HASWIDTH|POSTPONED);
7782         if (chain == NULL)      /* First piece. */
7783             *flagp |= flags&SPSTART;
7784         else {
7785             RExC_naughty++;
7786             REGTAIL(pRExC_state, chain, latest);
7787         }
7788         chain = latest;
7789         c++;
7790     }
7791     if (chain == NULL) {        /* Loop ran zero times. */
7792         chain = reg_node(pRExC_state, NOTHING);
7793         if (ret == NULL)
7794             ret = chain;
7795     }
7796     if (c == 1) {
7797         *flagp |= flags&SIMPLE;
7798     }
7799
7800     return ret;
7801 }
7802
7803 /*
7804  - regpiece - something followed by possible [*+?]
7805  *
7806  * Note that the branching code sequences used for ? and the general cases
7807  * of * and + are somewhat optimized:  they use the same NOTHING node as
7808  * both the endmarker for their branch list and the body of the last branch.
7809  * It might seem that this node could be dispensed with entirely, but the
7810  * endmarker role is not redundant.
7811  */
7812 STATIC regnode *
7813 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
7814 {
7815     dVAR;
7816     register regnode *ret;
7817     register char op;
7818     register char *next;
7819     I32 flags;
7820     const char * const origparse = RExC_parse;
7821     I32 min;
7822     I32 max = REG_INFTY;
7823 #ifdef RE_TRACK_PATTERN_OFFSETS
7824     char *parse_start;
7825 #endif
7826     const char *maxpos = NULL;
7827     GET_RE_DEBUG_FLAGS_DECL;
7828
7829     PERL_ARGS_ASSERT_REGPIECE;
7830
7831     DEBUG_PARSE("piec");
7832
7833     ret = regatom(pRExC_state, &flags,depth+1);
7834     if (ret == NULL) {
7835         if (flags & TRYAGAIN)
7836             *flagp |= TRYAGAIN;
7837         return(NULL);
7838     }
7839
7840     op = *RExC_parse;
7841
7842     if (op == '{' && regcurly(RExC_parse)) {
7843         maxpos = NULL;
7844 #ifdef RE_TRACK_PATTERN_OFFSETS
7845         parse_start = RExC_parse; /* MJD */
7846 #endif
7847         next = RExC_parse + 1;
7848         while (isDIGIT(*next) || *next == ',') {
7849             if (*next == ',') {
7850                 if (maxpos)
7851                     break;
7852                 else
7853                     maxpos = next;
7854             }
7855             next++;
7856         }
7857         if (*next == '}') {             /* got one */
7858             if (!maxpos)
7859                 maxpos = next;
7860             RExC_parse++;
7861             min = atoi(RExC_parse);
7862             if (*maxpos == ',')
7863                 maxpos++;
7864             else
7865                 maxpos = RExC_parse;
7866             max = atoi(maxpos);
7867             if (!max && *maxpos != '0')
7868                 max = REG_INFTY;                /* meaning "infinity" */
7869             else if (max >= REG_INFTY)
7870                 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
7871             RExC_parse = next;
7872             nextchar(pRExC_state);
7873
7874         do_curly:
7875             if ((flags&SIMPLE)) {
7876                 RExC_naughty += 2 + RExC_naughty / 2;
7877                 reginsert(pRExC_state, CURLY, ret, depth+1);
7878                 Set_Node_Offset(ret, parse_start+1); /* MJD */
7879                 Set_Node_Cur_Length(ret);
7880             }
7881             else {
7882                 regnode * const w = reg_node(pRExC_state, WHILEM);
7883
7884                 w->flags = 0;
7885                 REGTAIL(pRExC_state, ret, w);
7886                 if (!SIZE_ONLY && RExC_extralen) {
7887                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
7888                     reginsert(pRExC_state, NOTHING,ret, depth+1);
7889                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
7890                 }
7891                 reginsert(pRExC_state, CURLYX,ret, depth+1);
7892                                 /* MJD hk */
7893                 Set_Node_Offset(ret, parse_start+1);
7894                 Set_Node_Length(ret,
7895                                 op == '{' ? (RExC_parse - parse_start) : 1);
7896
7897                 if (!SIZE_ONLY && RExC_extralen)
7898                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
7899                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
7900                 if (SIZE_ONLY)
7901                     RExC_whilem_seen++, RExC_extralen += 3;
7902                 RExC_naughty += 4 + RExC_naughty;       /* compound interest */
7903             }
7904             ret->flags = 0;
7905
7906             if (min > 0)
7907                 *flagp = WORST;
7908             if (max > 0)
7909                 *flagp |= HASWIDTH;
7910             if (max < min)
7911                 vFAIL("Can't do {n,m} with n > m");
7912             if (!SIZE_ONLY) {
7913                 ARG1_SET(ret, (U16)min);
7914                 ARG2_SET(ret, (U16)max);
7915             }
7916
7917             goto nest_check;
7918         }
7919     }
7920
7921     if (!ISMULT1(op)) {
7922         *flagp = flags;
7923         return(ret);
7924     }
7925
7926 #if 0                           /* Now runtime fix should be reliable. */
7927
7928     /* if this is reinstated, don't forget to put this back into perldiag:
7929
7930             =item Regexp *+ operand could be empty at {#} in regex m/%s/
7931
7932            (F) The part of the regexp subject to either the * or + quantifier
7933            could match an empty string. The {#} shows in the regular
7934            expression about where the problem was discovered.
7935
7936     */
7937
7938     if (!(flags&HASWIDTH) && op != '?')
7939       vFAIL("Regexp *+ operand could be empty");
7940 #endif
7941
7942 #ifdef RE_TRACK_PATTERN_OFFSETS
7943     parse_start = RExC_parse;
7944 #endif
7945     nextchar(pRExC_state);
7946
7947     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
7948
7949     if (op == '*' && (flags&SIMPLE)) {
7950         reginsert(pRExC_state, STAR, ret, depth+1);
7951         ret->flags = 0;
7952         RExC_naughty += 4;
7953     }
7954     else if (op == '*') {
7955         min = 0;
7956         goto do_curly;
7957     }
7958     else if (op == '+' && (flags&SIMPLE)) {
7959         reginsert(pRExC_state, PLUS, ret, depth+1);
7960         ret->flags = 0;
7961         RExC_naughty += 3;
7962     }
7963     else if (op == '+') {
7964         min = 1;
7965         goto do_curly;
7966     }
7967     else if (op == '?') {
7968         min = 0; max = 1;
7969         goto do_curly;
7970     }
7971   nest_check:
7972     if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
7973         ckWARN3reg(RExC_parse,
7974                    "%.*s matches null string many times",
7975                    (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0),
7976                    origparse);
7977     }
7978
7979     if (RExC_parse < RExC_end && *RExC_parse == '?') {
7980         nextchar(pRExC_state);
7981         reginsert(pRExC_state, MINMOD, ret, depth+1);
7982         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
7983     }
7984 #ifndef REG_ALLOW_MINMOD_SUSPEND
7985     else
7986 #endif
7987     if (RExC_parse < RExC_end && *RExC_parse == '+') {
7988         regnode *ender;
7989         nextchar(pRExC_state);
7990         ender = reg_node(pRExC_state, SUCCEED);
7991         REGTAIL(pRExC_state, ret, ender);
7992         reginsert(pRExC_state, SUSPEND, ret, depth+1);
7993         ret->flags = 0;
7994         ender = reg_node(pRExC_state, TAIL);
7995         REGTAIL(pRExC_state, ret, ender);
7996         /*ret= ender;*/
7997     }
7998
7999     if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) {
8000         RExC_parse++;
8001         vFAIL("Nested quantifiers");
8002     }
8003
8004     return(ret);
8005 }
8006
8007
8008 /* reg_namedseq(pRExC_state,UVp, UV depth)
8009    
8010    This is expected to be called by a parser routine that has 
8011    recognized '\N' and needs to handle the rest. RExC_parse is
8012    expected to point at the first char following the N at the time
8013    of the call.
8014
8015    The \N may be inside (indicated by valuep not being NULL) or outside a
8016    character class.
8017
8018    \N may begin either a named sequence, or if outside a character class, mean
8019    to match a non-newline.  For non single-quoted regexes, the tokenizer has
8020    attempted to decide which, and in the case of a named sequence converted it
8021    into one of the forms: \N{} (if the sequence is null), or \N{U+c1.c2...},
8022    where c1... are the characters in the sequence.  For single-quoted regexes,
8023    the tokenizer passes the \N sequence through unchanged; this code will not
8024    attempt to determine this nor expand those.  The net effect is that if the
8025    beginning of the passed-in pattern isn't '{U+' or there is no '}', it
8026    signals that this \N occurrence means to match a non-newline.
8027    
8028    Only the \N{U+...} form should occur in a character class, for the same
8029    reason that '.' inside a character class means to just match a period: it
8030    just doesn't make sense.
8031    
8032    If valuep is non-null then it is assumed that we are parsing inside 
8033    of a charclass definition and the first codepoint in the resolved
8034    string is returned via *valuep and the routine will return NULL. 
8035    In this mode if a multichar string is returned from the charnames 
8036    handler, a warning will be issued, and only the first char in the 
8037    sequence will be examined. If the string returned is zero length
8038    then the value of *valuep is undefined and NON-NULL will 
8039    be returned to indicate failure. (This will NOT be a valid pointer 
8040    to a regnode.)
8041    
8042    If valuep is null then it is assumed that we are parsing normal text and a
8043    new EXACT node is inserted into the program containing the resolved string,
8044    and a pointer to the new node is returned.  But if the string is zero length
8045    a NOTHING node is emitted instead.
8046
8047    On success RExC_parse is set to the char following the endbrace.
8048    Parsing failures will generate a fatal error via vFAIL(...)
8049  */
8050 STATIC regnode *
8051 S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep, I32 *flagp, U32 depth)
8052 {
8053     char * endbrace;    /* '}' following the name */
8054     regnode *ret = NULL;
8055     char* p;
8056
8057     GET_RE_DEBUG_FLAGS_DECL;
8058  
8059     PERL_ARGS_ASSERT_REG_NAMEDSEQ;
8060
8061     GET_RE_DEBUG_FLAGS;
8062
8063     /* The [^\n] meaning of \N ignores spaces and comments under the /x
8064      * modifier.  The other meaning does not */
8065     p = (RExC_flags & RXf_PMf_EXTENDED)
8066         ? regwhite( pRExC_state, RExC_parse )
8067         : RExC_parse;
8068    
8069     /* Disambiguate between \N meaning a named character versus \N meaning
8070      * [^\n].  The former is assumed when it can't be the latter. */
8071     if (*p != '{' || regcurly(p)) {
8072         RExC_parse = p;
8073         if (valuep) {
8074             /* no bare \N in a charclass */
8075             vFAIL("\\N in a character class must be a named character: \\N{...}");
8076         }
8077         nextchar(pRExC_state);
8078         ret = reg_node(pRExC_state, REG_ANY);
8079         *flagp |= HASWIDTH|SIMPLE;
8080         RExC_naughty++;
8081         RExC_parse--;
8082         Set_Node_Length(ret, 1); /* MJD */
8083         return ret;
8084     }
8085
8086     /* Here, we have decided it should be a named sequence */
8087
8088     /* The test above made sure that the next real character is a '{', but
8089      * under the /x modifier, it could be separated by space (or a comment and
8090      * \n) and this is not allowed (for consistency with \x{...} and the
8091      * tokenizer handling of \N{NAME}). */
8092     if (*RExC_parse != '{') {
8093         vFAIL("Missing braces on \\N{}");
8094     }
8095
8096     RExC_parse++;       /* Skip past the '{' */
8097
8098     if (! (endbrace = strchr(RExC_parse, '}')) /* no trailing brace */
8099         || ! (endbrace == RExC_parse            /* nothing between the {} */
8100               || (endbrace - RExC_parse >= 2    /* U+ (bad hex is checked below */
8101                   && strnEQ(RExC_parse, "U+", 2)))) /* for a better error msg) */
8102     {
8103         if (endbrace) RExC_parse = endbrace;    /* position msg's '<--HERE' */
8104         vFAIL("\\N{NAME} must be resolved by the lexer");
8105     }
8106
8107     if (endbrace == RExC_parse) {   /* empty: \N{} */
8108         if (! valuep) {
8109             RExC_parse = endbrace + 1;  
8110             return reg_node(pRExC_state,NOTHING);
8111         }
8112
8113         if (SIZE_ONLY) {
8114             ckWARNreg(RExC_parse,
8115                     "Ignoring zero length \\N{} in character class"
8116             );
8117             RExC_parse = endbrace + 1;  
8118         }
8119         *valuep = 0;
8120         return (regnode *) &RExC_parse; /* Invalid regnode pointer */
8121     }
8122
8123     REQUIRE_UTF8;       /* named sequences imply Unicode semantics */
8124     RExC_parse += 2;    /* Skip past the 'U+' */
8125
8126     if (valuep) {   /* In a bracketed char class */
8127         /* We only pay attention to the first char of 
8128         multichar strings being returned. I kinda wonder
8129         if this makes sense as it does change the behaviour
8130         from earlier versions, OTOH that behaviour was broken
8131         as well. XXX Solution is to recharacterize as
8132         [rest-of-class]|multi1|multi2... */
8133
8134         STRLEN length_of_hex;
8135         I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
8136             | PERL_SCAN_DISALLOW_PREFIX
8137             | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
8138     
8139         char * endchar = RExC_parse + strcspn(RExC_parse, ".}");
8140         if (endchar < endbrace) {
8141             ckWARNreg(endchar, "Using just the first character returned by \\N{} in character class");
8142         }
8143
8144         length_of_hex = (STRLEN)(endchar - RExC_parse);
8145         *valuep = grok_hex(RExC_parse, &length_of_hex, &flags, NULL);
8146
8147         /* The tokenizer should have guaranteed validity, but it's possible to
8148          * bypass it by using single quoting, so check */
8149         if (length_of_hex == 0
8150             || length_of_hex != (STRLEN)(endchar - RExC_parse) )
8151         {
8152             RExC_parse += length_of_hex;        /* Includes all the valid */
8153             RExC_parse += (RExC_orig_utf8)      /* point to after 1st invalid */
8154                             ? UTF8SKIP(RExC_parse)
8155                             : 1;
8156             /* Guard against malformed utf8 */
8157             if (RExC_parse >= endchar) RExC_parse = endchar;
8158             vFAIL("Invalid hexadecimal number in \\N{U+...}");
8159         }    
8160
8161         RExC_parse = endbrace + 1;
8162         if (endchar == endbrace) return NULL;
8163
8164         ret = (regnode *) &RExC_parse;  /* Invalid regnode pointer */
8165     }
8166     else {      /* Not a char class */
8167
8168         /* What is done here is to convert this to a sub-pattern of the form
8169          * (?:\x{char1}\x{char2}...)
8170          * and then call reg recursively.  That way, it retains its atomicness,
8171          * while not having to worry about special handling that some code
8172          * points may have.  toke.c has converted the original Unicode values
8173          * to native, so that we can just pass on the hex values unchanged.  We
8174          * do have to set a flag to keep recoding from happening in the
8175          * recursion */
8176
8177         SV * substitute_parse = newSVpvn_flags("?:", 2, SVf_UTF8|SVs_TEMP);
8178         STRLEN len;
8179         char *endchar;      /* Points to '.' or '}' ending cur char in the input
8180                                stream */
8181         char *orig_end = RExC_end;
8182
8183         while (RExC_parse < endbrace) {
8184
8185             /* Code points are separated by dots.  If none, there is only one
8186              * code point, and is terminated by the brace */
8187             endchar = RExC_parse + strcspn(RExC_parse, ".}");
8188
8189             /* Convert to notation the rest of the code understands */
8190             sv_catpv(substitute_parse, "\\x{");
8191             sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
8192             sv_catpv(substitute_parse, "}");
8193
8194             /* Point to the beginning of the next character in the sequence. */
8195             RExC_parse = endchar + 1;
8196         }
8197         sv_catpv(substitute_parse, ")");
8198
8199         RExC_parse = SvPV(substitute_parse, len);
8200
8201         /* Don't allow empty number */
8202         if (len < 8) {
8203             vFAIL("Invalid hexadecimal number in \\N{U+...}");
8204         }
8205         RExC_end = RExC_parse + len;
8206
8207         /* The values are Unicode, and therefore not subject to recoding */
8208         RExC_override_recoding = 1;
8209
8210         ret = reg(pRExC_state, 1, flagp, depth+1);
8211
8212         RExC_parse = endbrace;
8213         RExC_end = orig_end;
8214         RExC_override_recoding = 0;
8215
8216         nextchar(pRExC_state);
8217     }
8218
8219     return ret;
8220 }
8221
8222
8223 /*
8224  * reg_recode
8225  *
8226  * It returns the code point in utf8 for the value in *encp.
8227  *    value: a code value in the source encoding
8228  *    encp:  a pointer to an Encode object
8229  *
8230  * If the result from Encode is not a single character,
8231  * it returns U+FFFD (Replacement character) and sets *encp to NULL.
8232  */
8233 STATIC UV
8234 S_reg_recode(pTHX_ const char value, SV **encp)
8235 {
8236     STRLEN numlen = 1;
8237     SV * const sv = newSVpvn_flags(&value, numlen, SVs_TEMP);
8238     const char * const s = *encp ? sv_recode_to_utf8(sv, *encp) : SvPVX(sv);
8239     const STRLEN newlen = SvCUR(sv);
8240     UV uv = UNICODE_REPLACEMENT;
8241
8242     PERL_ARGS_ASSERT_REG_RECODE;
8243
8244     if (newlen)
8245         uv = SvUTF8(sv)
8246              ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
8247              : *(U8*)s;
8248
8249     if (!newlen || numlen != newlen) {
8250         uv = UNICODE_REPLACEMENT;
8251         *encp = NULL;
8252     }
8253     return uv;
8254 }
8255
8256
8257 /*
8258  - regatom - the lowest level
8259
8260    Try to identify anything special at the start of the pattern. If there
8261    is, then handle it as required. This may involve generating a single regop,
8262    such as for an assertion; or it may involve recursing, such as to
8263    handle a () structure.
8264
8265    If the string doesn't start with something special then we gobble up
8266    as much literal text as we can.
8267
8268    Once we have been able to handle whatever type of thing started the
8269    sequence, we return.
8270
8271    Note: we have to be careful with escapes, as they can be both literal
8272    and special, and in the case of \10 and friends can either, depending
8273    on context. Specifically there are two separate switches for handling
8274    escape sequences, with the one for handling literal escapes requiring
8275    a dummy entry for all of the special escapes that are actually handled
8276    by the other.
8277 */
8278
8279 STATIC regnode *
8280 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
8281 {
8282     dVAR;
8283     register regnode *ret = NULL;
8284     I32 flags;
8285     char *parse_start = RExC_parse;
8286     U8 op;
8287     GET_RE_DEBUG_FLAGS_DECL;
8288     DEBUG_PARSE("atom");
8289     *flagp = WORST;             /* Tentatively. */
8290
8291     PERL_ARGS_ASSERT_REGATOM;
8292
8293 tryagain:
8294     switch ((U8)*RExC_parse) {
8295     case '^':
8296         RExC_seen_zerolen++;
8297         nextchar(pRExC_state);
8298         if (RExC_flags & RXf_PMf_MULTILINE)
8299             ret = reg_node(pRExC_state, MBOL);
8300         else if (RExC_flags & RXf_PMf_SINGLELINE)
8301             ret = reg_node(pRExC_state, SBOL);
8302         else
8303             ret = reg_node(pRExC_state, BOL);
8304         Set_Node_Length(ret, 1); /* MJD */
8305         break;
8306     case '$':
8307         nextchar(pRExC_state);
8308         if (*RExC_parse)
8309             RExC_seen_zerolen++;
8310         if (RExC_flags & RXf_PMf_MULTILINE)
8311             ret = reg_node(pRExC_state, MEOL);
8312         else if (RExC_flags & RXf_PMf_SINGLELINE)
8313             ret = reg_node(pRExC_state, SEOL);
8314         else
8315             ret = reg_node(pRExC_state, EOL);
8316         Set_Node_Length(ret, 1); /* MJD */
8317         break;
8318     case '.':
8319         nextchar(pRExC_state);
8320         if (RExC_flags & RXf_PMf_SINGLELINE)
8321             ret = reg_node(pRExC_state, SANY);
8322         else
8323             ret = reg_node(pRExC_state, REG_ANY);
8324         *flagp |= HASWIDTH|SIMPLE;
8325         RExC_naughty++;
8326         Set_Node_Length(ret, 1); /* MJD */
8327         break;
8328     case '[':
8329     {
8330         char * const oregcomp_parse = ++RExC_parse;
8331         ret = regclass(pRExC_state,depth+1);
8332         if (*RExC_parse != ']') {
8333             RExC_parse = oregcomp_parse;
8334             vFAIL("Unmatched [");
8335         }
8336         nextchar(pRExC_state);
8337         *flagp |= HASWIDTH|SIMPLE;
8338         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
8339         break;
8340     }
8341     case '(':
8342         nextchar(pRExC_state);
8343         ret = reg(pRExC_state, 1, &flags,depth+1);
8344         if (ret == NULL) {
8345                 if (flags & TRYAGAIN) {
8346                     if (RExC_parse == RExC_end) {
8347                          /* Make parent create an empty node if needed. */
8348                         *flagp |= TRYAGAIN;
8349                         return(NULL);
8350                     }
8351                     goto tryagain;
8352                 }
8353                 return(NULL);
8354         }
8355         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
8356         break;
8357     case '|':
8358     case ')':
8359         if (flags & TRYAGAIN) {
8360             *flagp |= TRYAGAIN;
8361             return NULL;
8362         }
8363         vFAIL("Internal urp");
8364                                 /* Supposed to be caught earlier. */
8365         break;
8366     case '{':
8367         if (!regcurly(RExC_parse)) {
8368             RExC_parse++;
8369             goto defchar;
8370         }
8371         /* FALL THROUGH */
8372     case '?':
8373     case '+':
8374     case '*':
8375         RExC_parse++;
8376         vFAIL("Quantifier follows nothing");
8377         break;
8378     case '\\':
8379         /* Special Escapes
8380
8381            This switch handles escape sequences that resolve to some kind
8382            of special regop and not to literal text. Escape sequnces that
8383            resolve to literal text are handled below in the switch marked
8384            "Literal Escapes".
8385
8386            Every entry in this switch *must* have a corresponding entry
8387            in the literal escape switch. However, the opposite is not
8388            required, as the default for this switch is to jump to the
8389            literal text handling code.
8390         */
8391         switch ((U8)*++RExC_parse) {
8392         /* Special Escapes */
8393         case 'A':
8394             RExC_seen_zerolen++;
8395             ret = reg_node(pRExC_state, SBOL);
8396             *flagp |= SIMPLE;
8397             goto finish_meta_pat;
8398         case 'G':
8399             ret = reg_node(pRExC_state, GPOS);
8400             RExC_seen |= REG_SEEN_GPOS;
8401             *flagp |= SIMPLE;
8402             goto finish_meta_pat;
8403         case 'K':
8404             RExC_seen_zerolen++;
8405             ret = reg_node(pRExC_state, KEEPS);
8406             *flagp |= SIMPLE;
8407             /* XXX:dmq : disabling in-place substitution seems to
8408              * be necessary here to avoid cases of memory corruption, as
8409              * with: C<$_="x" x 80; s/x\K/y/> -- rgs
8410              */
8411             RExC_seen |= REG_SEEN_LOOKBEHIND;
8412             goto finish_meta_pat;
8413         case 'Z':
8414             ret = reg_node(pRExC_state, SEOL);
8415             *flagp |= SIMPLE;
8416             RExC_seen_zerolen++;                /* Do not optimize RE away */
8417             goto finish_meta_pat;
8418         case 'z':
8419             ret = reg_node(pRExC_state, EOS);
8420             *flagp |= SIMPLE;
8421             RExC_seen_zerolen++;                /* Do not optimize RE away */
8422             goto finish_meta_pat;
8423         case 'C':
8424             ret = reg_node(pRExC_state, CANY);
8425             RExC_seen |= REG_SEEN_CANY;
8426             *flagp |= HASWIDTH|SIMPLE;
8427             goto finish_meta_pat;
8428         case 'X':
8429             ret = reg_node(pRExC_state, CLUMP);
8430             *flagp |= HASWIDTH;
8431             goto finish_meta_pat;
8432         case 'w':
8433             switch (get_regex_charset(RExC_flags)) {
8434                 case REGEX_LOCALE_CHARSET:
8435                     op = ALNUML;
8436                     break;
8437                 case REGEX_UNICODE_CHARSET:
8438                     op = ALNUMU;
8439                     break;
8440                 case REGEX_ASCII_RESTRICTED_CHARSET:
8441                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8442                     op = ALNUMA;
8443                     break;
8444                 case REGEX_DEPENDS_CHARSET:
8445                     op = ALNUM;
8446                     break;
8447                 default:
8448                     goto bad_charset;
8449             }
8450             ret = reg_node(pRExC_state, op);
8451             *flagp |= HASWIDTH|SIMPLE;
8452             goto finish_meta_pat;
8453         case 'W':
8454             switch (get_regex_charset(RExC_flags)) {
8455                 case REGEX_LOCALE_CHARSET:
8456                     op = NALNUML;
8457                     break;
8458                 case REGEX_UNICODE_CHARSET:
8459                     op = NALNUMU;
8460                     break;
8461                 case REGEX_ASCII_RESTRICTED_CHARSET:
8462                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8463                     op = NALNUMA;
8464                     break;
8465                 case REGEX_DEPENDS_CHARSET:
8466                     op = NALNUM;
8467                     break;
8468                 default:
8469                     goto bad_charset;
8470             }
8471             ret = reg_node(pRExC_state, op);
8472             *flagp |= HASWIDTH|SIMPLE;
8473             goto finish_meta_pat;
8474         case 'b':
8475             RExC_seen_zerolen++;
8476             RExC_seen |= REG_SEEN_LOOKBEHIND;
8477             switch (get_regex_charset(RExC_flags)) {
8478                 case REGEX_LOCALE_CHARSET:
8479                     op = BOUNDL;
8480                     break;
8481                 case REGEX_UNICODE_CHARSET:
8482                     op = BOUNDU;
8483                     break;
8484                 case REGEX_ASCII_RESTRICTED_CHARSET:
8485                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8486                     op = BOUNDA;
8487                     break;
8488                 case REGEX_DEPENDS_CHARSET:
8489                     op = BOUND;
8490                     break;
8491                 default:
8492                     goto bad_charset;
8493             }
8494             ret = reg_node(pRExC_state, op);
8495             FLAGS(ret) = get_regex_charset(RExC_flags);
8496             *flagp |= SIMPLE;
8497             if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
8498                 ckWARNregdep(RExC_parse, "\"\\b{\" is deprecated; use \"\\b\\{\" instead");
8499             }
8500             goto finish_meta_pat;
8501         case 'B':
8502             RExC_seen_zerolen++;
8503             RExC_seen |= REG_SEEN_LOOKBEHIND;
8504             switch (get_regex_charset(RExC_flags)) {
8505                 case REGEX_LOCALE_CHARSET:
8506                     op = NBOUNDL;
8507                     break;
8508                 case REGEX_UNICODE_CHARSET:
8509                     op = NBOUNDU;
8510                     break;
8511                 case REGEX_ASCII_RESTRICTED_CHARSET:
8512                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8513                     op = NBOUNDA;
8514                     break;
8515                 case REGEX_DEPENDS_CHARSET:
8516                     op = NBOUND;
8517                     break;
8518                 default:
8519                     goto bad_charset;
8520             }
8521             ret = reg_node(pRExC_state, op);
8522             FLAGS(ret) = get_regex_charset(RExC_flags);
8523             *flagp |= SIMPLE;
8524             if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
8525                 ckWARNregdep(RExC_parse, "\"\\B{\" is deprecated; use \"\\B\\{\" instead");
8526             }
8527             goto finish_meta_pat;
8528         case 's':
8529             switch (get_regex_charset(RExC_flags)) {
8530                 case REGEX_LOCALE_CHARSET:
8531                     op = SPACEL;
8532                     break;
8533                 case REGEX_UNICODE_CHARSET:
8534                     op = SPACEU;
8535                     break;
8536                 case REGEX_ASCII_RESTRICTED_CHARSET:
8537                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8538                     op = SPACEA;
8539                     break;
8540                 case REGEX_DEPENDS_CHARSET:
8541                     op = SPACE;
8542                     break;
8543                 default:
8544                     goto bad_charset;
8545             }
8546             ret = reg_node(pRExC_state, op);
8547             *flagp |= HASWIDTH|SIMPLE;
8548             goto finish_meta_pat;
8549         case 'S':
8550             switch (get_regex_charset(RExC_flags)) {
8551                 case REGEX_LOCALE_CHARSET:
8552                     op = NSPACEL;
8553                     break;
8554                 case REGEX_UNICODE_CHARSET:
8555                     op = NSPACEU;
8556                     break;
8557                 case REGEX_ASCII_RESTRICTED_CHARSET:
8558                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8559                     op = NSPACEA;
8560                     break;
8561                 case REGEX_DEPENDS_CHARSET:
8562                     op = NSPACE;
8563                     break;
8564                 default:
8565                     goto bad_charset;
8566             }
8567             ret = reg_node(pRExC_state, op);
8568             *flagp |= HASWIDTH|SIMPLE;
8569             goto finish_meta_pat;
8570         case 'd':
8571             switch (get_regex_charset(RExC_flags)) {
8572                 case REGEX_LOCALE_CHARSET:
8573                     op = DIGITL;
8574                     break;
8575                 case REGEX_ASCII_RESTRICTED_CHARSET:
8576                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8577                     op = DIGITA;
8578                     break;
8579                 case REGEX_DEPENDS_CHARSET: /* No difference between these */
8580                 case REGEX_UNICODE_CHARSET:
8581                     op = DIGIT;
8582                     break;
8583                 default:
8584                     goto bad_charset;
8585             }
8586             ret = reg_node(pRExC_state, op);
8587             *flagp |= HASWIDTH|SIMPLE;
8588             goto finish_meta_pat;
8589         case 'D':
8590             switch (get_regex_charset(RExC_flags)) {
8591                 case REGEX_LOCALE_CHARSET:
8592                     op = NDIGITL;
8593                     break;
8594                 case REGEX_ASCII_RESTRICTED_CHARSET:
8595                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8596                     op = NDIGITA;
8597                     break;
8598                 case REGEX_DEPENDS_CHARSET: /* No difference between these */
8599                 case REGEX_UNICODE_CHARSET:
8600                     op = NDIGIT;
8601                     break;
8602                 default:
8603                     goto bad_charset;
8604             }
8605             ret = reg_node(pRExC_state, op);
8606             *flagp |= HASWIDTH|SIMPLE;
8607             goto finish_meta_pat;
8608         case 'R':
8609             ret = reg_node(pRExC_state, LNBREAK);
8610             *flagp |= HASWIDTH|SIMPLE;
8611             goto finish_meta_pat;
8612         case 'h':
8613             ret = reg_node(pRExC_state, HORIZWS);
8614             *flagp |= HASWIDTH|SIMPLE;
8615             goto finish_meta_pat;
8616         case 'H':
8617             ret = reg_node(pRExC_state, NHORIZWS);
8618             *flagp |= HASWIDTH|SIMPLE;
8619             goto finish_meta_pat;
8620         case 'v':
8621             ret = reg_node(pRExC_state, VERTWS);
8622             *flagp |= HASWIDTH|SIMPLE;
8623             goto finish_meta_pat;
8624         case 'V':
8625             ret = reg_node(pRExC_state, NVERTWS);
8626             *flagp |= HASWIDTH|SIMPLE;
8627          finish_meta_pat:           
8628             nextchar(pRExC_state);
8629             Set_Node_Length(ret, 2); /* MJD */
8630             break;          
8631         case 'p':
8632         case 'P':
8633             {   
8634                 char* const oldregxend = RExC_end;
8635 #ifdef DEBUGGING
8636                 char* parse_start = RExC_parse - 2;
8637 #endif
8638
8639                 if (RExC_parse[1] == '{') {
8640                   /* a lovely hack--pretend we saw [\pX] instead */
8641                     RExC_end = strchr(RExC_parse, '}');
8642                     if (!RExC_end) {
8643                         const U8 c = (U8)*RExC_parse;
8644                         RExC_parse += 2;
8645                         RExC_end = oldregxend;
8646                         vFAIL2("Missing right brace on \\%c{}", c);
8647                     }
8648                     RExC_end++;
8649                 }
8650                 else {
8651                     RExC_end = RExC_parse + 2;
8652                     if (RExC_end > oldregxend)
8653                         RExC_end = oldregxend;
8654                 }
8655                 RExC_parse--;
8656
8657                 ret = regclass(pRExC_state,depth+1);
8658
8659                 RExC_end = oldregxend;
8660                 RExC_parse--;
8661
8662                 Set_Node_Offset(ret, parse_start + 2);
8663                 Set_Node_Cur_Length(ret);
8664                 nextchar(pRExC_state);
8665                 *flagp |= HASWIDTH|SIMPLE;
8666             }
8667             break;
8668         case 'N': 
8669             /* Handle \N and \N{NAME} here and not below because it can be
8670             multicharacter. join_exact() will join them up later on. 
8671             Also this makes sure that things like /\N{BLAH}+/ and 
8672             \N{BLAH} being multi char Just Happen. dmq*/
8673             ++RExC_parse;
8674             ret= reg_namedseq(pRExC_state, NULL, flagp, depth);
8675             break;
8676         case 'k':    /* Handle \k<NAME> and \k'NAME' */
8677         parse_named_seq:
8678         {   
8679             char ch= RExC_parse[1];         
8680             if (ch != '<' && ch != '\'' && ch != '{') {
8681                 RExC_parse++;
8682                 vFAIL2("Sequence %.2s... not terminated",parse_start);
8683             } else {
8684                 /* this pretty much dupes the code for (?P=...) in reg(), if
8685                    you change this make sure you change that */
8686                 char* name_start = (RExC_parse += 2);
8687                 U32 num = 0;
8688                 SV *sv_dat = reg_scan_name(pRExC_state,
8689                     SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8690                 ch= (ch == '<') ? '>' : (ch == '{') ? '}' : '\'';
8691                 if (RExC_parse == name_start || *RExC_parse != ch)
8692                     vFAIL2("Sequence %.3s... not terminated",parse_start);
8693
8694                 if (!SIZE_ONLY) {
8695                     num = add_data( pRExC_state, 1, "S" );
8696                     RExC_rxi->data->data[num]=(void*)sv_dat;
8697                     SvREFCNT_inc_simple_void(sv_dat);
8698                 }
8699
8700                 RExC_sawback = 1;
8701                 ret = reganode(pRExC_state,
8702                                ((! FOLD)
8703                                  ? NREF
8704                                  : (MORE_ASCII_RESTRICTED)
8705                                    ? NREFFA
8706                                    : (AT_LEAST_UNI_SEMANTICS)
8707                                      ? NREFFU
8708                                      : (LOC)
8709                                        ? NREFFL
8710                                        : NREFF),
8711                                 num);
8712                 *flagp |= HASWIDTH;
8713
8714                 /* override incorrect value set in reganode MJD */
8715                 Set_Node_Offset(ret, parse_start+1);
8716                 Set_Node_Cur_Length(ret); /* MJD */
8717                 nextchar(pRExC_state);
8718
8719             }
8720             break;
8721         }
8722         case 'g': 
8723         case '1': case '2': case '3': case '4':
8724         case '5': case '6': case '7': case '8': case '9':
8725             {
8726                 I32 num;
8727                 bool isg = *RExC_parse == 'g';
8728                 bool isrel = 0; 
8729                 bool hasbrace = 0;
8730                 if (isg) {
8731                     RExC_parse++;
8732                     if (*RExC_parse == '{') {
8733                         RExC_parse++;
8734                         hasbrace = 1;
8735                     }
8736                     if (*RExC_parse == '-') {
8737                         RExC_parse++;
8738                         isrel = 1;
8739                     }
8740                     if (hasbrace && !isDIGIT(*RExC_parse)) {
8741                         if (isrel) RExC_parse--;
8742                         RExC_parse -= 2;                            
8743                         goto parse_named_seq;
8744                 }   }
8745                 num = atoi(RExC_parse);
8746                 if (isg && num == 0)
8747                     vFAIL("Reference to invalid group 0");
8748                 if (isrel) {
8749                     num = RExC_npar - num;
8750                     if (num < 1)
8751                         vFAIL("Reference to nonexistent or unclosed group");
8752                 }
8753                 if (!isg && num > 9 && num >= RExC_npar)
8754                     goto defchar;
8755                 else {
8756                     char * const parse_start = RExC_parse - 1; /* MJD */
8757                     while (isDIGIT(*RExC_parse))
8758                         RExC_parse++;
8759                     if (parse_start == RExC_parse - 1) 
8760                         vFAIL("Unterminated \\g... pattern");
8761                     if (hasbrace) {
8762                         if (*RExC_parse != '}') 
8763                             vFAIL("Unterminated \\g{...} pattern");
8764                         RExC_parse++;
8765                     }    
8766                     if (!SIZE_ONLY) {
8767                         if (num > (I32)RExC_rx->nparens)
8768                             vFAIL("Reference to nonexistent group");
8769                     }
8770                     RExC_sawback = 1;
8771                     ret = reganode(pRExC_state,
8772                                    ((! FOLD)
8773                                      ? REF
8774                                      : (MORE_ASCII_RESTRICTED)
8775                                        ? REFFA
8776                                        : (AT_LEAST_UNI_SEMANTICS)
8777                                          ? REFFU
8778                                          : (LOC)
8779                                            ? REFFL
8780                                            : REFF),
8781                                     num);
8782                     *flagp |= HASWIDTH;
8783
8784                     /* override incorrect value set in reganode MJD */
8785                     Set_Node_Offset(ret, parse_start+1);
8786                     Set_Node_Cur_Length(ret); /* MJD */
8787                     RExC_parse--;
8788                     nextchar(pRExC_state);
8789                 }
8790             }
8791             break;
8792         case '\0':
8793             if (RExC_parse >= RExC_end)
8794                 FAIL("Trailing \\");
8795             /* FALL THROUGH */
8796         default:
8797             /* Do not generate "unrecognized" warnings here, we fall
8798                back into the quick-grab loop below */
8799             parse_start--;
8800             goto defchar;
8801         }
8802         break;
8803
8804     case '#':
8805         if (RExC_flags & RXf_PMf_EXTENDED) {
8806             if ( reg_skipcomment( pRExC_state ) )
8807                 goto tryagain;
8808         }
8809         /* FALL THROUGH */
8810
8811     default:
8812
8813             parse_start = RExC_parse - 1;
8814
8815             RExC_parse++;
8816
8817         defchar: {
8818             typedef enum {
8819                 generic_char = 0,
8820                 char_s,
8821                 upsilon_1,
8822                 upsilon_2,
8823                 iota_1,
8824                 iota_2,
8825             } char_state;
8826             char_state latest_char_state = generic_char;
8827             register STRLEN len;
8828             register UV ender;
8829             register char *p;
8830             char *s;
8831             STRLEN foldlen;
8832             U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
8833             regnode * orig_emit;
8834
8835             ender = 0;
8836             orig_emit = RExC_emit; /* Save the original output node position in
8837                                       case we need to output a different node
8838                                       type */
8839             ret = reg_node(pRExC_state,
8840                            (U8) ((! FOLD) ? EXACT
8841                                           : (LOC)
8842                                              ? EXACTFL
8843                                              : (MORE_ASCII_RESTRICTED)
8844                                                ? EXACTFA
8845                                                : (AT_LEAST_UNI_SEMANTICS)
8846                                                  ? EXACTFU
8847                                                  : EXACTF)
8848                     );
8849             s = STRING(ret);
8850             for (len = 0, p = RExC_parse - 1;
8851               len < 127 && p < RExC_end;
8852               len++)
8853             {
8854                 char * const oldp = p;
8855
8856                 if (RExC_flags & RXf_PMf_EXTENDED)
8857                     p = regwhite( pRExC_state, p );
8858                 switch ((U8)*p) {
8859                 case '^':
8860                 case '$':
8861                 case '.':
8862                 case '[':
8863                 case '(':
8864                 case ')':
8865                 case '|':
8866                     goto loopdone;
8867                 case '\\':
8868                     /* Literal Escapes Switch
8869
8870                        This switch is meant to handle escape sequences that
8871                        resolve to a literal character.
8872
8873                        Every escape sequence that represents something
8874                        else, like an assertion or a char class, is handled
8875                        in the switch marked 'Special Escapes' above in this
8876                        routine, but also has an entry here as anything that
8877                        isn't explicitly mentioned here will be treated as
8878                        an unescaped equivalent literal.
8879                     */
8880
8881                     switch ((U8)*++p) {
8882                     /* These are all the special escapes. */
8883                     case 'A':             /* Start assertion */
8884                     case 'b': case 'B':   /* Word-boundary assertion*/
8885                     case 'C':             /* Single char !DANGEROUS! */
8886                     case 'd': case 'D':   /* digit class */
8887                     case 'g': case 'G':   /* generic-backref, pos assertion */
8888                     case 'h': case 'H':   /* HORIZWS */
8889                     case 'k': case 'K':   /* named backref, keep marker */
8890                     case 'N':             /* named char sequence */
8891                     case 'p': case 'P':   /* Unicode property */
8892                               case 'R':   /* LNBREAK */
8893                     case 's': case 'S':   /* space class */
8894                     case 'v': case 'V':   /* VERTWS */
8895                     case 'w': case 'W':   /* word class */
8896                     case 'X':             /* eXtended Unicode "combining character sequence" */
8897                     case 'z': case 'Z':   /* End of line/string assertion */
8898                         --p;
8899                         goto loopdone;
8900
8901                     /* Anything after here is an escape that resolves to a
8902                        literal. (Except digits, which may or may not)
8903                      */
8904                     case 'n':
8905                         ender = '\n';
8906                         p++;
8907                         break;
8908                     case 'r':
8909                         ender = '\r';
8910                         p++;
8911                         break;
8912                     case 't':
8913                         ender = '\t';
8914                         p++;
8915                         break;
8916                     case 'f':
8917                         ender = '\f';
8918                         p++;
8919                         break;
8920                     case 'e':
8921                           ender = ASCII_TO_NATIVE('\033');
8922                         p++;
8923                         break;
8924                     case 'a':
8925                           ender = ASCII_TO_NATIVE('\007');
8926                         p++;
8927                         break;
8928                     case 'o':
8929                         {
8930                             STRLEN brace_len = len;
8931                             UV result;
8932                             const char* error_msg;
8933
8934                             bool valid = grok_bslash_o(p,
8935                                                        &result,
8936                                                        &brace_len,
8937                                                        &error_msg,
8938                                                        1);
8939                             p += brace_len;
8940                             if (! valid) {
8941                                 RExC_parse = p; /* going to die anyway; point
8942                                                    to exact spot of failure */
8943                                 vFAIL(error_msg);
8944                             }
8945                             else
8946                             {
8947                                 ender = result;
8948                             }
8949                             if (PL_encoding && ender < 0x100) {
8950                                 goto recode_encoding;
8951                             }
8952                             if (ender > 0xff) {
8953                                 REQUIRE_UTF8;
8954                             }
8955                             break;
8956                         }
8957                     case 'x':
8958                         if (*++p == '{') {
8959                             char* const e = strchr(p, '}');
8960         
8961                             if (!e) {
8962                                 RExC_parse = p + 1;
8963                                 vFAIL("Missing right brace on \\x{}");
8964                             }
8965                             else {
8966                                 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
8967                                     | PERL_SCAN_DISALLOW_PREFIX;
8968                                 STRLEN numlen = e - p - 1;
8969                                 ender = grok_hex(p + 1, &numlen, &flags, NULL);
8970                                 if (ender > 0xff)
8971                                     REQUIRE_UTF8;
8972                                 p = e + 1;
8973                             }
8974                         }
8975                         else {
8976                             I32 flags = PERL_SCAN_DISALLOW_PREFIX;
8977                             STRLEN numlen = 2;
8978                             ender = grok_hex(p, &numlen, &flags, NULL);
8979                             p += numlen;
8980                         }
8981                         if (PL_encoding && ender < 0x100)
8982                             goto recode_encoding;
8983                         break;
8984                     case 'c':
8985                         p++;
8986                         ender = grok_bslash_c(*p++, UTF, SIZE_ONLY);
8987                         break;
8988                     case '0': case '1': case '2': case '3':case '4':
8989                     case '5': case '6': case '7': case '8':case '9':
8990                         if (*p == '0' ||
8991                             (isDIGIT(p[1]) && atoi(p) >= RExC_npar))
8992                         {
8993                             I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
8994                             STRLEN numlen = 3;
8995                             ender = grok_oct(p, &numlen, &flags, NULL);
8996                             if (ender > 0xff) {
8997                                 REQUIRE_UTF8;
8998                             }
8999                             p += numlen;
9000                         }
9001                         else {
9002                             --p;
9003                             goto loopdone;
9004                         }
9005                         if (PL_encoding && ender < 0x100)
9006                             goto recode_encoding;
9007                         break;
9008                     recode_encoding:
9009                         if (! RExC_override_recoding) {
9010                             SV* enc = PL_encoding;
9011                             ender = reg_recode((const char)(U8)ender, &enc);
9012                             if (!enc && SIZE_ONLY)
9013                                 ckWARNreg(p, "Invalid escape in the specified encoding");
9014                             REQUIRE_UTF8;
9015                         }
9016                         break;
9017                     case '\0':
9018                         if (p >= RExC_end)
9019                             FAIL("Trailing \\");
9020                         /* FALL THROUGH */
9021                     default:
9022                         if (!SIZE_ONLY&& isALPHA(*p)) {
9023                             /* Include any { following the alpha to emphasize
9024                              * that it could be part of an escape at some point
9025                              * in the future */
9026                             int len = (*(p + 1) == '{') ? 2 : 1;
9027                             ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p);
9028                         }
9029                         goto normal_default;
9030                     }
9031                     break;
9032                 default:
9033                   normal_default:
9034                     if (UTF8_IS_START(*p) && UTF) {
9035                         STRLEN numlen;
9036                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
9037                                                &numlen, UTF8_ALLOW_DEFAULT);
9038                         p += numlen;
9039                     }
9040                     else
9041                         ender = (U8) *p++;
9042                     break;
9043                 } /* End of switch on the literal */
9044
9045                 /* Certain characters are problematic because their folded
9046                  * length is so different from their original length that it
9047                  * isn't handleable by the optimizer.  They are therefore not
9048                  * placed in an EXACTish node; and are here handled specially.
9049                  * (Even if the optimizer handled LATIN_SMALL_LETTER_SHARP_S,
9050                  * putting it in a special node keeps regexec from having to
9051                  * deal with a non-utf8 multi-char fold */
9052                 if (FOLD
9053                     && (ender > 255 || (! MORE_ASCII_RESTRICTED && ! LOC)))
9054                 {
9055                     /* We look for either side of the fold.  For example \xDF
9056                      * folds to 'ss'.  We look for both the single character
9057                      * \xDF and the sequence 'ss'.  When we find something that
9058                      * could be one of those, we stop and flush whatever we
9059                      * have output so far into the EXACTish node that was being
9060                      * built.  Then restore the input pointer to what it was.
9061                      * regatom will return that EXACT node, and will be called
9062                      * again, positioned so the first character is the one in
9063                      * question, which we return in a different node type.
9064                      * The multi-char folds are a sequence, so the occurrence
9065                      * of the first character in that sequence doesn't
9066                      * necessarily mean that what follows is the rest of the
9067                      * sequence.  We keep track of that with a state machine,
9068                      * with the state being set to the latest character
9069                      * processed before the current one.  Most characters will
9070                      * set the state to 0, but if one occurs that is part of a
9071                      * potential tricky fold sequence, the state is set to that
9072                      * character, and the next loop iteration sees if the state
9073                      * should progress towards the final folded-from character,
9074                      * or if it was a false alarm.  If it turns out to be a
9075                      * false alarm, the character(s) will be output in a new
9076                      * EXACTish node, and join_exact() will later combine them.
9077                      * In the case of the 'ss' sequence, which is more common
9078                      * and more easily checked, some look-ahead is done to
9079                      * save time by ruling-out some false alarms */
9080                     switch (ender) {
9081                         default:
9082                             latest_char_state = generic_char;
9083                             break;
9084                         case 's':
9085                         case 'S':
9086                         case 0x17F: /* LATIN SMALL LETTER LONG S */
9087                              if (AT_LEAST_UNI_SEMANTICS) {
9088                                 if (latest_char_state == char_s) {  /* 'ss' */
9089                                     ender = LATIN_SMALL_LETTER_SHARP_S;
9090                                     goto do_tricky;
9091                                 }
9092                                 else if (p < RExC_end) {
9093
9094                                     /* Look-ahead at the next character.  If it
9095                                      * is also an s, we handle as a sharp s
9096                                      * tricky regnode.  */
9097                                     if (*p == 's' || *p == 'S') {
9098
9099                                         /* But first flush anything in the
9100                                          * EXACTish buffer */
9101                                         if (len != 0) {
9102                                             p = oldp;
9103                                             goto loopdone;
9104                                         }
9105                                         p++;    /* Account for swallowing this
9106                                                    's' up */
9107                                         ender = LATIN_SMALL_LETTER_SHARP_S;
9108                                         goto do_tricky;
9109                                     }
9110                                         /* Here, the next character is not a
9111                                          * literal 's', but still could
9112                                          * evaluate to one if part of a \o{},
9113                                          * \x or \OCTAL-DIGIT.  The minimum
9114                                          * length required for that is 4, eg
9115                                          * \x53 or \123 */
9116                                     else if (*p == '\\'
9117                                              && p < RExC_end - 4
9118                                              && (isDIGIT(*(p + 1))
9119                                                  || *(p + 1) == 'x'
9120                                                  || *(p + 1) == 'o' ))
9121                                     {
9122
9123                                         /* Here, it could be an 's', too much
9124                                          * bother to figure it out here.  Flush
9125                                          * the buffer if any; when come back
9126                                          * here, set the state so know that the
9127                                          * previous char was an 's' */
9128                                         if (len != 0) {
9129                                             latest_char_state = generic_char;
9130                                             p = oldp;
9131                                             goto loopdone;
9132                                         }
9133                                         latest_char_state = char_s;
9134                                         break;
9135                                     }
9136                                 }
9137                             }
9138
9139                             /* Here, can't be an 'ss' sequence, or at least not
9140                              * one that could fold to/from the sharp ss */
9141                             latest_char_state = generic_char;
9142                             break;
9143                         case 0x03C5:    /* First char in upsilon series */
9144                         case 0x03A5:    /* Also capital UPSILON, which folds to
9145                                            03C5, and hence exhibits the same
9146                                            problem */
9147                             if (p < RExC_end - 4) { /* Need >= 4 bytes left */
9148                                 latest_char_state = upsilon_1;
9149                                 if (len != 0) {
9150                                     p = oldp;
9151                                     goto loopdone;
9152                                 }
9153                             }
9154                             else {
9155                                 latest_char_state = generic_char;
9156                             }
9157                             break;
9158                         case 0x03B9:    /* First char in iota series */
9159                         case 0x0399:    /* Also capital IOTA */
9160                         case 0x1FBE:    /* GREEK PROSGEGRAMMENI folds to 3B9 */
9161                         case 0x0345:    /* COMBINING GREEK YPOGEGRAMMENI folds
9162                                            to 3B9 */
9163                             if (p < RExC_end - 4) {
9164                                 latest_char_state = iota_1;
9165                                 if (len != 0) {
9166                                     p = oldp;
9167                                     goto loopdone;
9168                                 }
9169                             }
9170                             else {
9171                                 latest_char_state = generic_char;
9172                             }
9173                             break;
9174                         case 0x0308:
9175                             if (latest_char_state == upsilon_1) {
9176                                 latest_char_state = upsilon_2;
9177                             }
9178                             else if (latest_char_state == iota_1) {
9179                                 latest_char_state = iota_2;
9180                             }
9181                             else {
9182                                 latest_char_state = generic_char;
9183                             }
9184                             break;
9185                         case 0x301:
9186                             if (latest_char_state == upsilon_2) {
9187                                 ender = GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS;
9188                                 goto do_tricky;
9189                             }
9190                             else if (latest_char_state == iota_2) {
9191                                 ender = GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS;
9192                                 goto do_tricky;
9193                             }
9194                             latest_char_state = generic_char;
9195                             break;
9196
9197                         /* These are the tricky fold characters.  Flush any
9198                          * buffer first. (When adding to this list, also should
9199                          * add them to fold_grind.t to make sure get tested) */
9200                         case GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS:
9201                         case GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS:
9202                         case LATIN_SMALL_LETTER_SHARP_S:
9203                         case LATIN_CAPITAL_LETTER_SHARP_S:
9204                         case 0x1FD3: /* GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA */
9205                         case 0x1FE3: /* GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA */
9206                             if (len != 0) {
9207                                 p = oldp;
9208                                 goto loopdone;
9209                             }
9210                             /* FALL THROUGH */
9211                         do_tricky: {
9212                             char* const oldregxend = RExC_end;
9213                             U8 tmpbuf[UTF8_MAXBYTES+1];
9214
9215                             /* Here, we know we need to generate a special
9216                              * regnode, and 'ender' contains the tricky
9217                              * character.  What's done is to pretend it's in a
9218                              * [bracketed] class, and let the code that deals
9219                              * with those handle it, as that code has all the
9220                              * intelligence necessary.  First save the current
9221                              * parse state, get rid of the already allocated
9222                              * but empty EXACT node that the ANYOFV node will
9223                              * replace, and point the parse to a buffer which
9224                              * we fill with the character we want the regclass
9225                              * code to think is being parsed */
9226                             RExC_emit = orig_emit;
9227                             RExC_parse = (char *) tmpbuf;
9228                             if (UTF) {
9229                                 U8 *d = uvchr_to_utf8(tmpbuf, ender);
9230                                 *d = '\0';
9231                                 RExC_end = (char *) d;
9232                             }
9233                             else {  /* ender above 255 already excluded */
9234                                 tmpbuf[0] = (U8) ender;
9235                                 tmpbuf[1] = '\0';
9236                                 RExC_end = RExC_parse + 1;
9237                             }
9238
9239                             ret = regclass(pRExC_state,depth+1);
9240
9241                             /* Here, have parsed the buffer.  Reset the parse to
9242                              * the actual input, and return */
9243                             RExC_end = oldregxend;
9244                             RExC_parse = p - 1;
9245
9246                             Set_Node_Offset(ret, RExC_parse);
9247                             Set_Node_Cur_Length(ret);
9248                             nextchar(pRExC_state);
9249                             *flagp |= HASWIDTH|SIMPLE;
9250                             return ret;
9251                         }
9252                     }
9253                 }
9254
9255                 if ( RExC_flags & RXf_PMf_EXTENDED)
9256                     p = regwhite( pRExC_state, p );
9257                 if (UTF && FOLD) {
9258                     /* Prime the casefolded buffer.  Locale rules, which apply
9259                      * only to code points < 256, aren't known until execution,
9260                      * so for them, just output the original character using
9261                      * utf8 */
9262                     if (LOC && ender < 256) {
9263                         if (UNI_IS_INVARIANT(ender)) {
9264                             *tmpbuf = (U8) ender;
9265                             foldlen = 1;
9266                         } else {
9267                             *tmpbuf = UTF8_TWO_BYTE_HI(ender);
9268                             *(tmpbuf + 1) = UTF8_TWO_BYTE_LO(ender);
9269                             foldlen = 2;
9270                         }
9271                     }
9272                     else if (isASCII(ender)) {  /* Note: Here can't also be LOC
9273                                                  */
9274                         ender = toLOWER(ender);
9275                         *tmpbuf = (U8) ender;
9276                         foldlen = 1;
9277                     }
9278                     else if (! MORE_ASCII_RESTRICTED && ! LOC) {
9279
9280                         /* Locale and /aa require more selectivity about the
9281                          * fold, so are handled below.  Otherwise, here, just
9282                          * use the fold */
9283                         ender = toFOLD_uni(ender, tmpbuf, &foldlen);
9284                     }
9285                     else {
9286                         /* Under locale rules or /aa we are not to mix,
9287                          * respectively, ords < 256 or ASCII with non-.  So
9288                          * reject folds that mix them, using only the
9289                          * non-folded code point.  So do the fold to a
9290                          * temporary, and inspect each character in it. */
9291                         U8 trialbuf[UTF8_MAXBYTES_CASE+1];
9292                         U8* s = trialbuf;
9293                         UV tmpender = toFOLD_uni(ender, trialbuf, &foldlen);
9294                         U8* e = s + foldlen;
9295                         bool fold_ok = TRUE;
9296
9297                         while (s < e) {
9298                             if (isASCII(*s)
9299                                 || (LOC && (UTF8_IS_INVARIANT(*s)
9300                                            || UTF8_IS_DOWNGRADEABLE_START(*s))))
9301                             {
9302                                 fold_ok = FALSE;
9303                                 break;
9304                             }
9305                             s += UTF8SKIP(s);
9306                         }
9307                         if (fold_ok) {
9308                             Copy(trialbuf, tmpbuf, foldlen, U8);
9309                             ender = tmpender;
9310                         }
9311                         else {
9312                             uvuni_to_utf8(tmpbuf, ender);
9313                             foldlen = UNISKIP(ender);
9314                         }
9315                     }
9316                 }
9317                 if (p < RExC_end && ISMULT2(p)) { /* Back off on ?+*. */
9318                     if (len)
9319                         p = oldp;
9320                     else if (UTF) {
9321                          if (FOLD) {
9322                               /* Emit all the Unicode characters. */
9323                               STRLEN numlen;
9324                               for (foldbuf = tmpbuf;
9325                                    foldlen;
9326                                    foldlen -= numlen) {
9327                                    ender = utf8_to_uvchr(foldbuf, &numlen);
9328                                    if (numlen > 0) {
9329                                         const STRLEN unilen = reguni(pRExC_state, ender, s);
9330                                         s       += unilen;
9331                                         len     += unilen;
9332                                         /* In EBCDIC the numlen
9333                                          * and unilen can differ. */
9334                                         foldbuf += numlen;
9335                                         if (numlen >= foldlen)
9336                                              break;
9337                                    }
9338                                    else
9339                                         break; /* "Can't happen." */
9340                               }
9341                          }
9342                          else {
9343                               const STRLEN unilen = reguni(pRExC_state, ender, s);
9344                               if (unilen > 0) {
9345                                    s   += unilen;
9346                                    len += unilen;
9347                               }
9348                          }
9349                     }
9350                     else {
9351                         len++;
9352                         REGC((char)ender, s++);
9353                     }
9354                     break;
9355                 }
9356                 if (UTF) {
9357                      if (FOLD) {
9358                           /* Emit all the Unicode characters. */
9359                           STRLEN numlen;
9360                           for (foldbuf = tmpbuf;
9361                                foldlen;
9362                                foldlen -= numlen) {
9363                                ender = utf8_to_uvchr(foldbuf, &numlen);
9364                                if (numlen > 0) {
9365                                     const STRLEN unilen = reguni(pRExC_state, ender, s);
9366                                     len     += unilen;
9367                                     s       += unilen;
9368                                     /* In EBCDIC the numlen
9369                                      * and unilen can differ. */
9370                                     foldbuf += numlen;
9371                                     if (numlen >= foldlen)
9372                                          break;
9373                                }
9374                                else
9375                                     break;
9376                           }
9377                      }
9378                      else {
9379                           const STRLEN unilen = reguni(pRExC_state, ender, s);
9380                           if (unilen > 0) {
9381                                s   += unilen;
9382                                len += unilen;
9383                           }
9384                      }
9385                      len--;
9386                 }
9387                 else {
9388                     REGC((char)ender, s++);
9389                 }
9390             }
9391         loopdone:   /* Jumped to when encounters something that shouldn't be in
9392                        the node */
9393             RExC_parse = p - 1;
9394             Set_Node_Cur_Length(ret); /* MJD */
9395             nextchar(pRExC_state);
9396             {
9397                 /* len is STRLEN which is unsigned, need to copy to signed */
9398                 IV iv = len;
9399                 if (iv < 0)
9400                     vFAIL("Internal disaster");
9401             }
9402             if (len > 0)
9403                 *flagp |= HASWIDTH;
9404             if (len == 1 && UNI_IS_INVARIANT(ender))
9405                 *flagp |= SIMPLE;
9406                 
9407             if (SIZE_ONLY)
9408                 RExC_size += STR_SZ(len);
9409             else {
9410                 STR_LEN(ret) = len;
9411                 RExC_emit += STR_SZ(len);
9412             }
9413         }
9414         break;
9415     }
9416
9417     return(ret);
9418
9419 /* Jumped to when an unrecognized character set is encountered */
9420 bad_charset:
9421     Perl_croak(aTHX_ "panic: Unknown regex character set encoding: %u", get_regex_charset(RExC_flags));
9422     return(NULL);
9423 }
9424
9425 STATIC char *
9426 S_regwhite( RExC_state_t *pRExC_state, char *p )
9427 {
9428     const char *e = RExC_end;
9429
9430     PERL_ARGS_ASSERT_REGWHITE;
9431
9432     while (p < e) {
9433         if (isSPACE(*p))
9434             ++p;
9435         else if (*p == '#') {
9436             bool ended = 0;
9437             do {
9438                 if (*p++ == '\n') {
9439                     ended = 1;
9440                     break;
9441                 }
9442             } while (p < e);
9443             if (!ended)
9444                 RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
9445         }
9446         else
9447             break;
9448     }
9449     return p;
9450 }
9451
9452 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
9453    Character classes ([:foo:]) can also be negated ([:^foo:]).
9454    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
9455    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
9456    but trigger failures because they are currently unimplemented. */
9457
9458 #define POSIXCC_DONE(c)   ((c) == ':')
9459 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
9460 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
9461
9462 STATIC I32
9463 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
9464 {
9465     dVAR;
9466     I32 namedclass = OOB_NAMEDCLASS;
9467
9468     PERL_ARGS_ASSERT_REGPPOSIXCC;
9469
9470     if (value == '[' && RExC_parse + 1 < RExC_end &&
9471         /* I smell either [: or [= or [. -- POSIX has been here, right? */
9472         POSIXCC(UCHARAT(RExC_parse))) {
9473         const char c = UCHARAT(RExC_parse);
9474         char* const s = RExC_parse++;
9475         
9476         while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
9477             RExC_parse++;
9478         if (RExC_parse == RExC_end)
9479             /* Grandfather lone [:, [=, [. */
9480             RExC_parse = s;
9481         else {
9482             const char* const t = RExC_parse++; /* skip over the c */
9483             assert(*t == c);
9484
9485             if (UCHARAT(RExC_parse) == ']') {
9486                 const char *posixcc = s + 1;
9487                 RExC_parse++; /* skip over the ending ] */
9488
9489                 if (*s == ':') {
9490                     const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
9491                     const I32 skip = t - posixcc;
9492
9493                     /* Initially switch on the length of the name.  */
9494                     switch (skip) {
9495                     case 4:
9496                         if (memEQ(posixcc, "word", 4)) /* this is not POSIX, this is the Perl \w */
9497                             namedclass = complement ? ANYOF_NALNUM : ANYOF_ALNUM;
9498                         break;
9499                     case 5:
9500                         /* Names all of length 5.  */
9501                         /* alnum alpha ascii blank cntrl digit graph lower
9502                            print punct space upper  */
9503                         /* Offset 4 gives the best switch position.  */
9504                         switch (posixcc[4]) {
9505                         case 'a':
9506                             if (memEQ(posixcc, "alph", 4)) /* alpha */
9507                                 namedclass = complement ? ANYOF_NALPHA : ANYOF_ALPHA;
9508                             break;
9509                         case 'e':
9510                             if (memEQ(posixcc, "spac", 4)) /* space */
9511                                 namedclass = complement ? ANYOF_NPSXSPC : ANYOF_PSXSPC;
9512                             break;
9513                         case 'h':
9514                             if (memEQ(posixcc, "grap", 4)) /* graph */
9515                                 namedclass = complement ? ANYOF_NGRAPH : ANYOF_GRAPH;
9516                             break;
9517                         case 'i':
9518                             if (memEQ(posixcc, "asci", 4)) /* ascii */
9519                                 namedclass = complement ? ANYOF_NASCII : ANYOF_ASCII;
9520                             break;
9521                         case 'k':
9522                             if (memEQ(posixcc, "blan", 4)) /* blank */
9523                                 namedclass = complement ? ANYOF_NBLANK : ANYOF_BLANK;
9524                             break;
9525                         case 'l':
9526                             if (memEQ(posixcc, "cntr", 4)) /* cntrl */
9527                                 namedclass = complement ? ANYOF_NCNTRL : ANYOF_CNTRL;
9528                             break;
9529                         case 'm':
9530                             if (memEQ(posixcc, "alnu", 4)) /* alnum */
9531                                 namedclass = complement ? ANYOF_NALNUMC : ANYOF_ALNUMC;
9532                             break;
9533                         case 'r':
9534                             if (memEQ(posixcc, "lowe", 4)) /* lower */
9535                                 namedclass = complement ? ANYOF_NLOWER : ANYOF_LOWER;
9536                             else if (memEQ(posixcc, "uppe", 4)) /* upper */
9537                                 namedclass = complement ? ANYOF_NUPPER : ANYOF_UPPER;
9538                             break;
9539                         case 't':
9540                             if (memEQ(posixcc, "digi", 4)) /* digit */
9541                                 namedclass = complement ? ANYOF_NDIGIT : ANYOF_DIGIT;
9542                             else if (memEQ(posixcc, "prin", 4)) /* print */
9543                                 namedclass = complement ? ANYOF_NPRINT : ANYOF_PRINT;
9544                             else if (memEQ(posixcc, "punc", 4)) /* punct */
9545                                 namedclass = complement ? ANYOF_NPUNCT : ANYOF_PUNCT;
9546                             break;
9547                         }
9548                         break;
9549                     case 6:
9550                         if (memEQ(posixcc, "xdigit", 6))
9551                             namedclass = complement ? ANYOF_NXDIGIT : ANYOF_XDIGIT;
9552                         break;
9553                     }
9554
9555                     if (namedclass == OOB_NAMEDCLASS)
9556                         Simple_vFAIL3("POSIX class [:%.*s:] unknown",
9557                                       t - s - 1, s + 1);
9558                     assert (posixcc[skip] == ':');
9559                     assert (posixcc[skip+1] == ']');
9560                 } else if (!SIZE_ONLY) {
9561                     /* [[=foo=]] and [[.foo.]] are still future. */
9562
9563                     /* adjust RExC_parse so the warning shows after
9564                        the class closes */
9565                     while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
9566                         RExC_parse++;
9567                     Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
9568                 }
9569             } else {
9570                 /* Maternal grandfather:
9571                  * "[:" ending in ":" but not in ":]" */
9572                 RExC_parse = s;
9573             }
9574         }
9575     }
9576
9577     return namedclass;
9578 }
9579
9580 STATIC void
9581 S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
9582 {
9583     dVAR;
9584
9585     PERL_ARGS_ASSERT_CHECKPOSIXCC;
9586
9587     if (POSIXCC(UCHARAT(RExC_parse))) {
9588         const char *s = RExC_parse;
9589         const char  c = *s++;
9590
9591         while (isALNUM(*s))
9592             s++;
9593         if (*s && c == *s && s[1] == ']') {
9594             ckWARN3reg(s+2,
9595                        "POSIX syntax [%c %c] belongs inside character classes",
9596                        c, c);
9597
9598             /* [[=foo=]] and [[.foo.]] are still future. */
9599             if (POSIXCC_NOTYET(c)) {
9600                 /* adjust RExC_parse so the error shows after
9601                    the class closes */
9602                 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
9603                     NOOP;
9604                 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
9605             }
9606         }
9607     }
9608 }
9609
9610 /* No locale test, and always Unicode semantics, no ignore-case differences */
9611 #define _C_C_T_NOLOC_(NAME,TEST,WORD)                                          \
9612 ANYOF_##NAME:                                                                  \
9613         for (value = 0; value < 256; value++)                                  \
9614             if (TEST)                                                          \
9615             stored += set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);  \
9616     yesno = '+';                                                               \
9617     what = WORD;                                                               \
9618     break;                                                                     \
9619 case ANYOF_N##NAME:                                                            \
9620         for (value = 0; value < 256; value++)                                  \
9621             if (!TEST)                                                         \
9622             stored += set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);  \
9623     yesno = '!';                                                               \
9624     what = WORD;                                                               \
9625     break
9626
9627 /* Like the above, but there are differences if we are in uni-8-bit or not, so
9628  * there are two tests passed in, to use depending on that. There aren't any
9629  * cases where the label is different from the name, so no need for that
9630  * parameter.
9631  * Sets 'what' to WORD which is the property name for non-bitmap code points;
9632  * But, uses FOLD_WORD instead if /i has been selected, to allow a different
9633  * property name */
9634 #define _C_C_T_(NAME, TEST_8, TEST_7, WORD, FOLD_WORD)                         \
9635 ANYOF_##NAME:                                                                  \
9636     if (LOC) ANYOF_CLASS_SET(ret, ANYOF_##NAME);                               \
9637     else if (UNI_SEMANTICS) {                                                  \
9638         for (value = 0; value < 256; value++) {                                \
9639             if (TEST_8(value)) stored +=                                       \
9640                       set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);  \
9641         }                                                                      \
9642     }                                                                          \
9643     else {                                                                     \
9644         for (value = 0; value < 128; value++) {                                \
9645             if (TEST_7(UNI_TO_NATIVE(value))) stored +=                        \
9646                 set_regclass_bit(pRExC_state, ret,                     \
9647                                    (U8) UNI_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate);                 \
9648         }                                                                      \
9649     }                                                                          \
9650     yesno = '+';                                                               \
9651     if (FOLD) {                                                                \
9652         what = FOLD_WORD;                                                      \
9653     }                                                                          \
9654     else {                                                                     \
9655         what = WORD;                                                           \
9656     }                                                                          \
9657     break;                                                                     \
9658 case ANYOF_N##NAME:                                                            \
9659     if (LOC) ANYOF_CLASS_SET(ret, ANYOF_N##NAME);                              \
9660     else if (UNI_SEMANTICS) {                                                  \
9661         for (value = 0; value < 256; value++) {                                \
9662             if (! TEST_8(value)) stored +=                                     \
9663                     set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);    \
9664         }                                                                      \
9665     }                                                                          \
9666     else {                                                                     \
9667         for (value = 0; value < 128; value++) {                                \
9668             if (! TEST_7(UNI_TO_NATIVE(value))) stored += set_regclass_bit(  \
9669                         pRExC_state, ret, (U8) UNI_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate);    \
9670         }                                                                      \
9671         if (AT_LEAST_ASCII_RESTRICTED) {                                       \
9672             for (value = 128; value < 256; value++) {                          \
9673              stored += set_regclass_bit(                                     \
9674                            pRExC_state, ret, (U8) UNI_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate); \
9675             }                                                                  \
9676             ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;                             \
9677         }                                                                      \
9678         else {                                                                 \
9679             /* For a non-ut8 target string with DEPENDS semantics, all above   \
9680              * ASCII Latin1 code points match the complement of any of the     \
9681              * classes.  But in utf8, they have their Unicode semantics, so    \
9682              * can't just set them in the bitmap, or else regexec.c will think \
9683              * they matched when they shouldn't. */                            \
9684             ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_LATIN1_ALL;                     \
9685         }                                                                      \
9686     }                                                                          \
9687     yesno = '!';                                                               \
9688     if (FOLD) {                                                                \
9689         what = FOLD_WORD;                                                      \
9690     }                                                                          \
9691     else {                                                                     \
9692         what = WORD;                                                           \
9693     }                                                                          \
9694     break
9695
9696 STATIC U8
9697 S_set_regclass_bit_fold(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, SV** invlist_ptr, AV** alternate_ptr)
9698 {
9699
9700     /* Handle the setting of folds in the bitmap for non-locale ANYOF nodes.
9701      * Locale folding is done at run-time, so this function should not be
9702      * called for nodes that are for locales.
9703      *
9704      * This function sets the bit corresponding to the fold of the input
9705      * 'value', if not already set.  The fold of 'f' is 'F', and the fold of
9706      * 'F' is 'f'.
9707      *
9708      * It also knows about the characters that are in the bitmap that have
9709      * folds that are matchable only outside it, and sets the appropriate lists
9710      * and flags.
9711      *
9712      * It returns the number of bits that actually changed from 0 to 1 */
9713
9714     U8 stored = 0;
9715     U8 fold;
9716
9717     PERL_ARGS_ASSERT_SET_REGCLASS_BIT_FOLD;
9718
9719     fold = (AT_LEAST_UNI_SEMANTICS) ? PL_fold_latin1[value]
9720                                     : PL_fold[value];
9721
9722     /* It assumes the bit for 'value' has already been set */
9723     if (fold != value && ! ANYOF_BITMAP_TEST(node, fold)) {
9724         ANYOF_BITMAP_SET(node, fold);
9725         stored++;
9726     }
9727     if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(value) && (! isASCII(value) || ! MORE_ASCII_RESTRICTED)) {
9728         /* Certain Latin1 characters have matches outside the bitmap.  To get
9729          * here, 'value' is one of those characters.   None of these matches is
9730          * valid for ASCII characters under /aa, which have been excluded by
9731          * the 'if' above.  The matches fall into three categories:
9732          * 1) They are singly folded-to or -from an above 255 character, as
9733          *    LATIN SMALL LETTER Y WITH DIAERESIS and LATIN CAPITAL LETTER Y
9734          *    WITH DIAERESIS;
9735          * 2) They are part of a multi-char fold with another character in the
9736          *    bitmap, only LATIN SMALL LETTER SHARP S => "ss" fits that bill;
9737          * 3) They are part of a multi-char fold with a character not in the
9738          *    bitmap, such as various ligatures.
9739          * We aren't dealing fully with multi-char folds, except we do deal
9740          * with the pattern containing a character that has a multi-char fold
9741          * (not so much the inverse).
9742          * For types 1) and 3), the matches only happen when the target string
9743          * is utf8; that's not true for 2), and we set a flag for it.
9744          *
9745          * The code below adds to the passed in inversion list the single fold
9746          * closures for 'value'.  The values are hard-coded here so that an
9747          * innocent-looking character class, like /[ks]/i won't have to go out
9748          * to disk to find the possible matches.  XXX It would be better to
9749          * generate these via regen, in case a new version of the Unicode
9750          * standard adds new mappings, though that is not really likely. */
9751         switch (value) {
9752             case 'k':
9753             case 'K':
9754                 /* KELVIN SIGN */
9755                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x212A);
9756                 break;
9757             case 's':
9758             case 'S':
9759                 /* LATIN SMALL LETTER LONG S */
9760                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x017F);
9761                 break;
9762             case MICRO_SIGN:
9763                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
9764                                                  GREEK_SMALL_LETTER_MU);
9765                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
9766                                                  GREEK_CAPITAL_LETTER_MU);
9767                 break;
9768             case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
9769             case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
9770                 /* ANGSTROM SIGN */
9771                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x212B);
9772                 if (DEPENDS_SEMANTICS) {    /* See DEPENDS comment below */
9773                     *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
9774                                                      PL_fold_latin1[value]);
9775                 }
9776                 break;
9777             case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
9778                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
9779                                         LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
9780                 break;
9781             case LATIN_SMALL_LETTER_SHARP_S:
9782                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
9783                                         LATIN_CAPITAL_LETTER_SHARP_S);
9784
9785                 /* Under /a, /d, and /u, this can match the two chars "ss" */
9786                 if (! MORE_ASCII_RESTRICTED) {
9787                     add_alternate(alternate_ptr, (U8 *) "ss", 2);
9788
9789                     /* And under /u or /a, it can match even if the target is
9790                      * not utf8 */
9791                     if (AT_LEAST_UNI_SEMANTICS) {
9792                         ANYOF_FLAGS(node) |= ANYOF_NONBITMAP_NON_UTF8;
9793                     }
9794                 }
9795                 break;
9796             case 'F': case 'f':
9797             case 'I': case 'i':
9798             case 'L': case 'l':
9799             case 'T': case 't':
9800             case 'A': case 'a':
9801             case 'H': case 'h':
9802             case 'J': case 'j':
9803             case 'N': case 'n':
9804             case 'W': case 'w':
9805             case 'Y': case 'y':
9806                 /* These all are targets of multi-character folds from code
9807                  * points that require UTF8 to express, so they can't match
9808                  * unless the target string is in UTF-8, so no action here is
9809                  * necessary, as regexec.c properly handles the general case
9810                  * for UTF-8 matching */
9811                 break;
9812             default:
9813                 /* Use deprecated warning to increase the chances of this
9814                  * being output */
9815                 ckWARN2regdep(RExC_parse, "Perl folding rules are not up-to-date for 0x%x; please use the perlbug utility to report;", value);
9816                 break;
9817         }
9818     }
9819     else if (DEPENDS_SEMANTICS
9820             && ! isASCII(value)
9821             && PL_fold_latin1[value] != value)
9822     {
9823            /* Under DEPENDS rules, non-ASCII Latin1 characters match their
9824             * folds only when the target string is in UTF-8.  We add the fold
9825             * here to the list of things to match outside the bitmap, which
9826             * won't be looked at unless it is UTF8 (or else if something else
9827             * says to look even if not utf8, but those things better not happen
9828             * under DEPENDS semantics. */
9829         *invlist_ptr = add_cp_to_invlist(*invlist_ptr, PL_fold_latin1[value]);
9830     }
9831
9832     return stored;
9833 }
9834
9835
9836 PERL_STATIC_INLINE U8
9837 S_set_regclass_bit(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, SV** invlist_ptr, AV** alternate_ptr)
9838 {
9839     /* This inline function sets a bit in the bitmap if not already set, and if
9840      * appropriate, its fold, returning the number of bits that actually
9841      * changed from 0 to 1 */
9842
9843     U8 stored;
9844
9845     PERL_ARGS_ASSERT_SET_REGCLASS_BIT;
9846
9847     if (ANYOF_BITMAP_TEST(node, value)) {   /* Already set */
9848         return 0;
9849     }
9850
9851     ANYOF_BITMAP_SET(node, value);
9852     stored = 1;
9853
9854     if (FOLD && ! LOC) {        /* Locale folds aren't known until runtime */
9855         stored += set_regclass_bit_fold(pRExC_state, node, value, invlist_ptr, alternate_ptr);
9856     }
9857
9858     return stored;
9859 }
9860
9861 STATIC void
9862 S_add_alternate(pTHX_ AV** alternate_ptr, U8* string, STRLEN len)
9863 {
9864     /* Adds input 'string' with length 'len' to the ANYOF node's unicode
9865      * alternate list, pointed to by 'alternate_ptr'.  This is an array of
9866      * the multi-character folds of characters in the node */
9867     SV *sv;
9868
9869     PERL_ARGS_ASSERT_ADD_ALTERNATE;
9870
9871     if (! *alternate_ptr) {
9872         *alternate_ptr = newAV();
9873     }
9874     sv = newSVpvn_utf8((char*)string, len, TRUE);
9875     av_push(*alternate_ptr, sv);
9876     return;
9877 }
9878
9879 /*
9880    parse a class specification and produce either an ANYOF node that
9881    matches the pattern or perhaps will be optimized into an EXACTish node
9882    instead. The node contains a bit map for the first 256 characters, with the
9883    corresponding bit set if that character is in the list.  For characters
9884    above 255, a range list is used */
9885
9886 STATIC regnode *
9887 S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth)
9888 {
9889     dVAR;
9890     register UV nextvalue;
9891     register IV prevvalue = OOB_UNICODE;
9892     register IV range = 0;
9893     UV value = 0; /* XXX:dmq: needs to be referenceable (unfortunately) */
9894     register regnode *ret;
9895     STRLEN numlen;
9896     IV namedclass;
9897     char *rangebegin = NULL;
9898     bool need_class = 0;
9899     bool allow_full_fold = TRUE;   /* Assume wants multi-char folding */
9900     SV *listsv = NULL;
9901     STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
9902                                       than just initialized.  */
9903     UV n;
9904
9905     /* code points this node matches that can't be stored in the bitmap */
9906     SV* nonbitmap = NULL;
9907
9908     /* The items that are to match that aren't stored in the bitmap, but are a
9909      * result of things that are stored there.  This is the fold closure of
9910      * such a character, either because it has DEPENDS semantics and shouldn't
9911      * be matched unless the target string is utf8, or is a code point that is
9912      * too large for the bit map, as for example, the fold of the MICRO SIGN is
9913      * above 255.  This all is solely for performance reasons.  By having this
9914      * code know the outside-the-bitmap folds that the bitmapped characters are
9915      * involved with, we don't have to go out to disk to find the list of
9916      * matches, unless the character class includes code points that aren't
9917      * storable in the bit map.  That means that a character class with an 's'
9918      * in it, for example, doesn't need to go out to disk to find everything
9919      * that matches.  A 2nd list is used so that the 'nonbitmap' list is kept
9920      * empty unless there is something whose fold we don't know about, and will
9921      * have to go out to the disk to find. */
9922     SV* l1_fold_invlist = NULL;
9923
9924     /* List of multi-character folds that are matched by this node */
9925     AV* unicode_alternate  = NULL;
9926 #ifdef EBCDIC
9927     UV literal_endpoint = 0;
9928 #endif
9929     UV stored = 0;  /* how many chars stored in the bitmap */
9930
9931     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
9932         case we need to change the emitted regop to an EXACT. */
9933     const char * orig_parse = RExC_parse;
9934     GET_RE_DEBUG_FLAGS_DECL;
9935
9936     PERL_ARGS_ASSERT_REGCLASS;
9937 #ifndef DEBUGGING
9938     PERL_UNUSED_ARG(depth);
9939 #endif
9940
9941     DEBUG_PARSE("clas");
9942
9943     /* Assume we are going to generate an ANYOF node. */
9944     ret = reganode(pRExC_state, ANYOF, 0);
9945
9946
9947     if (!SIZE_ONLY) {
9948         ANYOF_FLAGS(ret) = 0;
9949     }
9950
9951     if (UCHARAT(RExC_parse) == '^') {   /* Complement of range. */
9952         RExC_naughty++;
9953         RExC_parse++;
9954         if (!SIZE_ONLY)
9955             ANYOF_FLAGS(ret) |= ANYOF_INVERT;
9956
9957         /* We have decided to not allow multi-char folds in inverted character
9958          * classes, due to the confusion that can happen, especially with
9959          * classes that are designed for a non-Unicode world:  You have the
9960          * peculiar case that:
9961             "s s" =~ /^[^\xDF]+$/i => Y
9962             "ss"  =~ /^[^\xDF]+$/i => N
9963          *
9964          * See [perl #89750] */
9965         allow_full_fold = FALSE;
9966     }
9967
9968     if (SIZE_ONLY) {
9969         RExC_size += ANYOF_SKIP;
9970         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
9971     }
9972     else {
9973         RExC_emit += ANYOF_SKIP;
9974         if (LOC) {
9975             ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
9976         }
9977         ANYOF_BITMAP_ZERO(ret);
9978         listsv = newSVpvs("# comment\n");
9979         initial_listsv_len = SvCUR(listsv);
9980     }
9981
9982     nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
9983
9984     if (!SIZE_ONLY && POSIXCC(nextvalue))
9985         checkposixcc(pRExC_state);
9986
9987     /* allow 1st char to be ] (allowing it to be - is dealt with later) */
9988     if (UCHARAT(RExC_parse) == ']')
9989         goto charclassloop;
9990
9991 parseit:
9992     while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
9993
9994     charclassloop:
9995
9996         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
9997
9998         if (!range)
9999             rangebegin = RExC_parse;
10000         if (UTF) {
10001             value = utf8n_to_uvchr((U8*)RExC_parse,
10002                                    RExC_end - RExC_parse,
10003                                    &numlen, UTF8_ALLOW_DEFAULT);
10004             RExC_parse += numlen;
10005         }
10006         else
10007             value = UCHARAT(RExC_parse++);
10008
10009         nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
10010         if (value == '[' && POSIXCC(nextvalue))
10011             namedclass = regpposixcc(pRExC_state, value);
10012         else if (value == '\\') {
10013             if (UTF) {
10014                 value = utf8n_to_uvchr((U8*)RExC_parse,
10015                                    RExC_end - RExC_parse,
10016                                    &numlen, UTF8_ALLOW_DEFAULT);
10017                 RExC_parse += numlen;
10018             }
10019             else
10020                 value = UCHARAT(RExC_parse++);
10021             /* Some compilers cannot handle switching on 64-bit integer
10022              * values, therefore value cannot be an UV.  Yes, this will
10023              * be a problem later if we want switch on Unicode.
10024              * A similar issue a little bit later when switching on
10025              * namedclass. --jhi */
10026             switch ((I32)value) {
10027             case 'w':   namedclass = ANYOF_ALNUM;       break;
10028             case 'W':   namedclass = ANYOF_NALNUM;      break;
10029             case 's':   namedclass = ANYOF_SPACE;       break;
10030             case 'S':   namedclass = ANYOF_NSPACE;      break;
10031             case 'd':   namedclass = ANYOF_DIGIT;       break;
10032             case 'D':   namedclass = ANYOF_NDIGIT;      break;
10033             case 'v':   namedclass = ANYOF_VERTWS;      break;
10034             case 'V':   namedclass = ANYOF_NVERTWS;     break;
10035             case 'h':   namedclass = ANYOF_HORIZWS;     break;
10036             case 'H':   namedclass = ANYOF_NHORIZWS;    break;
10037             case 'N':  /* Handle \N{NAME} in class */
10038                 {
10039                     /* We only pay attention to the first char of 
10040                     multichar strings being returned. I kinda wonder
10041                     if this makes sense as it does change the behaviour
10042                     from earlier versions, OTOH that behaviour was broken
10043                     as well. */
10044                     UV v; /* value is register so we cant & it /grrr */
10045                     if (reg_namedseq(pRExC_state, &v, NULL, depth)) {
10046                         goto parseit;
10047                     }
10048                     value= v; 
10049                 }
10050                 break;
10051             case 'p':
10052             case 'P':
10053                 {
10054                 char *e;
10055                 if (RExC_parse >= RExC_end)
10056                     vFAIL2("Empty \\%c{}", (U8)value);
10057                 if (*RExC_parse == '{') {
10058                     const U8 c = (U8)value;
10059                     e = strchr(RExC_parse++, '}');
10060                     if (!e)
10061                         vFAIL2("Missing right brace on \\%c{}", c);
10062                     while (isSPACE(UCHARAT(RExC_parse)))
10063                         RExC_parse++;
10064                     if (e == RExC_parse)
10065                         vFAIL2("Empty \\%c{}", c);
10066                     n = e - RExC_parse;
10067                     while (isSPACE(UCHARAT(RExC_parse + n - 1)))
10068                         n--;
10069                 }
10070                 else {
10071                     e = RExC_parse;
10072                     n = 1;
10073                 }
10074                 if (!SIZE_ONLY) {
10075                     if (UCHARAT(RExC_parse) == '^') {
10076                          RExC_parse++;
10077                          n--;
10078                          value = value == 'p' ? 'P' : 'p'; /* toggle */
10079                          while (isSPACE(UCHARAT(RExC_parse))) {
10080                               RExC_parse++;
10081                               n--;
10082                          }
10083                     }
10084
10085                     /* Add the property name to the list.  If /i matching, give
10086                      * a different name which consists of the normal name
10087                      * sandwiched between two underscores and '_i'.  The design
10088                      * is discussed in the commit message for this. */
10089                     Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s%.*s%s\n",
10090                                         (value=='p' ? '+' : '!'),
10091                                         (FOLD) ? "__" : "",
10092                                         (int)n,
10093                                         RExC_parse,
10094                                         (FOLD) ? "_i" : ""
10095                                     );
10096                 }
10097                 RExC_parse = e + 1;
10098
10099                 /* The \p could match something in the Latin1 range, hence
10100                  * something that isn't utf8 */
10101                 ANYOF_FLAGS(ret) |= ANYOF_NONBITMAP_NON_UTF8;
10102                 namedclass = ANYOF_MAX;  /* no official name, but it's named */
10103
10104                 /* \p means they want Unicode semantics */
10105                 RExC_uni_semantics = 1;
10106                 }
10107                 break;
10108             case 'n':   value = '\n';                   break;
10109             case 'r':   value = '\r';                   break;
10110             case 't':   value = '\t';                   break;
10111             case 'f':   value = '\f';                   break;
10112             case 'b':   value = '\b';                   break;
10113             case 'e':   value = ASCII_TO_NATIVE('\033');break;
10114             case 'a':   value = ASCII_TO_NATIVE('\007');break;
10115             case 'o':
10116                 RExC_parse--;   /* function expects to be pointed at the 'o' */
10117                 {
10118                     const char* error_msg;
10119                     bool valid = grok_bslash_o(RExC_parse,
10120                                                &value,
10121                                                &numlen,
10122                                                &error_msg,
10123                                                SIZE_ONLY);
10124                     RExC_parse += numlen;
10125                     if (! valid) {
10126                         vFAIL(error_msg);
10127                     }
10128                 }
10129                 if (PL_encoding && value < 0x100) {
10130                     goto recode_encoding;
10131                 }
10132                 break;
10133             case 'x':
10134                 if (*RExC_parse == '{') {
10135                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
10136                         | PERL_SCAN_DISALLOW_PREFIX;
10137                     char * const e = strchr(RExC_parse++, '}');
10138                     if (!e)
10139                         vFAIL("Missing right brace on \\x{}");
10140
10141                     numlen = e - RExC_parse;
10142                     value = grok_hex(RExC_parse, &numlen, &flags, NULL);
10143                     RExC_parse = e + 1;
10144                 }
10145                 else {
10146                     I32 flags = PERL_SCAN_DISALLOW_PREFIX;
10147                     numlen = 2;
10148                     value = grok_hex(RExC_parse, &numlen, &flags, NULL);
10149                     RExC_parse += numlen;
10150                 }
10151                 if (PL_encoding && value < 0x100)
10152                     goto recode_encoding;
10153                 break;
10154             case 'c':
10155                 value = grok_bslash_c(*RExC_parse++, UTF, SIZE_ONLY);
10156                 break;
10157             case '0': case '1': case '2': case '3': case '4':
10158             case '5': case '6': case '7':
10159                 {
10160                     /* Take 1-3 octal digits */
10161                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
10162                     numlen = 3;
10163                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
10164                     RExC_parse += numlen;
10165                     if (PL_encoding && value < 0x100)
10166                         goto recode_encoding;
10167                     break;
10168                 }
10169             recode_encoding:
10170                 if (! RExC_override_recoding) {
10171                     SV* enc = PL_encoding;
10172                     value = reg_recode((const char)(U8)value, &enc);
10173                     if (!enc && SIZE_ONLY)
10174                         ckWARNreg(RExC_parse,
10175                                   "Invalid escape in the specified encoding");
10176                     break;
10177                 }
10178             default:
10179                 /* Allow \_ to not give an error */
10180                 if (!SIZE_ONLY && isALNUM(value) && value != '_') {
10181                     ckWARN2reg(RExC_parse,
10182                                "Unrecognized escape \\%c in character class passed through",
10183                                (int)value);
10184                 }
10185                 break;
10186             }
10187         } /* end of \blah */
10188 #ifdef EBCDIC
10189         else
10190             literal_endpoint++;
10191 #endif
10192
10193         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
10194
10195             /* What matches in a locale is not known until runtime, so need to
10196              * (one time per class) allocate extra space to pass to regexec.
10197              * The space will contain a bit for each named class that is to be
10198              * matched against.  This isn't needed for \p{} and pseudo-classes,
10199              * as they are not affected by locale, and hence are dealt with
10200              * separately */
10201             if (LOC && namedclass < ANYOF_MAX && ! need_class) {
10202                 need_class = 1;
10203                 if (SIZE_ONLY) {
10204                     RExC_size += ANYOF_CLASS_SKIP - ANYOF_SKIP;
10205                 }
10206                 else {
10207                     RExC_emit += ANYOF_CLASS_SKIP - ANYOF_SKIP;
10208                     ANYOF_CLASS_ZERO(ret);
10209                 }
10210                 ANYOF_FLAGS(ret) |= ANYOF_CLASS;
10211             }
10212
10213             /* a bad range like a-\d, a-[:digit:].  The '-' is taken as a
10214              * literal, as is the character that began the false range, i.e.
10215              * the 'a' in the examples */
10216             if (range) {
10217                 if (!SIZE_ONLY) {
10218                     const int w =
10219                         RExC_parse >= rangebegin ?
10220                         RExC_parse - rangebegin : 0;
10221                     ckWARN4reg(RExC_parse,
10222                                "False [] range \"%*.*s\"",
10223                                w, w, rangebegin);
10224
10225                     stored +=
10226                          set_regclass_bit(pRExC_state, ret, '-', &l1_fold_invlist, &unicode_alternate);
10227                     if (prevvalue < 256) {
10228                         stored +=
10229                          set_regclass_bit(pRExC_state, ret, (U8) prevvalue, &l1_fold_invlist, &unicode_alternate);
10230                     }
10231                     else {
10232                         nonbitmap = add_cp_to_invlist(nonbitmap, prevvalue);
10233                     }
10234                 }
10235
10236                 range = 0; /* this was not a true range */
10237             }
10238
10239
10240     
10241             if (!SIZE_ONLY) {
10242                 const char *what = NULL;
10243                 char yesno = 0;
10244
10245                 /* Possible truncation here but in some 64-bit environments
10246                  * the compiler gets heartburn about switch on 64-bit values.
10247                  * A similar issue a little earlier when switching on value.
10248                  * --jhi */
10249                 switch ((I32)namedclass) {
10250                 
10251                 case _C_C_T_(ALNUMC, isALNUMC_L1, isALNUMC, "XPosixAlnum", "XPosixAlnum");
10252                 case _C_C_T_(ALPHA, isALPHA_L1, isALPHA, "XPosixAlpha", "XPosixAlpha");
10253                 case _C_C_T_(BLANK, isBLANK_L1, isBLANK, "XPosixBlank", "XPosixBlank");
10254                 case _C_C_T_(CNTRL, isCNTRL_L1, isCNTRL, "XPosixCntrl", "XPosixCntrl");
10255                 case _C_C_T_(GRAPH, isGRAPH_L1, isGRAPH, "XPosixGraph", "XPosixGraph");
10256                 case _C_C_T_(LOWER, isLOWER_L1, isLOWER, "XPosixLower", "__XPosixLower_i");
10257                 case _C_C_T_(PRINT, isPRINT_L1, isPRINT, "XPosixPrint", "XPosixPrint");
10258                 case _C_C_T_(PSXSPC, isPSXSPC_L1, isPSXSPC, "XPosixSpace", "XPosixSpace");
10259                 case _C_C_T_(PUNCT, isPUNCT_L1, isPUNCT, "XPosixPunct", "XPosixPunct");
10260                 case _C_C_T_(UPPER, isUPPER_L1, isUPPER, "XPosixUpper", "__XPosixUpper_i");
10261                 /* \s, \w match all unicode if utf8. */
10262                 case _C_C_T_(SPACE, isSPACE_L1, isSPACE, "SpacePerl", "SpacePerl");
10263                 case _C_C_T_(ALNUM, isWORDCHAR_L1, isALNUM, "Word", "Word");
10264                 case _C_C_T_(XDIGIT, isXDIGIT_L1, isXDIGIT, "XPosixXDigit", "XPosixXDigit");
10265                 case _C_C_T_NOLOC_(VERTWS, is_VERTWS_latin1(&value), "VertSpace");
10266                 case _C_C_T_NOLOC_(HORIZWS, is_HORIZWS_latin1(&value), "HorizSpace");
10267                 case ANYOF_ASCII:
10268                     if (LOC)
10269                         ANYOF_CLASS_SET(ret, ANYOF_ASCII);
10270                     else {
10271                         for (value = 0; value < 128; value++)
10272                             stored +=
10273                               set_regclass_bit(pRExC_state, ret, (U8) ASCII_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate);
10274                     }
10275                     yesno = '+';
10276                     what = NULL;        /* Doesn't match outside ascii, so
10277                                            don't want to add +utf8:: */
10278                     break;
10279                 case ANYOF_NASCII:
10280                     if (LOC)
10281                         ANYOF_CLASS_SET(ret, ANYOF_NASCII);
10282                     else {
10283                         for (value = 128; value < 256; value++)
10284                             stored +=
10285                               set_regclass_bit(pRExC_state, ret, (U8) ASCII_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate);
10286                     }
10287                     ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
10288                     yesno = '!';
10289                     what = "ASCII";
10290                     break;              
10291                 case ANYOF_DIGIT:
10292                     if (LOC)
10293                         ANYOF_CLASS_SET(ret, ANYOF_DIGIT);
10294                     else {
10295                         /* consecutive digits assumed */
10296                         for (value = '0'; value <= '9'; value++)
10297                             stored +=
10298                               set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);
10299                     }
10300                     yesno = '+';
10301                     what = "Digit";
10302                     break;
10303                 case ANYOF_NDIGIT:
10304                     if (LOC)
10305                         ANYOF_CLASS_SET(ret, ANYOF_NDIGIT);
10306                     else {
10307                         /* consecutive digits assumed */
10308                         for (value = 0; value < '0'; value++)
10309                             stored +=
10310                               set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);
10311                         for (value = '9' + 1; value < 256; value++)
10312                             stored +=
10313                               set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);
10314                     }
10315                     yesno = '!';
10316                     what = "Digit";
10317                     if (AT_LEAST_ASCII_RESTRICTED ) {
10318                         ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
10319                     }
10320                     break;              
10321                 case ANYOF_MAX:
10322                     /* this is to handle \p and \P */
10323                     break;
10324                 default:
10325                     vFAIL("Invalid [::] class");
10326                     break;
10327                 }
10328                 if (what && ! (AT_LEAST_ASCII_RESTRICTED)) {
10329                     /* Strings such as "+utf8::isWord\n" */
10330                     Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s\n", yesno, what);
10331                 }
10332
10333                 continue;
10334             }
10335         } /* end of namedclass \blah */
10336
10337         if (range) {
10338             if (prevvalue > (IV)value) /* b-a */ {
10339                 const int w = RExC_parse - rangebegin;
10340                 Simple_vFAIL4("Invalid [] range \"%*.*s\"", w, w, rangebegin);
10341                 range = 0; /* not a valid range */
10342             }
10343         }
10344         else {
10345             prevvalue = value; /* save the beginning of the range */
10346             if (RExC_parse+1 < RExC_end
10347                 && *RExC_parse == '-'
10348                 && RExC_parse[1] != ']')
10349             {
10350                 RExC_parse++;
10351
10352                 /* a bad range like \w-, [:word:]- ? */
10353                 if (namedclass > OOB_NAMEDCLASS) {
10354                     if (ckWARN(WARN_REGEXP)) {
10355                         const int w =
10356                             RExC_parse >= rangebegin ?
10357                             RExC_parse - rangebegin : 0;
10358                         vWARN4(RExC_parse,
10359                                "False [] range \"%*.*s\"",
10360                                w, w, rangebegin);
10361                     }
10362                     if (!SIZE_ONLY)
10363                         stored +=
10364                             set_regclass_bit(pRExC_state, ret, '-', &l1_fold_invlist, &unicode_alternate);
10365                 } else
10366                     range = 1;  /* yeah, it's a range! */
10367                 continue;       /* but do it the next time */
10368             }
10369         }
10370
10371         /* non-Latin1 code point implies unicode semantics.  Must be set in
10372          * pass1 so is there for the whole of pass 2 */
10373         if (value > 255) {
10374             RExC_uni_semantics = 1;
10375         }
10376
10377         /* now is the next time */
10378         if (!SIZE_ONLY) {
10379             if (prevvalue < 256) {
10380                 const IV ceilvalue = value < 256 ? value : 255;
10381                 IV i;
10382 #ifdef EBCDIC
10383                 /* In EBCDIC [\x89-\x91] should include
10384                  * the \x8e but [i-j] should not. */
10385                 if (literal_endpoint == 2 &&
10386                     ((isLOWER(prevvalue) && isLOWER(ceilvalue)) ||
10387                      (isUPPER(prevvalue) && isUPPER(ceilvalue))))
10388                 {
10389                     if (isLOWER(prevvalue)) {
10390                         for (i = prevvalue; i <= ceilvalue; i++)
10391                             if (isLOWER(i) && !ANYOF_BITMAP_TEST(ret,i)) {
10392                                 stored +=
10393                                   set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
10394                             }
10395                     } else {
10396                         for (i = prevvalue; i <= ceilvalue; i++)
10397                             if (isUPPER(i) && !ANYOF_BITMAP_TEST(ret,i)) {
10398                                 stored +=
10399                                   set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
10400                             }
10401                     }
10402                 }
10403                 else
10404 #endif
10405                       for (i = prevvalue; i <= ceilvalue; i++) {
10406                         stored += set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
10407                       }
10408           }
10409           if (value > 255) {
10410             const UV prevnatvalue  = NATIVE_TO_UNI(prevvalue);
10411             const UV natvalue      = NATIVE_TO_UNI(value);
10412             nonbitmap = add_range_to_invlist(nonbitmap, prevnatvalue, natvalue);
10413         }
10414 #ifdef EBCDIC
10415             literal_endpoint = 0;
10416 #endif
10417         }
10418
10419         range = 0; /* this range (if it was one) is done now */
10420     }
10421
10422
10423
10424     if (SIZE_ONLY)
10425         return ret;
10426     /****** !SIZE_ONLY AFTER HERE *********/
10427
10428     /* If folding and there are code points above 255, we calculate all
10429      * characters that could fold to or from the ones already on the list */
10430     if (FOLD && nonbitmap) {
10431         UV start, end;  /* End points of code point ranges */
10432
10433         SV* fold_intersection;
10434
10435         /* This is a list of all the characters that participate in folds
10436             * (except marks, etc in multi-char folds */
10437         if (! PL_utf8_foldable) {
10438             SV* swash = swash_init("utf8", "Cased", &PL_sv_undef, 1, 0);
10439             PL_utf8_foldable = _swash_to_invlist(swash);
10440         }
10441
10442         /* This is a hash that for a particular fold gives all characters
10443             * that are involved in it */
10444         if (! PL_utf8_foldclosures) {
10445
10446             /* If we were unable to find any folds, then we likely won't be
10447              * able to find the closures.  So just create an empty list.
10448              * Folding will effectively be restricted to the non-Unicode rules
10449              * hard-coded into Perl.  (This case happens legitimately during
10450              * compilation of Perl itself before the Unicode tables are
10451              * generated) */
10452             if (invlist_len(PL_utf8_foldable) == 0) {
10453                 PL_utf8_foldclosures = newHV();
10454             } else {
10455                 /* If the folds haven't been read in, call a fold function
10456                     * to force that */
10457                 if (! PL_utf8_tofold) {
10458                     U8 dummy[UTF8_MAXBYTES+1];
10459                     STRLEN dummy_len;
10460
10461                     /* This particular string is above \xff in both UTF-8 and
10462                      * UTFEBCDIC */
10463                     to_utf8_fold((U8*) "\xC8\x80", dummy, &dummy_len);
10464                     assert(PL_utf8_tofold); /* Verify that worked */
10465                 }
10466                 PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
10467             }
10468         }
10469
10470         /* Only the characters in this class that participate in folds need
10471             * be checked.  Get the intersection of this class and all the
10472             * possible characters that are foldable.  This can quickly narrow
10473             * down a large class */
10474         _invlist_intersection(PL_utf8_foldable, nonbitmap, &fold_intersection);
10475
10476         /* Now look at the foldable characters in this class individually */
10477         invlist_iterinit(fold_intersection);
10478         while (invlist_iternext(fold_intersection, &start, &end)) {
10479             UV j;
10480
10481             /* Look at every character in the range */
10482             for (j = start; j <= end; j++) {
10483
10484                 /* Get its fold */
10485                 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
10486                 STRLEN foldlen;
10487                 const UV f =
10488                     _to_uni_fold_flags(j, foldbuf, &foldlen, allow_full_fold);
10489
10490                 if (foldlen > (STRLEN)UNISKIP(f)) {
10491
10492                     /* Any multicharacter foldings (disallowed in
10493                         * lookbehind patterns) require the following
10494                         * transform: [ABCDEF] -> (?:[ABCabcDEFd]|pq|rst) where
10495                         * E folds into "pq" and F folds into "rst", all other
10496                         * characters fold to single characters.  We save away
10497                         * these multicharacter foldings, to be later saved as
10498                         * part of the additional "s" data. */
10499                     if (! RExC_in_lookbehind) {
10500                         U8* loc = foldbuf;
10501                         U8* e = foldbuf + foldlen;
10502
10503                         /* If any of the folded characters of this are in
10504                             * the Latin1 range, tell the regex engine that
10505                             * this can match a non-utf8 target string.  The
10506                             * only multi-byte fold whose source is in the
10507                             * Latin1 range (U+00DF) applies only when the
10508                             * target string is utf8, or under unicode rules */
10509                         if (j > 255 || AT_LEAST_UNI_SEMANTICS) {
10510                             while (loc < e) {
10511
10512                                 /* Can't mix ascii with non- under /aa */
10513                                 if (MORE_ASCII_RESTRICTED
10514                                     && (isASCII(*loc) != isASCII(j)))
10515                                 {
10516                                     goto end_multi_fold;
10517                                 }
10518                                 if (UTF8_IS_INVARIANT(*loc)
10519                                     || UTF8_IS_DOWNGRADEABLE_START(*loc))
10520                                 {
10521                                     /* Can't mix above and below 256 under
10522                                         * LOC */
10523                                     if (LOC) {
10524                                         goto end_multi_fold;
10525                                     }
10526                                     ANYOF_FLAGS(ret)
10527                                             |= ANYOF_NONBITMAP_NON_UTF8;
10528                                     break;
10529                                 }
10530                                 loc += UTF8SKIP(loc);
10531                             }
10532                         }
10533
10534                         add_alternate(&unicode_alternate, foldbuf, foldlen);
10535                     end_multi_fold: ;
10536                     }
10537
10538                     /* This is special-cased, as it is the only letter which
10539                      * has both a multi-fold and single-fold in Latin1.  All
10540                      * the other chars that have single and multi-folds are
10541                      * always in utf8, and the utf8 folding algorithm catches
10542                      * them */
10543                     if (! LOC && j == LATIN_CAPITAL_LETTER_SHARP_S) {
10544                         stored += set_regclass_bit(pRExC_state,
10545                                         ret,
10546                                         LATIN_SMALL_LETTER_SHARP_S,
10547                                         &l1_fold_invlist, &unicode_alternate);
10548                     }
10549                 }
10550                 else {
10551                     /* Single character fold.  Add everything in its fold
10552                         * closure to the list that this node should match */
10553                     SV** listp;
10554
10555                     /* The fold closures data structure is a hash with the
10556                         * keys being every character that is folded to, like
10557                         * 'k', and the values each an array of everything that
10558                         * folds to its key.  e.g. [ 'k', 'K', KELVIN_SIGN ] */
10559                     if ((listp = hv_fetch(PL_utf8_foldclosures,
10560                                     (char *) foldbuf, foldlen, FALSE)))
10561                     {
10562                         AV* list = (AV*) *listp;
10563                         IV k;
10564                         for (k = 0; k <= av_len(list); k++) {
10565                             SV** c_p = av_fetch(list, k, FALSE);
10566                             UV c;
10567                             if (c_p == NULL) {
10568                                 Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
10569                             }
10570                             c = SvUV(*c_p);
10571
10572                             /* /aa doesn't allow folds between ASCII and
10573                                 * non-; /l doesn't allow them between above
10574                                 * and below 256 */
10575                             if ((MORE_ASCII_RESTRICTED
10576                                  && (isASCII(c) != isASCII(j)))
10577                                     || (LOC && ((c < 256) != (j < 256))))
10578                             {
10579                                 continue;
10580                             }
10581
10582                             if (c < 256 && AT_LEAST_UNI_SEMANTICS) {
10583                                 stored += set_regclass_bit(pRExC_state,
10584                                         ret,
10585                                         (U8) c,
10586                                         &l1_fold_invlist, &unicode_alternate);
10587                             }
10588                                 /* It may be that the code point is already
10589                                     * in this range or already in the bitmap,
10590                                     * in which case we need do nothing */
10591                             else if ((c < start || c > end)
10592                                         && (c > 255
10593                                             || ! ANYOF_BITMAP_TEST(ret, c)))
10594                             {
10595                                 nonbitmap = add_cp_to_invlist(nonbitmap, c);
10596                             }
10597                         }
10598                     }
10599                 }
10600             }
10601         }
10602         SvREFCNT_dec(fold_intersection);
10603     }
10604
10605     /* Combine the two lists into one. */
10606     if (l1_fold_invlist) {
10607         if (nonbitmap) {
10608             _invlist_union(nonbitmap, l1_fold_invlist, &nonbitmap);
10609             SvREFCNT_dec(l1_fold_invlist);
10610         }
10611         else {
10612             nonbitmap = l1_fold_invlist;
10613         }
10614     }
10615
10616     /* Here, we have calculated what code points should be in the character
10617      * class.   Now we can see about various optimizations.  Fold calculation
10618      * needs to take place before inversion.  Otherwise /[^k]/i would invert to
10619      * include K, which under /i would match k. */
10620
10621     /* Optimize inverted simple patterns (e.g. [^a-z]).  Note that we haven't
10622      * set the FOLD flag yet, so this this does optimize those.  It doesn't
10623      * optimize locale.  Doing so perhaps could be done as long as there is
10624      * nothing like \w in it; some thought also would have to be given to the
10625      * interaction with above 0x100 chars */
10626     if (! LOC
10627         && (ANYOF_FLAGS(ret) & ANYOF_INVERT)
10628         && ! unicode_alternate
10629         /* In case of /d, there are some things that should match only when in
10630          * not in the bitmap, i.e., they require UTF8 to match.  These are
10631          * listed in nonbitmap. */
10632         && (! nonbitmap
10633             || ! DEPENDS_SEMANTICS
10634             || (ANYOF_FLAGS(ret) & ANYOF_NONBITMAP_NON_UTF8))
10635         && SvCUR(listsv) == initial_listsv_len)
10636     {
10637         if (! nonbitmap) {
10638             for (value = 0; value < ANYOF_BITMAP_SIZE; ++value)
10639                 ANYOF_BITMAP(ret)[value] ^= 0xFF;
10640             /* The inversion means that everything above 255 is matched */
10641             ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
10642         }
10643         else {
10644             /* Here, also has things outside the bitmap.  Go through each bit
10645              * individually and add it to the list to get rid of from those
10646              * things not in the bitmap */
10647             SV *remove_list = _new_invlist(2);
10648             _invlist_invert(nonbitmap);
10649             for (value = 0; value < 256; ++value) {
10650                 if (ANYOF_BITMAP_TEST(ret, value)) {
10651                     ANYOF_BITMAP_CLEAR(ret, value);
10652                     remove_list = add_cp_to_invlist(remove_list, value);
10653                 }
10654                 else {
10655                     ANYOF_BITMAP_SET(ret, value);
10656                 }
10657             }
10658             _invlist_subtract(nonbitmap, remove_list, &nonbitmap);
10659             SvREFCNT_dec(remove_list);
10660         }
10661
10662         stored = 256 - stored;
10663
10664         /* Clear the invert flag since have just done it here */
10665         ANYOF_FLAGS(ret) &= ~ANYOF_INVERT;
10666     }
10667
10668     /* Folding in the bitmap is taken care of above, but not for locale (for
10669      * which we have to wait to see what folding is in effect at runtime), and
10670      * for things not in the bitmap.  Set run-time fold flag for these */
10671     if (FOLD && (LOC || nonbitmap || unicode_alternate)) {
10672         ANYOF_FLAGS(ret) |= ANYOF_LOC_NONBITMAP_FOLD;
10673     }
10674
10675     /* A single character class can be "optimized" into an EXACTish node.
10676      * Note that since we don't currently count how many characters there are
10677      * outside the bitmap, we are XXX missing optimization possibilities for
10678      * them.  This optimization can't happen unless this is a truly single
10679      * character class, which means that it can't be an inversion into a
10680      * many-character class, and there must be no possibility of there being
10681      * things outside the bitmap.  'stored' (only) for locales doesn't include
10682      * \w, etc, so have to make a special test that they aren't present
10683      *
10684      * Similarly A 2-character class of the very special form like [bB] can be
10685      * optimized into an EXACTFish node, but only for non-locales, and for
10686      * characters which only have the two folds; so things like 'fF' and 'Ii'
10687      * wouldn't work because they are part of the fold of 'LATIN SMALL LIGATURE
10688      * FI'. */
10689     if (! nonbitmap
10690         && ! unicode_alternate
10691         && SvCUR(listsv) == initial_listsv_len
10692         && ! (ANYOF_FLAGS(ret) & (ANYOF_INVERT|ANYOF_UNICODE_ALL))
10693         && (((stored == 1 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
10694                               || (! ANYOF_CLASS_TEST_ANY_SET(ret)))))
10695             || (stored == 2 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
10696                                  && (! _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(value))
10697                                  /* If the latest code point has a fold whose
10698                                   * bit is set, it must be the only other one */
10699                                 && ((prevvalue = PL_fold_latin1[value]) != (IV)value)
10700                                  && ANYOF_BITMAP_TEST(ret, prevvalue)))))
10701     {
10702         /* Note that the information needed to decide to do this optimization
10703          * is not currently available until the 2nd pass, and that the actually
10704          * used EXACTish node takes less space than the calculated ANYOF node,
10705          * and hence the amount of space calculated in the first pass is larger
10706          * than actually used, so this optimization doesn't gain us any space.
10707          * But an EXACT node is faster than an ANYOF node, and can be combined
10708          * with any adjacent EXACT nodes later by the optimizer for further
10709          * gains.  The speed of executing an EXACTF is similar to an ANYOF
10710          * node, so the optimization advantage comes from the ability to join
10711          * it to adjacent EXACT nodes */
10712
10713         const char * cur_parse= RExC_parse;
10714         U8 op;
10715         RExC_emit = (regnode *)orig_emit;
10716         RExC_parse = (char *)orig_parse;
10717
10718         if (stored == 1) {
10719
10720             /* A locale node with one point can be folded; all the other cases
10721              * with folding will have two points, since we calculate them above
10722              */
10723             if (ANYOF_FLAGS(ret) & ANYOF_LOC_NONBITMAP_FOLD) {
10724                  op = EXACTFL;
10725             }
10726             else {
10727                 op = EXACT;
10728             }
10729         }
10730         else {   /* else 2 chars in the bit map: the folds of each other */
10731
10732             /* Use the folded value, which for the cases where we get here,
10733              * is just the lower case of the current one (which may resolve to
10734              * itself, or to the other one */
10735             value = toLOWER_LATIN1(value);
10736             if (AT_LEAST_UNI_SEMANTICS || !isASCII(value)) {
10737
10738                 /* To join adjacent nodes, they must be the exact EXACTish
10739                  * type.  Try to use the most likely type, by using EXACTFU if
10740                  * the regex calls for them, or is required because the
10741                  * character is non-ASCII */
10742                 op = EXACTFU;
10743             }
10744             else {    /* Otherwise, more likely to be EXACTF type */
10745                 op = EXACTF;
10746             }
10747         }
10748
10749         ret = reg_node(pRExC_state, op);
10750         RExC_parse = (char *)cur_parse;
10751         if (UTF && ! NATIVE_IS_INVARIANT(value)) {
10752             *STRING(ret)= UTF8_EIGHT_BIT_HI((U8) value);
10753             *(STRING(ret) + 1)= UTF8_EIGHT_BIT_LO((U8) value);
10754             STR_LEN(ret)= 2;
10755             RExC_emit += STR_SZ(2);
10756         }
10757         else {
10758             *STRING(ret)= (char)value;
10759             STR_LEN(ret)= 1;
10760             RExC_emit += STR_SZ(1);
10761         }
10762         SvREFCNT_dec(listsv);
10763         return ret;
10764     }
10765
10766     if (nonbitmap) {
10767         UV start, end;
10768         invlist_iterinit(nonbitmap);
10769         while (invlist_iternext(nonbitmap, &start, &end)) {
10770             if (start == end) {
10771                 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", start);
10772             }
10773             else {
10774                 /* The \t sets the whole range */
10775                 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
10776                         /* XXX EBCDIC */
10777                                    start, end);
10778             }
10779         }
10780         SvREFCNT_dec(nonbitmap);
10781     }
10782
10783     if (SvCUR(listsv) == initial_listsv_len && ! unicode_alternate) {
10784         ARG_SET(ret, ANYOF_NONBITMAP_EMPTY);
10785         SvREFCNT_dec(listsv);
10786         SvREFCNT_dec(unicode_alternate);
10787     }
10788     else {
10789
10790         AV * const av = newAV();
10791         SV *rv;
10792         /* The 0th element stores the character class description
10793          * in its textual form: used later (regexec.c:Perl_regclass_swash())
10794          * to initialize the appropriate swash (which gets stored in
10795          * the 1st element), and also useful for dumping the regnode.
10796          * The 2nd element stores the multicharacter foldings,
10797          * used later (regexec.c:S_reginclass()). */
10798         av_store(av, 0, listsv);
10799         av_store(av, 1, NULL);
10800
10801         /* Store any computed multi-char folds only if we are allowing
10802          * them */
10803         if (allow_full_fold) {
10804             av_store(av, 2, MUTABLE_SV(unicode_alternate));
10805             if (unicode_alternate) { /* This node is variable length */
10806                 OP(ret) = ANYOFV;
10807             }
10808         }
10809         else {
10810             av_store(av, 2, NULL);
10811         }
10812         rv = newRV_noinc(MUTABLE_SV(av));
10813         n = add_data(pRExC_state, 1, "s");
10814         RExC_rxi->data->data[n] = (void*)rv;
10815         ARG_SET(ret, n);
10816     }
10817     return ret;
10818 }
10819 #undef _C_C_T_
10820
10821
10822 /* reg_skipcomment()
10823
10824    Absorbs an /x style # comments from the input stream.
10825    Returns true if there is more text remaining in the stream.
10826    Will set the REG_SEEN_RUN_ON_COMMENT flag if the comment
10827    terminates the pattern without including a newline.
10828
10829    Note its the callers responsibility to ensure that we are
10830    actually in /x mode
10831
10832 */
10833
10834 STATIC bool
10835 S_reg_skipcomment(pTHX_ RExC_state_t *pRExC_state)
10836 {
10837     bool ended = 0;
10838
10839     PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
10840
10841     while (RExC_parse < RExC_end)
10842         if (*RExC_parse++ == '\n') {
10843             ended = 1;
10844             break;
10845         }
10846     if (!ended) {
10847         /* we ran off the end of the pattern without ending
10848            the comment, so we have to add an \n when wrapping */
10849         RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
10850         return 0;
10851     } else
10852         return 1;
10853 }
10854
10855 /* nextchar()
10856
10857    Advances the parse position, and optionally absorbs
10858    "whitespace" from the inputstream.
10859
10860    Without /x "whitespace" means (?#...) style comments only,
10861    with /x this means (?#...) and # comments and whitespace proper.
10862
10863    Returns the RExC_parse point from BEFORE the scan occurs.
10864
10865    This is the /x friendly way of saying RExC_parse++.
10866 */
10867
10868 STATIC char*
10869 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
10870 {
10871     char* const retval = RExC_parse++;
10872
10873     PERL_ARGS_ASSERT_NEXTCHAR;
10874
10875     for (;;) {
10876         if (*RExC_parse == '(' && RExC_parse[1] == '?' &&
10877                 RExC_parse[2] == '#') {
10878             while (*RExC_parse != ')') {
10879                 if (RExC_parse == RExC_end)
10880                     FAIL("Sequence (?#... not terminated");
10881                 RExC_parse++;
10882             }
10883             RExC_parse++;
10884             continue;
10885         }
10886         if (RExC_flags & RXf_PMf_EXTENDED) {
10887             if (isSPACE(*RExC_parse)) {
10888                 RExC_parse++;
10889                 continue;
10890             }
10891             else if (*RExC_parse == '#') {
10892                 if ( reg_skipcomment( pRExC_state ) )
10893                     continue;
10894             }
10895         }
10896         return retval;
10897     }
10898 }
10899
10900 /*
10901 - reg_node - emit a node
10902 */
10903 STATIC regnode *                        /* Location. */
10904 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
10905 {
10906     dVAR;
10907     register regnode *ptr;
10908     regnode * const ret = RExC_emit;
10909     GET_RE_DEBUG_FLAGS_DECL;
10910
10911     PERL_ARGS_ASSERT_REG_NODE;
10912
10913     if (SIZE_ONLY) {
10914         SIZE_ALIGN(RExC_size);
10915         RExC_size += 1;
10916         return(ret);
10917     }
10918     if (RExC_emit >= RExC_emit_bound)
10919         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d", op);
10920
10921     NODE_ALIGN_FILL(ret);
10922     ptr = ret;
10923     FILL_ADVANCE_NODE(ptr, op);
10924     REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, (ptr) - 1);
10925 #ifdef RE_TRACK_PATTERN_OFFSETS
10926     if (RExC_offsets) {         /* MJD */
10927         MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n", 
10928               "reg_node", __LINE__, 
10929               PL_reg_name[op],
10930               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] 
10931                 ? "Overwriting end of array!\n" : "OK",
10932               (UV)(RExC_emit - RExC_emit_start),
10933               (UV)(RExC_parse - RExC_start),
10934               (UV)RExC_offsets[0])); 
10935         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
10936     }
10937 #endif
10938     RExC_emit = ptr;
10939     return(ret);
10940 }
10941
10942 /*
10943 - reganode - emit a node with an argument
10944 */
10945 STATIC regnode *                        /* Location. */
10946 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
10947 {
10948     dVAR;
10949     register regnode *ptr;
10950     regnode * const ret = RExC_emit;
10951     GET_RE_DEBUG_FLAGS_DECL;
10952
10953     PERL_ARGS_ASSERT_REGANODE;
10954
10955     if (SIZE_ONLY) {
10956         SIZE_ALIGN(RExC_size);
10957         RExC_size += 2;
10958         /* 
10959            We can't do this:
10960            
10961            assert(2==regarglen[op]+1); 
10962         
10963            Anything larger than this has to allocate the extra amount.
10964            If we changed this to be:
10965            
10966            RExC_size += (1 + regarglen[op]);
10967            
10968            then it wouldn't matter. Its not clear what side effect
10969            might come from that so its not done so far.
10970            -- dmq
10971         */
10972         return(ret);
10973     }
10974     if (RExC_emit >= RExC_emit_bound)
10975         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d", op);
10976
10977     NODE_ALIGN_FILL(ret);
10978     ptr = ret;
10979     FILL_ADVANCE_NODE_ARG(ptr, op, arg);
10980     REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, (ptr) - 2);
10981 #ifdef RE_TRACK_PATTERN_OFFSETS
10982     if (RExC_offsets) {         /* MJD */
10983         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
10984               "reganode",
10985               __LINE__,
10986               PL_reg_name[op],
10987               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ? 
10988               "Overwriting end of array!\n" : "OK",
10989               (UV)(RExC_emit - RExC_emit_start),
10990               (UV)(RExC_parse - RExC_start),
10991               (UV)RExC_offsets[0])); 
10992         Set_Cur_Node_Offset;
10993     }
10994 #endif            
10995     RExC_emit = ptr;
10996     return(ret);
10997 }
10998
10999 /*
11000 - reguni - emit (if appropriate) a Unicode character
11001 */
11002 STATIC STRLEN
11003 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
11004 {
11005     dVAR;
11006
11007     PERL_ARGS_ASSERT_REGUNI;
11008
11009     return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
11010 }
11011
11012 /*
11013 - reginsert - insert an operator in front of already-emitted operand
11014 *
11015 * Means relocating the operand.
11016 */
11017 STATIC void
11018 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
11019 {
11020     dVAR;
11021     register regnode *src;
11022     register regnode *dst;
11023     register regnode *place;
11024     const int offset = regarglen[(U8)op];
11025     const int size = NODE_STEP_REGNODE + offset;
11026     GET_RE_DEBUG_FLAGS_DECL;
11027
11028     PERL_ARGS_ASSERT_REGINSERT;
11029     PERL_UNUSED_ARG(depth);
11030 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
11031     DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
11032     if (SIZE_ONLY) {
11033         RExC_size += size;
11034         return;
11035     }
11036
11037     src = RExC_emit;
11038     RExC_emit += size;
11039     dst = RExC_emit;
11040     if (RExC_open_parens) {
11041         int paren;
11042         /*DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);*/
11043         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
11044             if ( RExC_open_parens[paren] >= opnd ) {
11045                 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
11046                 RExC_open_parens[paren] += size;
11047             } else {
11048                 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
11049             }
11050             if ( RExC_close_parens[paren] >= opnd ) {
11051                 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
11052                 RExC_close_parens[paren] += size;
11053             } else {
11054                 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
11055             }
11056         }
11057     }
11058
11059     while (src > opnd) {
11060         StructCopy(--src, --dst, regnode);
11061 #ifdef RE_TRACK_PATTERN_OFFSETS
11062         if (RExC_offsets) {     /* MJD 20010112 */
11063             MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
11064                   "reg_insert",
11065                   __LINE__,
11066                   PL_reg_name[op],
11067                   (UV)(dst - RExC_emit_start) > RExC_offsets[0] 
11068                     ? "Overwriting end of array!\n" : "OK",
11069                   (UV)(src - RExC_emit_start),
11070                   (UV)(dst - RExC_emit_start),
11071                   (UV)RExC_offsets[0])); 
11072             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
11073             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
11074         }
11075 #endif
11076     }
11077     
11078
11079     place = opnd;               /* Op node, where operand used to be. */
11080 #ifdef RE_TRACK_PATTERN_OFFSETS
11081     if (RExC_offsets) {         /* MJD */
11082         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
11083               "reginsert",
11084               __LINE__,
11085               PL_reg_name[op],
11086               (UV)(place - RExC_emit_start) > RExC_offsets[0] 
11087               ? "Overwriting end of array!\n" : "OK",
11088               (UV)(place - RExC_emit_start),
11089               (UV)(RExC_parse - RExC_start),
11090               (UV)RExC_offsets[0]));
11091         Set_Node_Offset(place, RExC_parse);
11092         Set_Node_Length(place, 1);
11093     }
11094 #endif    
11095     src = NEXTOPER(place);
11096     FILL_ADVANCE_NODE(place, op);
11097     REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, (place) - 1);
11098     Zero(src, offset, regnode);
11099 }
11100
11101 /*
11102 - regtail - set the next-pointer at the end of a node chain of p to val.
11103 - SEE ALSO: regtail_study
11104 */
11105 /* TODO: All three parms should be const */
11106 STATIC void
11107 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
11108 {
11109     dVAR;
11110     register regnode *scan;
11111     GET_RE_DEBUG_FLAGS_DECL;
11112
11113     PERL_ARGS_ASSERT_REGTAIL;
11114 #ifndef DEBUGGING
11115     PERL_UNUSED_ARG(depth);
11116 #endif
11117
11118     if (SIZE_ONLY)
11119         return;
11120
11121     /* Find last node. */
11122     scan = p;
11123     for (;;) {
11124         regnode * const temp = regnext(scan);
11125         DEBUG_PARSE_r({
11126             SV * const mysv=sv_newmortal();
11127             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
11128             regprop(RExC_rx, mysv, scan);
11129             PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
11130                 SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
11131                     (temp == NULL ? "->" : ""),
11132                     (temp == NULL ? PL_reg_name[OP(val)] : "")
11133             );
11134         });
11135         if (temp == NULL)
11136             break;
11137         scan = temp;
11138     }
11139
11140     if (reg_off_by_arg[OP(scan)]) {
11141         ARG_SET(scan, val - scan);
11142     }
11143     else {
11144         NEXT_OFF(scan) = val - scan;
11145     }
11146 }
11147
11148 #ifdef DEBUGGING
11149 /*
11150 - regtail_study - set the next-pointer at the end of a node chain of p to val.
11151 - Look for optimizable sequences at the same time.
11152 - currently only looks for EXACT chains.
11153
11154 This is experimental code. The idea is to use this routine to perform 
11155 in place optimizations on branches and groups as they are constructed,
11156 with the long term intention of removing optimization from study_chunk so
11157 that it is purely analytical.
11158
11159 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
11160 to control which is which.
11161
11162 */
11163 /* TODO: All four parms should be const */
11164
11165 STATIC U8
11166 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
11167 {
11168     dVAR;
11169     register regnode *scan;
11170     U8 exact = PSEUDO;
11171 #ifdef EXPERIMENTAL_INPLACESCAN
11172     I32 min = 0;
11173 #endif
11174     GET_RE_DEBUG_FLAGS_DECL;
11175
11176     PERL_ARGS_ASSERT_REGTAIL_STUDY;
11177
11178
11179     if (SIZE_ONLY)
11180         return exact;
11181
11182     /* Find last node. */
11183
11184     scan = p;
11185     for (;;) {
11186         regnode * const temp = regnext(scan);
11187 #ifdef EXPERIMENTAL_INPLACESCAN
11188         if (PL_regkind[OP(scan)] == EXACT)
11189             if (join_exact(pRExC_state,scan,&min,1,val,depth+1))
11190                 return EXACT;
11191 #endif
11192         if ( exact ) {
11193             switch (OP(scan)) {
11194                 case EXACT:
11195                 case EXACTF:
11196                 case EXACTFA:
11197                 case EXACTFU:
11198                 case EXACTFL:
11199                         if( exact == PSEUDO )
11200                             exact= OP(scan);
11201                         else if ( exact != OP(scan) )
11202                             exact= 0;
11203                 case NOTHING:
11204                     break;
11205                 default:
11206                     exact= 0;
11207             }
11208         }
11209         DEBUG_PARSE_r({
11210             SV * const mysv=sv_newmortal();
11211             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
11212             regprop(RExC_rx, mysv, scan);
11213             PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
11214                 SvPV_nolen_const(mysv),
11215                 REG_NODE_NUM(scan),
11216                 PL_reg_name[exact]);
11217         });
11218         if (temp == NULL)
11219             break;
11220         scan = temp;
11221     }
11222     DEBUG_PARSE_r({
11223         SV * const mysv_val=sv_newmortal();
11224         DEBUG_PARSE_MSG("");
11225         regprop(RExC_rx, mysv_val, val);
11226         PerlIO_printf(Perl_debug_log, "~ attach to %s (%"IVdf") offset to %"IVdf"\n",
11227                       SvPV_nolen_const(mysv_val),
11228                       (IV)REG_NODE_NUM(val),
11229                       (IV)(val - scan)
11230         );
11231     });
11232     if (reg_off_by_arg[OP(scan)]) {
11233         ARG_SET(scan, val - scan);
11234     }
11235     else {
11236         NEXT_OFF(scan) = val - scan;
11237     }
11238
11239     return exact;
11240 }
11241 #endif
11242
11243 /*
11244  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
11245  */
11246 #ifdef DEBUGGING
11247 static void 
11248 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
11249 {
11250     int bit;
11251     int set=0;
11252     regex_charset cs;
11253
11254     for (bit=0; bit<32; bit++) {
11255         if (flags & (1<<bit)) {
11256             if ((1<<bit) & RXf_PMf_CHARSET) {   /* Output separately, below */
11257                 continue;
11258             }
11259             if (!set++ && lead) 
11260                 PerlIO_printf(Perl_debug_log, "%s",lead);
11261             PerlIO_printf(Perl_debug_log, "%s ",PL_reg_extflags_name[bit]);
11262         }               
11263     }      
11264     if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
11265             if (!set++ && lead) {
11266                 PerlIO_printf(Perl_debug_log, "%s",lead);
11267             }
11268             switch (cs) {
11269                 case REGEX_UNICODE_CHARSET:
11270                     PerlIO_printf(Perl_debug_log, "UNICODE");
11271                     break;
11272                 case REGEX_LOCALE_CHARSET:
11273                     PerlIO_printf(Perl_debug_log, "LOCALE");
11274                     break;
11275                 case REGEX_ASCII_RESTRICTED_CHARSET:
11276                     PerlIO_printf(Perl_debug_log, "ASCII-RESTRICTED");
11277                     break;
11278                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
11279                     PerlIO_printf(Perl_debug_log, "ASCII-MORE_RESTRICTED");
11280                     break;
11281                 default:
11282                     PerlIO_printf(Perl_debug_log, "UNKNOWN CHARACTER SET");
11283                     break;
11284             }
11285     }
11286     if (lead)  {
11287         if (set) 
11288             PerlIO_printf(Perl_debug_log, "\n");
11289         else 
11290             PerlIO_printf(Perl_debug_log, "%s[none-set]\n",lead);
11291     }            
11292 }   
11293 #endif
11294
11295 void
11296 Perl_regdump(pTHX_ const regexp *r)
11297 {
11298 #ifdef DEBUGGING
11299     dVAR;
11300     SV * const sv = sv_newmortal();
11301     SV *dsv= sv_newmortal();
11302     RXi_GET_DECL(r,ri);
11303     GET_RE_DEBUG_FLAGS_DECL;
11304
11305     PERL_ARGS_ASSERT_REGDUMP;
11306
11307     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
11308
11309     /* Header fields of interest. */
11310     if (r->anchored_substr) {
11311         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr), 
11312             RE_SV_DUMPLEN(r->anchored_substr), 30);
11313         PerlIO_printf(Perl_debug_log,
11314                       "anchored %s%s at %"IVdf" ",
11315                       s, RE_SV_TAIL(r->anchored_substr),
11316                       (IV)r->anchored_offset);
11317     } else if (r->anchored_utf8) {
11318         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8), 
11319             RE_SV_DUMPLEN(r->anchored_utf8), 30);
11320         PerlIO_printf(Perl_debug_log,
11321                       "anchored utf8 %s%s at %"IVdf" ",
11322                       s, RE_SV_TAIL(r->anchored_utf8),
11323                       (IV)r->anchored_offset);
11324     }                 
11325     if (r->float_substr) {
11326         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr), 
11327             RE_SV_DUMPLEN(r->float_substr), 30);
11328         PerlIO_printf(Perl_debug_log,
11329                       "floating %s%s at %"IVdf"..%"UVuf" ",
11330                       s, RE_SV_TAIL(r->float_substr),
11331                       (IV)r->float_min_offset, (UV)r->float_max_offset);
11332     } else if (r->float_utf8) {
11333         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8), 
11334             RE_SV_DUMPLEN(r->float_utf8), 30);
11335         PerlIO_printf(Perl_debug_log,
11336                       "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
11337                       s, RE_SV_TAIL(r->float_utf8),
11338                       (IV)r->float_min_offset, (UV)r->float_max_offset);
11339     }
11340     if (r->check_substr || r->check_utf8)
11341         PerlIO_printf(Perl_debug_log,
11342                       (const char *)
11343                       (r->check_substr == r->float_substr
11344                        && r->check_utf8 == r->float_utf8
11345                        ? "(checking floating" : "(checking anchored"));
11346     if (r->extflags & RXf_NOSCAN)
11347         PerlIO_printf(Perl_debug_log, " noscan");
11348     if (r->extflags & RXf_CHECK_ALL)
11349         PerlIO_printf(Perl_debug_log, " isall");
11350     if (r->check_substr || r->check_utf8)
11351         PerlIO_printf(Perl_debug_log, ") ");
11352
11353     if (ri->regstclass) {
11354         regprop(r, sv, ri->regstclass);
11355         PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
11356     }
11357     if (r->extflags & RXf_ANCH) {
11358         PerlIO_printf(Perl_debug_log, "anchored");
11359         if (r->extflags & RXf_ANCH_BOL)
11360             PerlIO_printf(Perl_debug_log, "(BOL)");
11361         if (r->extflags & RXf_ANCH_MBOL)
11362             PerlIO_printf(Perl_debug_log, "(MBOL)");
11363         if (r->extflags & RXf_ANCH_SBOL)
11364             PerlIO_printf(Perl_debug_log, "(SBOL)");
11365         if (r->extflags & RXf_ANCH_GPOS)
11366             PerlIO_printf(Perl_debug_log, "(GPOS)");
11367         PerlIO_putc(Perl_debug_log, ' ');
11368     }
11369     if (r->extflags & RXf_GPOS_SEEN)
11370         PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs);
11371     if (r->intflags & PREGf_SKIP)
11372         PerlIO_printf(Perl_debug_log, "plus ");
11373     if (r->intflags & PREGf_IMPLICIT)
11374         PerlIO_printf(Perl_debug_log, "implicit ");
11375     PerlIO_printf(Perl_debug_log, "minlen %"IVdf" ", (IV)r->minlen);
11376     if (r->extflags & RXf_EVAL_SEEN)
11377         PerlIO_printf(Perl_debug_log, "with eval ");
11378     PerlIO_printf(Perl_debug_log, "\n");
11379     DEBUG_FLAGS_r(regdump_extflags("r->extflags: ",r->extflags));            
11380 #else
11381     PERL_ARGS_ASSERT_REGDUMP;
11382     PERL_UNUSED_CONTEXT;
11383     PERL_UNUSED_ARG(r);
11384 #endif  /* DEBUGGING */
11385 }
11386
11387 /*
11388 - regprop - printable representation of opcode
11389 */
11390 #define EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags) \
11391 STMT_START { \
11392         if (do_sep) {                           \
11393             Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]); \
11394             if (flags & ANYOF_INVERT)           \
11395                 /*make sure the invert info is in each */ \
11396                 sv_catpvs(sv, "^");             \
11397             do_sep = 0;                         \
11398         }                                       \
11399 } STMT_END
11400
11401 void
11402 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
11403 {
11404 #ifdef DEBUGGING
11405     dVAR;
11406     register int k;
11407     RXi_GET_DECL(prog,progi);
11408     GET_RE_DEBUG_FLAGS_DECL;
11409     
11410     PERL_ARGS_ASSERT_REGPROP;
11411
11412     sv_setpvs(sv, "");
11413
11414     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
11415         /* It would be nice to FAIL() here, but this may be called from
11416            regexec.c, and it would be hard to supply pRExC_state. */
11417         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX);
11418     sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
11419
11420     k = PL_regkind[OP(o)];
11421
11422     if (k == EXACT) {
11423         sv_catpvs(sv, " ");
11424         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT) 
11425          * is a crude hack but it may be the best for now since 
11426          * we have no flag "this EXACTish node was UTF-8" 
11427          * --jhi */
11428         pv_pretty(sv, STRING(o), STR_LEN(o), 60, PL_colors[0], PL_colors[1],
11429                   PERL_PV_ESCAPE_UNI_DETECT |
11430                   PERL_PV_ESCAPE_NONASCII   |
11431                   PERL_PV_PRETTY_ELLIPSES   |
11432                   PERL_PV_PRETTY_LTGT       |
11433                   PERL_PV_PRETTY_NOCLEAR
11434                   );
11435     } else if (k == TRIE) {
11436         /* print the details of the trie in dumpuntil instead, as
11437          * progi->data isn't available here */
11438         const char op = OP(o);
11439         const U32 n = ARG(o);
11440         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
11441                (reg_ac_data *)progi->data->data[n] :
11442                NULL;
11443         const reg_trie_data * const trie
11444             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
11445         
11446         Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
11447         DEBUG_TRIE_COMPILE_r(
11448             Perl_sv_catpvf(aTHX_ sv,
11449                 "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
11450                 (UV)trie->startstate,
11451                 (IV)trie->statecount-1, /* -1 because of the unused 0 element */
11452                 (UV)trie->wordcount,
11453                 (UV)trie->minlen,
11454                 (UV)trie->maxlen,
11455                 (UV)TRIE_CHARCOUNT(trie),
11456                 (UV)trie->uniquecharcount
11457             )
11458         );
11459         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
11460             int i;
11461             int rangestart = -1;
11462             U8* bitmap = IS_ANYOF_TRIE(op) ? (U8*)ANYOF_BITMAP(o) : (U8*)TRIE_BITMAP(trie);
11463             sv_catpvs(sv, "[");
11464             for (i = 0; i <= 256; i++) {
11465                 if (i < 256 && BITMAP_TEST(bitmap,i)) {
11466                     if (rangestart == -1)
11467                         rangestart = i;
11468                 } else if (rangestart != -1) {
11469                     if (i <= rangestart + 3)
11470                         for (; rangestart < i; rangestart++)
11471                             put_byte(sv, rangestart);
11472                     else {
11473                         put_byte(sv, rangestart);
11474                         sv_catpvs(sv, "-");
11475                         put_byte(sv, i - 1);
11476                     }
11477                     rangestart = -1;
11478                 }
11479             }
11480             sv_catpvs(sv, "]");
11481         } 
11482          
11483     } else if (k == CURLY) {
11484         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
11485             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
11486         Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
11487     }
11488     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
11489         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
11490     else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) {
11491         Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o));    /* Parenth number */
11492         if ( RXp_PAREN_NAMES(prog) ) {
11493             if ( k != REF || (OP(o) < NREF)) {
11494                 AV *list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
11495                 SV **name= av_fetch(list, ARG(o), 0 );
11496                 if (name)
11497                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
11498             }       
11499             else {
11500                 AV *list= MUTABLE_AV(progi->data->data[ progi->name_list_idx ]);
11501                 SV *sv_dat= MUTABLE_SV(progi->data->data[ ARG( o ) ]);
11502                 I32 *nums=(I32*)SvPVX(sv_dat);
11503                 SV **name= av_fetch(list, nums[0], 0 );
11504                 I32 n;
11505                 if (name) {
11506                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
11507                         Perl_sv_catpvf(aTHX_ sv, "%s%"IVdf,
11508                                     (n ? "," : ""), (IV)nums[n]);
11509                     }
11510                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
11511                 }
11512             }
11513         }            
11514     } else if (k == GOSUB) 
11515         Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */
11516     else if (k == VERB) {
11517         if (!o->flags) 
11518             Perl_sv_catpvf(aTHX_ sv, ":%"SVf, 
11519                            SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
11520     } else if (k == LOGICAL)
11521         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);     /* 2: embedded, otherwise 1 */
11522     else if (k == FOLDCHAR)
11523         Perl_sv_catpvf(aTHX_ sv, "[0x%"UVXf"]", PTR2UV(ARG(o)) );
11524     else if (k == ANYOF) {
11525         int i, rangestart = -1;
11526         const U8 flags = ANYOF_FLAGS(o);
11527         int do_sep = 0;
11528
11529         /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
11530         static const char * const anyofs[] = {
11531             "\\w",
11532             "\\W",
11533             "\\s",
11534             "\\S",
11535             "\\d",
11536             "\\D",
11537             "[:alnum:]",
11538             "[:^alnum:]",
11539             "[:alpha:]",
11540             "[:^alpha:]",
11541             "[:ascii:]",
11542             "[:^ascii:]",
11543             "[:cntrl:]",
11544             "[:^cntrl:]",
11545             "[:graph:]",
11546             "[:^graph:]",
11547             "[:lower:]",
11548             "[:^lower:]",
11549             "[:print:]",
11550             "[:^print:]",
11551             "[:punct:]",
11552             "[:^punct:]",
11553             "[:upper:]",
11554             "[:^upper:]",
11555             "[:xdigit:]",
11556             "[:^xdigit:]",
11557             "[:space:]",
11558             "[:^space:]",
11559             "[:blank:]",
11560             "[:^blank:]"
11561         };
11562
11563         if (flags & ANYOF_LOCALE)
11564             sv_catpvs(sv, "{loc}");
11565         if (flags & ANYOF_LOC_NONBITMAP_FOLD)
11566             sv_catpvs(sv, "{i}");
11567         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
11568         if (flags & ANYOF_INVERT)
11569             sv_catpvs(sv, "^");
11570         
11571         /* output what the standard cp 0-255 bitmap matches */
11572         for (i = 0; i <= 256; i++) {
11573             if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
11574                 if (rangestart == -1)
11575                     rangestart = i;
11576             } else if (rangestart != -1) {
11577                 if (i <= rangestart + 3)
11578                     for (; rangestart < i; rangestart++)
11579                         put_byte(sv, rangestart);
11580                 else {
11581                     put_byte(sv, rangestart);
11582                     sv_catpvs(sv, "-");
11583                     put_byte(sv, i - 1);
11584                 }
11585                 do_sep = 1;
11586                 rangestart = -1;
11587             }
11588         }
11589         
11590         EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
11591         /* output any special charclass tests (used entirely under use locale) */
11592         if (ANYOF_CLASS_TEST_ANY_SET(o))
11593             for (i = 0; i < (int)(sizeof(anyofs)/sizeof(char*)); i++)
11594                 if (ANYOF_CLASS_TEST(o,i)) {
11595                     sv_catpv(sv, anyofs[i]);
11596                     do_sep = 1;
11597                 }
11598         
11599         EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
11600         
11601         if (flags & ANYOF_NON_UTF8_LATIN1_ALL) {
11602             sv_catpvs(sv, "{non-utf8-latin1-all}");
11603         }
11604
11605         /* output information about the unicode matching */
11606         if (flags & ANYOF_UNICODE_ALL)
11607             sv_catpvs(sv, "{unicode_all}");
11608         else if (ANYOF_NONBITMAP(o))
11609             sv_catpvs(sv, "{unicode}");
11610         if (flags & ANYOF_NONBITMAP_NON_UTF8)
11611             sv_catpvs(sv, "{outside bitmap}");
11612
11613         if (ANYOF_NONBITMAP(o)) {
11614             SV *lv;
11615             SV * const sw = regclass_swash(prog, o, FALSE, &lv, 0);
11616         
11617             if (lv) {
11618                 if (sw) {
11619                     U8 s[UTF8_MAXBYTES_CASE+1];
11620
11621                     for (i = 0; i <= 256; i++) { /* just the first 256 */
11622                         uvchr_to_utf8(s, i);
11623                         
11624                         if (i < 256 && swash_fetch(sw, s, TRUE)) {
11625                             if (rangestart == -1)
11626                                 rangestart = i;
11627                         } else if (rangestart != -1) {
11628                             if (i <= rangestart + 3)
11629                                 for (; rangestart < i; rangestart++) {
11630                                     const U8 * const e = uvchr_to_utf8(s,rangestart);
11631                                     U8 *p;
11632                                     for(p = s; p < e; p++)
11633                                         put_byte(sv, *p);
11634                                 }
11635                             else {
11636                                 const U8 *e = uvchr_to_utf8(s,rangestart);
11637                                 U8 *p;
11638                                 for (p = s; p < e; p++)
11639                                     put_byte(sv, *p);
11640                                 sv_catpvs(sv, "-");
11641                                 e = uvchr_to_utf8(s, i-1);
11642                                 for (p = s; p < e; p++)
11643                                     put_byte(sv, *p);
11644                                 }
11645                                 rangestart = -1;
11646                             }
11647                         }
11648                         
11649                     sv_catpvs(sv, "..."); /* et cetera */
11650                 }
11651
11652                 {
11653                     char *s = savesvpv(lv);
11654                     char * const origs = s;
11655                 
11656                     while (*s && *s != '\n')
11657                         s++;
11658                 
11659                     if (*s == '\n') {
11660                         const char * const t = ++s;
11661                         
11662                         while (*s) {
11663                             if (*s == '\n')
11664                                 *s = ' ';
11665                             s++;
11666                         }
11667                         if (s[-1] == ' ')
11668                             s[-1] = 0;
11669                         
11670                         sv_catpv(sv, t);
11671                     }
11672                 
11673                     Safefree(origs);
11674                 }
11675             }
11676         }
11677
11678         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
11679     }
11680     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
11681         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
11682 #else
11683     PERL_UNUSED_CONTEXT;
11684     PERL_UNUSED_ARG(sv);
11685     PERL_UNUSED_ARG(o);
11686     PERL_UNUSED_ARG(prog);
11687 #endif  /* DEBUGGING */
11688 }
11689
11690 SV *
11691 Perl_re_intuit_string(pTHX_ REGEXP * const r)
11692 {                               /* Assume that RE_INTUIT is set */
11693     dVAR;
11694     struct regexp *const prog = (struct regexp *)SvANY(r);
11695     GET_RE_DEBUG_FLAGS_DECL;
11696
11697     PERL_ARGS_ASSERT_RE_INTUIT_STRING;
11698     PERL_UNUSED_CONTEXT;
11699
11700     DEBUG_COMPILE_r(
11701         {
11702             const char * const s = SvPV_nolen_const(prog->check_substr
11703                       ? prog->check_substr : prog->check_utf8);
11704
11705             if (!PL_colorset) reginitcolors();
11706             PerlIO_printf(Perl_debug_log,
11707                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
11708                       PL_colors[4],
11709                       prog->check_substr ? "" : "utf8 ",
11710                       PL_colors[5],PL_colors[0],
11711                       s,
11712                       PL_colors[1],
11713                       (strlen(s) > 60 ? "..." : ""));
11714         } );
11715
11716     return prog->check_substr ? prog->check_substr : prog->check_utf8;
11717 }
11718
11719 /* 
11720    pregfree() 
11721    
11722    handles refcounting and freeing the perl core regexp structure. When 
11723    it is necessary to actually free the structure the first thing it 
11724    does is call the 'free' method of the regexp_engine associated to
11725    the regexp, allowing the handling of the void *pprivate; member 
11726    first. (This routine is not overridable by extensions, which is why 
11727    the extensions free is called first.)
11728    
11729    See regdupe and regdupe_internal if you change anything here. 
11730 */
11731 #ifndef PERL_IN_XSUB_RE
11732 void
11733 Perl_pregfree(pTHX_ REGEXP *r)
11734 {
11735     SvREFCNT_dec(r);
11736 }
11737
11738 void
11739 Perl_pregfree2(pTHX_ REGEXP *rx)
11740 {
11741     dVAR;
11742     struct regexp *const r = (struct regexp *)SvANY(rx);
11743     GET_RE_DEBUG_FLAGS_DECL;
11744
11745     PERL_ARGS_ASSERT_PREGFREE2;
11746
11747     if (r->mother_re) {
11748         ReREFCNT_dec(r->mother_re);
11749     } else {
11750         CALLREGFREE_PVT(rx); /* free the private data */
11751         SvREFCNT_dec(RXp_PAREN_NAMES(r));
11752     }        
11753     if (r->substrs) {
11754         SvREFCNT_dec(r->anchored_substr);
11755         SvREFCNT_dec(r->anchored_utf8);
11756         SvREFCNT_dec(r->float_substr);
11757         SvREFCNT_dec(r->float_utf8);
11758         Safefree(r->substrs);
11759     }
11760     RX_MATCH_COPY_FREE(rx);
11761 #ifdef PERL_OLD_COPY_ON_WRITE
11762     SvREFCNT_dec(r->saved_copy);
11763 #endif
11764     Safefree(r->offs);
11765 }
11766
11767 /*  reg_temp_copy()
11768     
11769     This is a hacky workaround to the structural issue of match results
11770     being stored in the regexp structure which is in turn stored in
11771     PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
11772     could be PL_curpm in multiple contexts, and could require multiple
11773     result sets being associated with the pattern simultaneously, such
11774     as when doing a recursive match with (??{$qr})
11775     
11776     The solution is to make a lightweight copy of the regexp structure 
11777     when a qr// is returned from the code executed by (??{$qr}) this
11778     lightweight copy doesn't actually own any of its data except for
11779     the starp/end and the actual regexp structure itself. 
11780     
11781 */    
11782     
11783     
11784 REGEXP *
11785 Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
11786 {
11787     struct regexp *ret;
11788     struct regexp *const r = (struct regexp *)SvANY(rx);
11789     register const I32 npar = r->nparens+1;
11790
11791     PERL_ARGS_ASSERT_REG_TEMP_COPY;
11792
11793     if (!ret_x)
11794         ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
11795     ret = (struct regexp *)SvANY(ret_x);
11796     
11797     (void)ReREFCNT_inc(rx);
11798     /* We can take advantage of the existing "copied buffer" mechanism in SVs
11799        by pointing directly at the buffer, but flagging that the allocated
11800        space in the copy is zero. As we've just done a struct copy, it's now
11801        a case of zero-ing that, rather than copying the current length.  */
11802     SvPV_set(ret_x, RX_WRAPPED(rx));
11803     SvFLAGS(ret_x) |= SvFLAGS(rx) & (SVf_POK|SVp_POK|SVf_UTF8);
11804     memcpy(&(ret->xpv_cur), &(r->xpv_cur),
11805            sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
11806     SvLEN_set(ret_x, 0);
11807     SvSTASH_set(ret_x, NULL);
11808     SvMAGIC_set(ret_x, NULL);
11809     Newx(ret->offs, npar, regexp_paren_pair);
11810     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
11811     if (r->substrs) {
11812         Newx(ret->substrs, 1, struct reg_substr_data);
11813         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
11814
11815         SvREFCNT_inc_void(ret->anchored_substr);
11816         SvREFCNT_inc_void(ret->anchored_utf8);
11817         SvREFCNT_inc_void(ret->float_substr);
11818         SvREFCNT_inc_void(ret->float_utf8);
11819
11820         /* check_substr and check_utf8, if non-NULL, point to either their
11821            anchored or float namesakes, and don't hold a second reference.  */
11822     }
11823     RX_MATCH_COPIED_off(ret_x);
11824 #ifdef PERL_OLD_COPY_ON_WRITE
11825     ret->saved_copy = NULL;
11826 #endif
11827     ret->mother_re = rx;
11828     
11829     return ret_x;
11830 }
11831 #endif
11832
11833 /* regfree_internal() 
11834
11835    Free the private data in a regexp. This is overloadable by 
11836    extensions. Perl takes care of the regexp structure in pregfree(), 
11837    this covers the *pprivate pointer which technically perl doesn't 
11838    know about, however of course we have to handle the 
11839    regexp_internal structure when no extension is in use. 
11840    
11841    Note this is called before freeing anything in the regexp 
11842    structure. 
11843  */
11844  
11845 void
11846 Perl_regfree_internal(pTHX_ REGEXP * const rx)
11847 {
11848     dVAR;
11849     struct regexp *const r = (struct regexp *)SvANY(rx);
11850     RXi_GET_DECL(r,ri);
11851     GET_RE_DEBUG_FLAGS_DECL;
11852
11853     PERL_ARGS_ASSERT_REGFREE_INTERNAL;
11854
11855     DEBUG_COMPILE_r({
11856         if (!PL_colorset)
11857             reginitcolors();
11858         {
11859             SV *dsv= sv_newmortal();
11860             RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
11861                 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60);
11862             PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n", 
11863                 PL_colors[4],PL_colors[5],s);
11864         }
11865     });
11866 #ifdef RE_TRACK_PATTERN_OFFSETS
11867     if (ri->u.offsets)
11868         Safefree(ri->u.offsets);             /* 20010421 MJD */
11869 #endif
11870     if (ri->data) {
11871         int n = ri->data->count;
11872         PAD* new_comppad = NULL;
11873         PAD* old_comppad;
11874         PADOFFSET refcnt;
11875
11876         while (--n >= 0) {
11877           /* If you add a ->what type here, update the comment in regcomp.h */
11878             switch (ri->data->what[n]) {
11879             case 'a':
11880             case 's':
11881             case 'S':
11882             case 'u':
11883                 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
11884                 break;
11885             case 'f':
11886                 Safefree(ri->data->data[n]);
11887                 break;
11888             case 'p':
11889                 new_comppad = MUTABLE_AV(ri->data->data[n]);
11890                 break;
11891             case 'o':
11892                 if (new_comppad == NULL)
11893                     Perl_croak(aTHX_ "panic: pregfree comppad");
11894                 PAD_SAVE_LOCAL(old_comppad,
11895                     /* Watch out for global destruction's random ordering. */
11896                     (SvTYPE(new_comppad) == SVt_PVAV) ? new_comppad : NULL
11897                 );
11898                 OP_REFCNT_LOCK;
11899                 refcnt = OpREFCNT_dec((OP_4tree*)ri->data->data[n]);
11900                 OP_REFCNT_UNLOCK;
11901                 if (!refcnt)
11902                     op_free((OP_4tree*)ri->data->data[n]);
11903
11904                 PAD_RESTORE_LOCAL(old_comppad);
11905                 SvREFCNT_dec(MUTABLE_SV(new_comppad));
11906                 new_comppad = NULL;
11907                 break;
11908             case 'n':
11909                 break;
11910             case 'T':           
11911                 { /* Aho Corasick add-on structure for a trie node.
11912                      Used in stclass optimization only */
11913                     U32 refcount;
11914                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
11915                     OP_REFCNT_LOCK;
11916                     refcount = --aho->refcount;
11917                     OP_REFCNT_UNLOCK;
11918                     if ( !refcount ) {
11919                         PerlMemShared_free(aho->states);
11920                         PerlMemShared_free(aho->fail);
11921                          /* do this last!!!! */
11922                         PerlMemShared_free(ri->data->data[n]);
11923                         PerlMemShared_free(ri->regstclass);
11924                     }
11925                 }
11926                 break;
11927             case 't':
11928                 {
11929                     /* trie structure. */
11930                     U32 refcount;
11931                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
11932                     OP_REFCNT_LOCK;
11933                     refcount = --trie->refcount;
11934                     OP_REFCNT_UNLOCK;
11935                     if ( !refcount ) {
11936                         PerlMemShared_free(trie->charmap);
11937                         PerlMemShared_free(trie->states);
11938                         PerlMemShared_free(trie->trans);
11939                         if (trie->bitmap)
11940                             PerlMemShared_free(trie->bitmap);
11941                         if (trie->jump)
11942                             PerlMemShared_free(trie->jump);
11943                         PerlMemShared_free(trie->wordinfo);
11944                         /* do this last!!!! */
11945                         PerlMemShared_free(ri->data->data[n]);
11946                     }
11947                 }
11948                 break;
11949             default:
11950                 Perl_croak(aTHX_ "panic: regfree data code '%c'", ri->data->what[n]);
11951             }
11952         }
11953         Safefree(ri->data->what);
11954         Safefree(ri->data);
11955     }
11956
11957     Safefree(ri);
11958 }
11959
11960 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
11961 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
11962 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
11963
11964 /* 
11965    re_dup - duplicate a regexp. 
11966    
11967    This routine is expected to clone a given regexp structure. It is only
11968    compiled under USE_ITHREADS.
11969
11970    After all of the core data stored in struct regexp is duplicated
11971    the regexp_engine.dupe method is used to copy any private data
11972    stored in the *pprivate pointer. This allows extensions to handle
11973    any duplication it needs to do.
11974
11975    See pregfree() and regfree_internal() if you change anything here. 
11976 */
11977 #if defined(USE_ITHREADS)
11978 #ifndef PERL_IN_XSUB_RE
11979 void
11980 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
11981 {
11982     dVAR;
11983     I32 npar;
11984     const struct regexp *r = (const struct regexp *)SvANY(sstr);
11985     struct regexp *ret = (struct regexp *)SvANY(dstr);
11986     
11987     PERL_ARGS_ASSERT_RE_DUP_GUTS;
11988
11989     npar = r->nparens+1;
11990     Newx(ret->offs, npar, regexp_paren_pair);
11991     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
11992     if(ret->swap) {
11993         /* no need to copy these */
11994         Newx(ret->swap, npar, regexp_paren_pair);
11995     }
11996
11997     if (ret->substrs) {
11998         /* Do it this way to avoid reading from *r after the StructCopy().
11999            That way, if any of the sv_dup_inc()s dislodge *r from the L1
12000            cache, it doesn't matter.  */
12001         const bool anchored = r->check_substr
12002             ? r->check_substr == r->anchored_substr
12003             : r->check_utf8 == r->anchored_utf8;
12004         Newx(ret->substrs, 1, struct reg_substr_data);
12005         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
12006
12007         ret->anchored_substr = sv_dup_inc(ret->anchored_substr, param);
12008         ret->anchored_utf8 = sv_dup_inc(ret->anchored_utf8, param);
12009         ret->float_substr = sv_dup_inc(ret->float_substr, param);
12010         ret->float_utf8 = sv_dup_inc(ret->float_utf8, param);
12011
12012         /* check_substr and check_utf8, if non-NULL, point to either their
12013            anchored or float namesakes, and don't hold a second reference.  */
12014
12015         if (ret->check_substr) {
12016             if (anchored) {
12017                 assert(r->check_utf8 == r->anchored_utf8);
12018                 ret->check_substr = ret->anchored_substr;
12019                 ret->check_utf8 = ret->anchored_utf8;
12020             } else {
12021                 assert(r->check_substr == r->float_substr);
12022                 assert(r->check_utf8 == r->float_utf8);
12023                 ret->check_substr = ret->float_substr;
12024                 ret->check_utf8 = ret->float_utf8;
12025             }
12026         } else if (ret->check_utf8) {
12027             if (anchored) {
12028                 ret->check_utf8 = ret->anchored_utf8;
12029             } else {
12030                 ret->check_utf8 = ret->float_utf8;
12031             }
12032         }
12033     }
12034
12035     RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
12036
12037     if (ret->pprivate)
12038         RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
12039
12040     if (RX_MATCH_COPIED(dstr))
12041         ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
12042     else
12043         ret->subbeg = NULL;
12044 #ifdef PERL_OLD_COPY_ON_WRITE
12045     ret->saved_copy = NULL;
12046 #endif
12047
12048     if (ret->mother_re) {
12049         if (SvPVX_const(dstr) == SvPVX_const(ret->mother_re)) {
12050             /* Our storage points directly to our mother regexp, but that's
12051                1: a buffer in a different thread
12052                2: something we no longer hold a reference on
12053                so we need to copy it locally.  */
12054             /* Note we need to use SvCUR(), rather than
12055                SvLEN(), on our mother_re, because it, in
12056                turn, may well be pointing to its own mother_re.  */
12057             SvPV_set(dstr, SAVEPVN(SvPVX_const(ret->mother_re),
12058                                    SvCUR(ret->mother_re)+1));
12059             SvLEN_set(dstr, SvCUR(ret->mother_re)+1);
12060         }
12061         ret->mother_re      = NULL;
12062     }
12063     ret->gofs = 0;
12064 }
12065 #endif /* PERL_IN_XSUB_RE */
12066
12067 /*
12068    regdupe_internal()
12069    
12070    This is the internal complement to regdupe() which is used to copy
12071    the structure pointed to by the *pprivate pointer in the regexp.
12072    This is the core version of the extension overridable cloning hook.
12073    The regexp structure being duplicated will be copied by perl prior
12074    to this and will be provided as the regexp *r argument, however 
12075    with the /old/ structures pprivate pointer value. Thus this routine
12076    may override any copying normally done by perl.
12077    
12078    It returns a pointer to the new regexp_internal structure.
12079 */
12080
12081 void *
12082 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
12083 {
12084     dVAR;
12085     struct regexp *const r = (struct regexp *)SvANY(rx);
12086     regexp_internal *reti;
12087     int len;
12088     RXi_GET_DECL(r,ri);
12089
12090     PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
12091     
12092     len = ProgLen(ri);
12093     
12094     Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode), char, regexp_internal);
12095     Copy(ri->program, reti->program, len+1, regnode);
12096     
12097
12098     reti->regstclass = NULL;
12099
12100     if (ri->data) {
12101         struct reg_data *d;
12102         const int count = ri->data->count;
12103         int i;
12104
12105         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
12106                 char, struct reg_data);
12107         Newx(d->what, count, U8);
12108
12109         d->count = count;
12110         for (i = 0; i < count; i++) {
12111             d->what[i] = ri->data->what[i];
12112             switch (d->what[i]) {
12113                 /* legal options are one of: sSfpontTua
12114                    see also regcomp.h and pregfree() */
12115             case 'a': /* actually an AV, but the dup function is identical.  */
12116             case 's':
12117             case 'S':
12118             case 'p': /* actually an AV, but the dup function is identical.  */
12119             case 'u': /* actually an HV, but the dup function is identical.  */
12120                 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
12121                 break;
12122             case 'f':
12123                 /* This is cheating. */
12124                 Newx(d->data[i], 1, struct regnode_charclass_class);
12125                 StructCopy(ri->data->data[i], d->data[i],
12126                             struct regnode_charclass_class);
12127                 reti->regstclass = (regnode*)d->data[i];
12128                 break;
12129             case 'o':
12130                 /* Compiled op trees are readonly and in shared memory,
12131                    and can thus be shared without duplication. */
12132                 OP_REFCNT_LOCK;
12133                 d->data[i] = (void*)OpREFCNT_inc((OP*)ri->data->data[i]);
12134                 OP_REFCNT_UNLOCK;
12135                 break;
12136             case 'T':
12137                 /* Trie stclasses are readonly and can thus be shared
12138                  * without duplication. We free the stclass in pregfree
12139                  * when the corresponding reg_ac_data struct is freed.
12140                  */
12141                 reti->regstclass= ri->regstclass;
12142                 /* Fall through */
12143             case 't':
12144                 OP_REFCNT_LOCK;
12145                 ((reg_trie_data*)ri->data->data[i])->refcount++;
12146                 OP_REFCNT_UNLOCK;
12147                 /* Fall through */
12148             case 'n':
12149                 d->data[i] = ri->data->data[i];
12150                 break;
12151             default:
12152                 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", ri->data->what[i]);
12153             }
12154         }
12155
12156         reti->data = d;
12157     }
12158     else
12159         reti->data = NULL;
12160
12161     reti->name_list_idx = ri->name_list_idx;
12162
12163 #ifdef RE_TRACK_PATTERN_OFFSETS
12164     if (ri->u.offsets) {
12165         Newx(reti->u.offsets, 2*len+1, U32);
12166         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
12167     }
12168 #else
12169     SetProgLen(reti,len);
12170 #endif
12171
12172     return (void*)reti;
12173 }
12174
12175 #endif    /* USE_ITHREADS */
12176
12177 #ifndef PERL_IN_XSUB_RE
12178
12179 /*
12180  - regnext - dig the "next" pointer out of a node
12181  */
12182 regnode *
12183 Perl_regnext(pTHX_ register regnode *p)
12184 {
12185     dVAR;
12186     register I32 offset;
12187
12188     if (!p)
12189         return(NULL);
12190
12191     if (OP(p) > REGNODE_MAX) {          /* regnode.type is unsigned */
12192         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(p), (int)REGNODE_MAX);
12193     }
12194
12195     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
12196     if (offset == 0)
12197         return(NULL);
12198
12199     return(p+offset);
12200 }
12201 #endif
12202
12203 STATIC void     
12204 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
12205 {
12206     va_list args;
12207     STRLEN l1 = strlen(pat1);
12208     STRLEN l2 = strlen(pat2);
12209     char buf[512];
12210     SV *msv;
12211     const char *message;
12212
12213     PERL_ARGS_ASSERT_RE_CROAK2;
12214
12215     if (l1 > 510)
12216         l1 = 510;
12217     if (l1 + l2 > 510)
12218         l2 = 510 - l1;
12219     Copy(pat1, buf, l1 , char);
12220     Copy(pat2, buf + l1, l2 , char);
12221     buf[l1 + l2] = '\n';
12222     buf[l1 + l2 + 1] = '\0';
12223 #ifdef I_STDARG
12224     /* ANSI variant takes additional second argument */
12225     va_start(args, pat2);
12226 #else
12227     va_start(args);
12228 #endif
12229     msv = vmess(buf, &args);
12230     va_end(args);
12231     message = SvPV_const(msv,l1);
12232     if (l1 > 512)
12233         l1 = 512;
12234     Copy(message, buf, l1 , char);
12235     buf[l1-1] = '\0';                   /* Overwrite \n */
12236     Perl_croak(aTHX_ "%s", buf);
12237 }
12238
12239 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
12240
12241 #ifndef PERL_IN_XSUB_RE
12242 void
12243 Perl_save_re_context(pTHX)
12244 {
12245     dVAR;
12246
12247     struct re_save_state *state;
12248
12249     SAVEVPTR(PL_curcop);
12250     SSGROW(SAVESTACK_ALLOC_FOR_RE_SAVE_STATE + 1);
12251
12252     state = (struct re_save_state *)(PL_savestack + PL_savestack_ix);
12253     PL_savestack_ix += SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
12254     SSPUSHUV(SAVEt_RE_STATE);
12255
12256     Copy(&PL_reg_state, state, 1, struct re_save_state);
12257
12258     PL_reg_start_tmp = 0;
12259     PL_reg_start_tmpl = 0;
12260     PL_reg_oldsaved = NULL;
12261     PL_reg_oldsavedlen = 0;
12262     PL_reg_maxiter = 0;
12263     PL_reg_leftiter = 0;
12264     PL_reg_poscache = NULL;
12265     PL_reg_poscache_size = 0;
12266 #ifdef PERL_OLD_COPY_ON_WRITE
12267     PL_nrs = NULL;
12268 #endif
12269
12270     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
12271     if (PL_curpm) {
12272         const REGEXP * const rx = PM_GETRE(PL_curpm);
12273         if (rx) {
12274             U32 i;
12275             for (i = 1; i <= RX_NPARENS(rx); i++) {
12276                 char digits[TYPE_CHARS(long)];
12277                 const STRLEN len = my_snprintf(digits, sizeof(digits), "%lu", (long)i);
12278                 GV *const *const gvp
12279                     = (GV**)hv_fetch(PL_defstash, digits, len, 0);
12280
12281                 if (gvp) {
12282                     GV * const gv = *gvp;
12283                     if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
12284                         save_scalar(gv);
12285                 }
12286             }
12287         }
12288     }
12289 }
12290 #endif
12291
12292 static void
12293 clear_re(pTHX_ void *r)
12294 {
12295     dVAR;
12296     ReREFCNT_dec((REGEXP *)r);
12297 }
12298
12299 #ifdef DEBUGGING
12300
12301 STATIC void
12302 S_put_byte(pTHX_ SV *sv, int c)
12303 {
12304     PERL_ARGS_ASSERT_PUT_BYTE;
12305
12306     /* Our definition of isPRINT() ignores locales, so only bytes that are
12307        not part of UTF-8 are considered printable. I assume that the same
12308        holds for UTF-EBCDIC.
12309        Also, code point 255 is not printable in either (it's E0 in EBCDIC,
12310        which Wikipedia says:
12311
12312        EO, or Eight Ones, is an 8-bit EBCDIC character code represented as all
12313        ones (binary 1111 1111, hexadecimal FF). It is similar, but not
12314        identical, to the ASCII delete (DEL) or rubout control character.
12315        ) So the old condition can be simplified to !isPRINT(c)  */
12316     if (!isPRINT(c)) {
12317         if (c < 256) {
12318             Perl_sv_catpvf(aTHX_ sv, "\\x%02x", c);
12319         }
12320         else {
12321             Perl_sv_catpvf(aTHX_ sv, "\\x{%x}", c);
12322         }
12323     }
12324     else {
12325         const char string = c;
12326         if (c == '-' || c == ']' || c == '\\' || c == '^')
12327             sv_catpvs(sv, "\\");
12328         sv_catpvn(sv, &string, 1);
12329     }
12330 }
12331
12332
12333 #define CLEAR_OPTSTART \
12334     if (optstart) STMT_START { \
12335             DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%"IVdf" nodes)\n", (IV)(node - optstart))); \
12336             optstart=NULL; \
12337     } STMT_END
12338
12339 #define DUMPUNTIL(b,e) CLEAR_OPTSTART; node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
12340
12341 STATIC const regnode *
12342 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
12343             const regnode *last, const regnode *plast, 
12344             SV* sv, I32 indent, U32 depth)
12345 {
12346     dVAR;
12347     register U8 op = PSEUDO;    /* Arbitrary non-END op. */
12348     register const regnode *next;
12349     const regnode *optstart= NULL;
12350     
12351     RXi_GET_DECL(r,ri);
12352     GET_RE_DEBUG_FLAGS_DECL;
12353
12354     PERL_ARGS_ASSERT_DUMPUNTIL;
12355
12356 #ifdef DEBUG_DUMPUNTIL
12357     PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
12358         last ? last-start : 0,plast ? plast-start : 0);
12359 #endif
12360             
12361     if (plast && plast < last) 
12362         last= plast;
12363
12364     while (PL_regkind[op] != END && (!last || node < last)) {
12365         /* While that wasn't END last time... */
12366         NODE_ALIGN(node);
12367         op = OP(node);
12368         if (op == CLOSE || op == WHILEM)
12369             indent--;
12370         next = regnext((regnode *)node);
12371
12372         /* Where, what. */
12373         if (OP(node) == OPTIMIZED) {
12374             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
12375                 optstart = node;
12376             else
12377                 goto after_print;
12378         } else
12379             CLEAR_OPTSTART;
12380         
12381         regprop(r, sv, node);
12382         PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
12383                       (int)(2*indent + 1), "", SvPVX_const(sv));
12384         
12385         if (OP(node) != OPTIMIZED) {                  
12386             if (next == NULL)           /* Next ptr. */
12387                 PerlIO_printf(Perl_debug_log, " (0)");
12388             else if (PL_regkind[(U8)op] == BRANCH && PL_regkind[OP(next)] != BRANCH )
12389                 PerlIO_printf(Perl_debug_log, " (FAIL)");
12390             else 
12391                 PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start));
12392             (void)PerlIO_putc(Perl_debug_log, '\n'); 
12393         }
12394         
12395       after_print:
12396         if (PL_regkind[(U8)op] == BRANCHJ) {
12397             assert(next);
12398             {
12399                 register const regnode *nnode = (OP(next) == LONGJMP
12400                                              ? regnext((regnode *)next)
12401                                              : next);
12402                 if (last && nnode > last)
12403                     nnode = last;
12404                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
12405             }
12406         }
12407         else if (PL_regkind[(U8)op] == BRANCH) {
12408             assert(next);
12409             DUMPUNTIL(NEXTOPER(node), next);
12410         }
12411         else if ( PL_regkind[(U8)op]  == TRIE ) {
12412             const regnode *this_trie = node;
12413             const char op = OP(node);
12414             const U32 n = ARG(node);
12415             const reg_ac_data * const ac = op>=AHOCORASICK ?
12416                (reg_ac_data *)ri->data->data[n] :
12417                NULL;
12418             const reg_trie_data * const trie =
12419                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
12420 #ifdef DEBUGGING
12421             AV *const trie_words = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
12422 #endif
12423             const regnode *nextbranch= NULL;
12424             I32 word_idx;
12425             sv_setpvs(sv, "");
12426             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
12427                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
12428                 
12429                 PerlIO_printf(Perl_debug_log, "%*s%s ",
12430                    (int)(2*(indent+3)), "",
12431                     elem_ptr ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60,
12432                             PL_colors[0], PL_colors[1],
12433                             (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) |
12434                             PERL_PV_PRETTY_ELLIPSES    |
12435                             PERL_PV_PRETTY_LTGT
12436                             )
12437                             : "???"
12438                 );
12439                 if (trie->jump) {
12440                     U16 dist= trie->jump[word_idx+1];
12441                     PerlIO_printf(Perl_debug_log, "(%"UVuf")\n",
12442                                   (UV)((dist ? this_trie + dist : next) - start));
12443                     if (dist) {
12444                         if (!nextbranch)
12445                             nextbranch= this_trie + trie->jump[0];    
12446                         DUMPUNTIL(this_trie + dist, nextbranch);
12447                     }
12448                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
12449                         nextbranch= regnext((regnode *)nextbranch);
12450                 } else {
12451                     PerlIO_printf(Perl_debug_log, "\n");
12452                 }
12453             }
12454             if (last && next > last)
12455                 node= last;
12456             else
12457                 node= next;
12458         }
12459         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
12460             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
12461                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
12462         }
12463         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
12464             assert(next);
12465             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
12466         }
12467         else if ( op == PLUS || op == STAR) {
12468             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
12469         }
12470         else if (PL_regkind[(U8)op] == ANYOF) {
12471             /* arglen 1 + class block */
12472             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_CLASS)
12473                     ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
12474             node = NEXTOPER(node);
12475         }
12476         else if (PL_regkind[(U8)op] == EXACT) {
12477             /* Literal string, where present. */
12478             node += NODE_SZ_STR(node) - 1;
12479             node = NEXTOPER(node);
12480         }
12481         else {
12482             node = NEXTOPER(node);
12483             node += regarglen[(U8)op];
12484         }
12485         if (op == CURLYX || op == OPEN)
12486             indent++;
12487     }
12488     CLEAR_OPTSTART;
12489 #ifdef DEBUG_DUMPUNTIL    
12490     PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent);
12491 #endif
12492     return node;
12493 }
12494
12495 #endif  /* DEBUGGING */
12496
12497 /*
12498  * Local variables:
12499  * c-indentation-style: bsd
12500  * c-basic-offset: 4
12501  * indent-tabs-mode: t
12502  * End:
12503  *
12504  * ex: set ts=8 sts=4 sw=4 noet:
12505  */