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