]> git.vpit.fr Git - perl/modules/re-engine-Hooks.git/blob - src/5014001/regcomp.c
c8e79b704cc3542066d60f91a8e062646d23a6f2
[perl/modules/re-engine-Hooks.git] / src / 5014001 / regcomp.c
1 /*    regcomp.c
2  */
3
4 /*
5  * 'A fair jaw-cracker dwarf-language must be.'            --Samwise Gamgee
6  *
7  *     [p.285 of _The Lord of the Rings_, II/iii: "The Ring Goes South"]
8  */
9
10 /* This file contains functions for compiling a regular expression.  See
11  * also regexec.c which funnily enough, contains functions for executing
12  * a regular expression.
13  *
14  * This file is also copied at build time to ext/re/re_comp.c, where
15  * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
16  * This causes the main functions to be compiled under new names and with
17  * debugging support added, which makes "use re 'debug'" work.
18  */
19
20 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
21  * confused with the original package (see point 3 below).  Thanks, Henry!
22  */
23
24 /* Additional note: this code is very heavily munged from Henry's version
25  * in places.  In some spots I've traded clarity for efficiency, so don't
26  * blame Henry for some of the lack of readability.
27  */
28
29 /* The names of the functions have been changed from regcomp and
30  * regexec to pregcomp and pregexec in order to avoid conflicts
31  * with the POSIX routines of the same names.
32 */
33
34 #ifdef PERL_EXT_RE_BUILD
35 #include "re_top.h"
36 #endif
37
38 /*
39  * pregcomp and pregexec -- regsub and regerror are not used in perl
40  *
41  *      Copyright (c) 1986 by University of Toronto.
42  *      Written by Henry Spencer.  Not derived from licensed software.
43  *
44  *      Permission is granted to anyone to use this software for any
45  *      purpose on any computer system, and to redistribute it freely,
46  *      subject to the following restrictions:
47  *
48  *      1. The author is not responsible for the consequences of use of
49  *              this software, no matter how awful, even if they arise
50  *              from defects in it.
51  *
52  *      2. The origin of this software must not be misrepresented, either
53  *              by explicit claim or by omission.
54  *
55  *      3. Altered versions must be plainly marked as such, and must not
56  *              be misrepresented as being the original software.
57  *
58  *
59  ****    Alterations to Henry's code are...
60  ****
61  ****    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
62  ****    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
63  ****    by Larry Wall and others
64  ****
65  ****    You may distribute under the terms of either the GNU General Public
66  ****    License or the Artistic License, as specified in the README file.
67
68  *
69  * Beware that some of this code is subtly aware of the way operator
70  * precedence is structured in regular expressions.  Serious changes in
71  * regular-expression syntax might require a total rethink.
72  */
73 #include "EXTERN.h"
74 #define PERL_IN_REGCOMP_C
75 #include "perl.h"
76
77 #ifndef PERL_IN_XSUB_RE
78 #include "re_defs.h"
79 #endif
80
81 #define REG_COMP_C
82 #ifdef PERL_IN_XSUB_RE
83 #  include "re_comp.h"
84 #else
85 #  include "regcomp.h"
86 #endif
87
88 #include "dquote_static.c"
89
90 #ifdef op
91 #undef op
92 #endif /* op */
93
94 #ifdef MSDOS
95 #  if defined(BUGGY_MSC6)
96  /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
97 #    pragma optimize("a",off)
98  /* But MSC 6.00A is happy with 'w', for aliases only across function calls*/
99 #    pragma optimize("w",on )
100 #  endif /* BUGGY_MSC6 */
101 #endif /* MSDOS */
102
103 #ifndef STATIC
104 #define STATIC  static
105 #endif
106
107 typedef struct RExC_state_t {
108     U32         flags;                  /* are we folding, multilining? */
109     char        *precomp;               /* uncompiled string. */
110     REGEXP      *rx_sv;                 /* The SV that is the regexp. */
111     regexp      *rx;                    /* perl core regexp structure */
112     regexp_internal     *rxi;           /* internal data for regexp object pprivate field */        
113     char        *start;                 /* Start of input for compile */
114     char        *end;                   /* End of input for compile */
115     char        *parse;                 /* Input-scan pointer. */
116     I32         whilem_seen;            /* number of WHILEM in this expr */
117     regnode     *emit_start;            /* Start of emitted-code area */
118     regnode     *emit_bound;            /* First regnode outside of the allocated space */
119     regnode     *emit;                  /* Code-emit pointer; &regdummy = don't = compiling */
120     I32         naughty;                /* How bad is this pattern? */
121     I32         sawback;                /* Did we see \1, ...? */
122     U32         seen;
123     I32         size;                   /* Code size. */
124     I32         npar;                   /* Capture buffer count, (OPEN). */
125     I32         cpar;                   /* Capture buffer count, (CLOSE). */
126     I32         nestroot;               /* root parens we are in - used by accept */
127     I32         extralen;
128     I32         seen_zerolen;
129     I32         seen_evals;
130     regnode     **open_parens;          /* pointers to open parens */
131     regnode     **close_parens;         /* pointers to close parens */
132     regnode     *opend;                 /* END node in program */
133     I32         utf8;           /* whether the pattern is utf8 or not */
134     I32         orig_utf8;      /* whether the pattern was originally in utf8 */
135                                 /* XXX use this for future optimisation of case
136                                  * where pattern must be upgraded to utf8. */
137     I32         uni_semantics;  /* If a d charset modifier should use unicode
138                                    rules, even if the pattern is not in
139                                    utf8 */
140     HV          *paren_names;           /* Paren names */
141     
142     regnode     **recurse;              /* Recurse regops */
143     I32         recurse_count;          /* Number of recurse regops */
144     I32         in_lookbehind;
145     I32         contains_locale;
146     I32         override_recoding;
147 #if ADD_TO_REGEXEC
148     char        *starttry;              /* -Dr: where regtry was called. */
149 #define RExC_starttry   (pRExC_state->starttry)
150 #endif
151 #ifdef DEBUGGING
152     const char  *lastparse;
153     I32         lastnum;
154     AV          *paren_name_list;       /* idx -> name */
155 #define RExC_lastparse  (pRExC_state->lastparse)
156 #define RExC_lastnum    (pRExC_state->lastnum)
157 #define RExC_paren_name_list    (pRExC_state->paren_name_list)
158 #endif
159 } RExC_state_t;
160
161 #define RExC_flags      (pRExC_state->flags)
162 #define RExC_precomp    (pRExC_state->precomp)
163 #define RExC_rx_sv      (pRExC_state->rx_sv)
164 #define RExC_rx         (pRExC_state->rx)
165 #define RExC_rxi        (pRExC_state->rxi)
166 #define RExC_start      (pRExC_state->start)
167 #define RExC_end        (pRExC_state->end)
168 #define RExC_parse      (pRExC_state->parse)
169 #define RExC_whilem_seen        (pRExC_state->whilem_seen)
170 #ifdef RE_TRACK_PATTERN_OFFSETS
171 #define RExC_offsets    (pRExC_state->rxi->u.offsets) /* I am not like the others */
172 #endif
173 #define RExC_emit       (pRExC_state->emit)
174 #define RExC_emit_start (pRExC_state->emit_start)
175 #define RExC_emit_bound (pRExC_state->emit_bound)
176 #define RExC_naughty    (pRExC_state->naughty)
177 #define RExC_sawback    (pRExC_state->sawback)
178 #define RExC_seen       (pRExC_state->seen)
179 #define RExC_size       (pRExC_state->size)
180 #define RExC_npar       (pRExC_state->npar)
181 #define RExC_nestroot   (pRExC_state->nestroot)
182 #define RExC_extralen   (pRExC_state->extralen)
183 #define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
184 #define RExC_seen_evals (pRExC_state->seen_evals)
185 #define RExC_utf8       (pRExC_state->utf8)
186 #define RExC_uni_semantics      (pRExC_state->uni_semantics)
187 #define RExC_orig_utf8  (pRExC_state->orig_utf8)
188 #define RExC_open_parens        (pRExC_state->open_parens)
189 #define RExC_close_parens       (pRExC_state->close_parens)
190 #define RExC_opend      (pRExC_state->opend)
191 #define RExC_paren_names        (pRExC_state->paren_names)
192 #define RExC_recurse    (pRExC_state->recurse)
193 #define RExC_recurse_count      (pRExC_state->recurse_count)
194 #define RExC_in_lookbehind      (pRExC_state->in_lookbehind)
195 #define RExC_contains_locale    (pRExC_state->contains_locale)
196 #define RExC_override_recoding  (pRExC_state->override_recoding)
197
198
199 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
200 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
201         ((*s) == '{' && regcurly(s)))
202
203 #ifdef SPSTART
204 #undef SPSTART          /* dratted cpp namespace... */
205 #endif
206 /*
207  * Flags to be passed up and down.
208  */
209 #define WORST           0       /* Worst case. */
210 #define HASWIDTH        0x01    /* Known to match non-null strings. */
211
212 /* Simple enough to be STAR/PLUS operand, in an EXACT node must be a single
213  * character, and if utf8, must be invariant.  Note that this is not the same thing as REGNODE_SIMPLE */
214 #define SIMPLE          0x02
215 #define SPSTART         0x04    /* Starts with * or +. */
216 #define TRYAGAIN        0x08    /* Weeded out a declaration. */
217 #define POSTPONED       0x10    /* (?1),(?&name), (??{...}) or similar */
218
219 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
220
221 /* whether trie related optimizations are enabled */
222 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
223 #define TRIE_STUDY_OPT
224 #define FULL_TRIE_STUDY
225 #define TRIE_STCLASS
226 #endif
227
228
229
230 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
231 #define PBITVAL(paren) (1 << ((paren) & 7))
232 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
233 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
234 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
235
236 /* If not already in utf8, do a longjmp back to the beginning */
237 #define UTF8_LONGJMP 42 /* Choose a value not likely to ever conflict */
238 #define REQUIRE_UTF8    STMT_START {                                       \
239                                      if (! UTF) JMPENV_JUMP(UTF8_LONGJMP); \
240                         } STMT_END
241
242 /* About scan_data_t.
243
244   During optimisation we recurse through the regexp program performing
245   various inplace (keyhole style) optimisations. In addition study_chunk
246   and scan_commit populate this data structure with information about
247   what strings MUST appear in the pattern. We look for the longest 
248   string that must appear at a fixed location, and we look for the
249   longest string that may appear at a floating location. So for instance
250   in the pattern:
251   
252     /FOO[xX]A.*B[xX]BAR/
253     
254   Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
255   strings (because they follow a .* construct). study_chunk will identify
256   both FOO and BAR as being the longest fixed and floating strings respectively.
257   
258   The strings can be composites, for instance
259   
260      /(f)(o)(o)/
261      
262   will result in a composite fixed substring 'foo'.
263   
264   For each string some basic information is maintained:
265   
266   - offset or min_offset
267     This is the position the string must appear at, or not before.
268     It also implicitly (when combined with minlenp) tells us how many
269     characters must match before the string we are searching for.
270     Likewise when combined with minlenp and the length of the string it
271     tells us how many characters must appear after the string we have 
272     found.
273   
274   - max_offset
275     Only used for floating strings. This is the rightmost point that
276     the string can appear at. If set to I32 max it indicates that the
277     string can occur infinitely far to the right.
278   
279   - minlenp
280     A pointer to the minimum length of the pattern that the string 
281     was found inside. This is important as in the case of positive 
282     lookahead or positive lookbehind we can have multiple patterns 
283     involved. Consider
284     
285     /(?=FOO).*F/
286     
287     The minimum length of the pattern overall is 3, the minimum length
288     of the lookahead part is 3, but the minimum length of the part that
289     will actually match is 1. So 'FOO's minimum length is 3, but the 
290     minimum length for the F is 1. This is important as the minimum length
291     is used to determine offsets in front of and behind the string being 
292     looked for.  Since strings can be composites this is the length of the
293     pattern at the time it was committed with a scan_commit. Note that
294     the length is calculated by study_chunk, so that the minimum lengths
295     are not known until the full pattern has been compiled, thus the 
296     pointer to the value.
297   
298   - lookbehind
299   
300     In the case of lookbehind the string being searched for can be
301     offset past the start point of the final matching string. 
302     If this value was just blithely removed from the min_offset it would
303     invalidate some of the calculations for how many chars must match
304     before or after (as they are derived from min_offset and minlen and
305     the length of the string being searched for). 
306     When the final pattern is compiled and the data is moved from the
307     scan_data_t structure into the regexp structure the information
308     about lookbehind is factored in, with the information that would 
309     have been lost precalculated in the end_shift field for the 
310     associated string.
311
312   The fields pos_min and pos_delta are used to store the minimum offset
313   and the delta to the maximum offset at the current point in the pattern.    
314
315 */
316
317 typedef struct scan_data_t {
318     /*I32 len_min;      unused */
319     /*I32 len_delta;    unused */
320     I32 pos_min;
321     I32 pos_delta;
322     SV *last_found;
323     I32 last_end;           /* min value, <0 unless valid. */
324     I32 last_start_min;
325     I32 last_start_max;
326     SV **longest;           /* Either &l_fixed, or &l_float. */
327     SV *longest_fixed;      /* longest fixed string found in pattern */
328     I32 offset_fixed;       /* offset where it starts */
329     I32 *minlen_fixed;      /* pointer to the minlen relevant to the string */
330     I32 lookbehind_fixed;   /* is the position of the string modfied by LB */
331     SV *longest_float;      /* longest floating string found in pattern */
332     I32 offset_float_min;   /* earliest point in string it can appear */
333     I32 offset_float_max;   /* latest point in string it can appear */
334     I32 *minlen_float;      /* pointer to the minlen relevant to the string */
335     I32 lookbehind_float;   /* is the position of the string modified by LB */
336     I32 flags;
337     I32 whilem_c;
338     I32 *last_closep;
339     struct regnode_charclass_class *start_class;
340 } scan_data_t;
341
342 /*
343  * Forward declarations for pregcomp()'s friends.
344  */
345
346 static const scan_data_t zero_scan_data =
347   { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,0};
348
349 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
350 #define SF_BEFORE_SEOL          0x0001
351 #define SF_BEFORE_MEOL          0x0002
352 #define SF_FIX_BEFORE_EOL       (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
353 #define SF_FL_BEFORE_EOL        (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
354
355 #ifdef NO_UNARY_PLUS
356 #  define SF_FIX_SHIFT_EOL      (0+2)
357 #  define SF_FL_SHIFT_EOL               (0+4)
358 #else
359 #  define SF_FIX_SHIFT_EOL      (+2)
360 #  define SF_FL_SHIFT_EOL               (+4)
361 #endif
362
363 #define SF_FIX_BEFORE_SEOL      (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
364 #define SF_FIX_BEFORE_MEOL      (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
365
366 #define SF_FL_BEFORE_SEOL       (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
367 #define SF_FL_BEFORE_MEOL       (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
368 #define SF_IS_INF               0x0040
369 #define SF_HAS_PAR              0x0080
370 #define SF_IN_PAR               0x0100
371 #define SF_HAS_EVAL             0x0200
372 #define SCF_DO_SUBSTR           0x0400
373 #define SCF_DO_STCLASS_AND      0x0800
374 #define SCF_DO_STCLASS_OR       0x1000
375 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
376 #define SCF_WHILEM_VISITED_POS  0x2000
377
378 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
379 #define SCF_SEEN_ACCEPT         0x8000 
380
381 #define UTF cBOOL(RExC_utf8)
382 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
383 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
384 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_DEPENDS_CHARSET)
385 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags) >= REGEX_UNICODE_CHARSET)
386 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_RESTRICTED_CHARSET)
387 #define MORE_ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
388 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags) >= REGEX_ASCII_RESTRICTED_CHARSET)
389
390 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
391
392 #define OOB_UNICODE             12345678
393 #define OOB_NAMEDCLASS          -1
394
395 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
396 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
397
398
399 /* length of regex to show in messages that don't mark a position within */
400 #define RegexLengthToShowInErrorMessages 127
401
402 /*
403  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
404  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
405  * op/pragma/warn/regcomp.
406  */
407 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
408 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
409
410 #define REPORT_LOCATION " in regex; marked by " MARKER1 " in m/%.*s" MARKER2 "%s/"
411
412 /*
413  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
414  * arg. Show regex, up to a maximum length. If it's too long, chop and add
415  * "...".
416  */
417 #define _FAIL(code) STMT_START {                                        \
418     const char *ellipses = "";                                          \
419     IV len = RExC_end - RExC_precomp;                                   \
420                                                                         \
421     if (!SIZE_ONLY)                                                     \
422         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv);                   \
423     if (len > RegexLengthToShowInErrorMessages) {                       \
424         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
425         len = RegexLengthToShowInErrorMessages - 10;                    \
426         ellipses = "...";                                               \
427     }                                                                   \
428     code;                                                               \
429 } STMT_END
430
431 #define FAIL(msg) _FAIL(                            \
432     Perl_croak(aTHX_ "%s in regex m/%.*s%s/",       \
433             msg, (int)len, RExC_precomp, ellipses))
434
435 #define FAIL2(msg,arg) _FAIL(                       \
436     Perl_croak(aTHX_ msg " in regex m/%.*s%s/",     \
437             arg, (int)len, RExC_precomp, ellipses))
438
439 /*
440  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
441  */
442 #define Simple_vFAIL(m) STMT_START {                                    \
443     const IV offset = RExC_parse - RExC_precomp;                        \
444     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
445             m, (int)offset, RExC_precomp, RExC_precomp + offset);       \
446 } STMT_END
447
448 /*
449  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
450  */
451 #define vFAIL(m) STMT_START {                           \
452     if (!SIZE_ONLY)                                     \
453         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv);   \
454     Simple_vFAIL(m);                                    \
455 } STMT_END
456
457 /*
458  * Like Simple_vFAIL(), but accepts two arguments.
459  */
460 #define Simple_vFAIL2(m,a1) STMT_START {                        \
461     const IV offset = RExC_parse - RExC_precomp;                        \
462     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1,                   \
463             (int)offset, RExC_precomp, RExC_precomp + offset);  \
464 } STMT_END
465
466 /*
467  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
468  */
469 #define vFAIL2(m,a1) STMT_START {                       \
470     if (!SIZE_ONLY)                                     \
471         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv);   \
472     Simple_vFAIL2(m, a1);                               \
473 } STMT_END
474
475
476 /*
477  * Like Simple_vFAIL(), but accepts three arguments.
478  */
479 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
480     const IV offset = RExC_parse - RExC_precomp;                \
481     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2,               \
482             (int)offset, RExC_precomp, RExC_precomp + offset);  \
483 } STMT_END
484
485 /*
486  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
487  */
488 #define vFAIL3(m,a1,a2) STMT_START {                    \
489     if (!SIZE_ONLY)                                     \
490         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv);   \
491     Simple_vFAIL3(m, a1, a2);                           \
492 } STMT_END
493
494 /*
495  * Like Simple_vFAIL(), but accepts four arguments.
496  */
497 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
498     const IV offset = RExC_parse - RExC_precomp;                \
499     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3,           \
500             (int)offset, RExC_precomp, RExC_precomp + offset);  \
501 } STMT_END
502
503 #define ckWARNreg(loc,m) STMT_START {                                   \
504     const IV offset = loc - RExC_precomp;                               \
505     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
506             (int)offset, RExC_precomp, RExC_precomp + offset);          \
507 } STMT_END
508
509 #define ckWARNregdep(loc,m) STMT_START {                                \
510     const IV offset = loc - RExC_precomp;                               \
511     Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP),     \
512             m REPORT_LOCATION,                                          \
513             (int)offset, RExC_precomp, RExC_precomp + offset);          \
514 } STMT_END
515
516 #define ckWARN2regdep(loc,m, a1) STMT_START {                           \
517     const IV offset = loc - RExC_precomp;                               \
518     Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP),     \
519             m REPORT_LOCATION,                                          \
520             a1, (int)offset, RExC_precomp, RExC_precomp + offset);      \
521 } STMT_END
522
523 #define ckWARN2reg(loc, m, a1) STMT_START {                             \
524     const IV offset = loc - RExC_precomp;                               \
525     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
526             a1, (int)offset, RExC_precomp, RExC_precomp + offset);      \
527 } STMT_END
528
529 #define vWARN3(loc, m, a1, a2) STMT_START {                             \
530     const IV offset = loc - RExC_precomp;                               \
531     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
532             a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset);  \
533 } STMT_END
534
535 #define ckWARN3reg(loc, m, a1, a2) STMT_START {                         \
536     const IV offset = loc - RExC_precomp;                               \
537     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
538             a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset);  \
539 } STMT_END
540
541 #define vWARN4(loc, m, a1, a2, a3) STMT_START {                         \
542     const IV offset = loc - RExC_precomp;                               \
543     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
544             a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
545 } STMT_END
546
547 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START {                     \
548     const IV offset = loc - RExC_precomp;                               \
549     Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,      \
550             a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
551 } STMT_END
552
553 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {                     \
554     const IV offset = loc - RExC_precomp;                               \
555     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
556             a1, a2, a3, a4, (int)offset, RExC_precomp, RExC_precomp + offset); \
557 } STMT_END
558
559
560 /* Allow for side effects in s */
561 #define REGC(c,s) STMT_START {                  \
562     if (!SIZE_ONLY) *(s) = (c); else (void)(s); \
563 } STMT_END
564
565 /* Macros for recording node offsets.   20001227 mjd@plover.com 
566  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
567  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
568  * Element 0 holds the number n.
569  * Position is 1 indexed.
570  */
571 #ifndef RE_TRACK_PATTERN_OFFSETS
572 #define Set_Node_Offset_To_R(node,byte)
573 #define Set_Node_Offset(node,byte)
574 #define Set_Cur_Node_Offset
575 #define Set_Node_Length_To_R(node,len)
576 #define Set_Node_Length(node,len)
577 #define Set_Node_Cur_Length(node)
578 #define Node_Offset(n) 
579 #define Node_Length(n) 
580 #define Set_Node_Offset_Length(node,offset,len)
581 #define ProgLen(ri) ri->u.proglen
582 #define SetProgLen(ri,x) ri->u.proglen = x
583 #else
584 #define ProgLen(ri) ri->u.offsets[0]
585 #define SetProgLen(ri,x) ri->u.offsets[0] = x
586 #define Set_Node_Offset_To_R(node,byte) STMT_START {                    \
587     if (! SIZE_ONLY) {                                                  \
588         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
589                     __LINE__, (int)(node), (int)(byte)));               \
590         if((node) < 0) {                                                \
591             Perl_croak(aTHX_ "value of node is %d in Offset macro", (int)(node)); \
592         } else {                                                        \
593             RExC_offsets[2*(node)-1] = (byte);                          \
594         }                                                               \
595     }                                                                   \
596 } STMT_END
597
598 #define Set_Node_Offset(node,byte) \
599     Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
600 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
601
602 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
603     if (! SIZE_ONLY) {                                                  \
604         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
605                 __LINE__, (int)(node), (int)(len)));                    \
606         if((node) < 0) {                                                \
607             Perl_croak(aTHX_ "value of node is %d in Length macro", (int)(node)); \
608         } else {                                                        \
609             RExC_offsets[2*(node)] = (len);                             \
610         }                                                               \
611     }                                                                   \
612 } STMT_END
613
614 #define Set_Node_Length(node,len) \
615     Set_Node_Length_To_R((node)-RExC_emit_start, len)
616 #define Set_Cur_Node_Length(len) Set_Node_Length(RExC_emit, len)
617 #define Set_Node_Cur_Length(node) \
618     Set_Node_Length(node, RExC_parse - parse_start)
619
620 /* Get offsets and lengths */
621 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
622 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
623
624 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
625     Set_Node_Offset_To_R((node)-RExC_emit_start, (offset));     \
626     Set_Node_Length_To_R((node)-RExC_emit_start, (len));        \
627 } STMT_END
628 #endif
629
630 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
631 #define EXPERIMENTAL_INPLACESCAN
632 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
633
634 #define DEBUG_STUDYDATA(str,data,depth)                              \
635 DEBUG_OPTIMISE_MORE_r(if(data){                                      \
636     PerlIO_printf(Perl_debug_log,                                    \
637         "%*s" str "Pos:%"IVdf"/%"IVdf                                \
638         " Flags: 0x%"UVXf" Whilem_c: %"IVdf" Lcp: %"IVdf" %s",       \
639         (int)(depth)*2, "",                                          \
640         (IV)((data)->pos_min),                                       \
641         (IV)((data)->pos_delta),                                     \
642         (UV)((data)->flags),                                         \
643         (IV)((data)->whilem_c),                                      \
644         (IV)((data)->last_closep ? *((data)->last_closep) : -1),     \
645         is_inf ? "INF " : ""                                         \
646     );                                                               \
647     if ((data)->last_found)                                          \
648         PerlIO_printf(Perl_debug_log,                                \
649             "Last:'%s' %"IVdf":%"IVdf"/%"IVdf" %sFixed:'%s' @ %"IVdf \
650             " %sFloat: '%s' @ %"IVdf"/%"IVdf"",                      \
651             SvPVX_const((data)->last_found),                         \
652             (IV)((data)->last_end),                                  \
653             (IV)((data)->last_start_min),                            \
654             (IV)((data)->last_start_max),                            \
655             ((data)->longest &&                                      \
656              (data)->longest==&((data)->longest_fixed)) ? "*" : "",  \
657             SvPVX_const((data)->longest_fixed),                      \
658             (IV)((data)->offset_fixed),                              \
659             ((data)->longest &&                                      \
660              (data)->longest==&((data)->longest_float)) ? "*" : "",  \
661             SvPVX_const((data)->longest_float),                      \
662             (IV)((data)->offset_float_min),                          \
663             (IV)((data)->offset_float_max)                           \
664         );                                                           \
665     PerlIO_printf(Perl_debug_log,"\n");                              \
666 });
667
668 static void clear_re(pTHX_ void *r);
669
670 /* Mark that we cannot extend a found fixed substring at this point.
671    Update the longest found anchored substring and the longest found
672    floating substrings if needed. */
673
674 STATIC void
675 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, I32 *minlenp, int is_inf)
676 {
677     const STRLEN l = CHR_SVLEN(data->last_found);
678     const STRLEN old_l = CHR_SVLEN(*data->longest);
679     GET_RE_DEBUG_FLAGS_DECL;
680
681     PERL_ARGS_ASSERT_SCAN_COMMIT;
682
683     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
684         SvSetMagicSV(*data->longest, data->last_found);
685         if (*data->longest == data->longest_fixed) {
686             data->offset_fixed = l ? data->last_start_min : data->pos_min;
687             if (data->flags & SF_BEFORE_EOL)
688                 data->flags
689                     |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
690             else
691                 data->flags &= ~SF_FIX_BEFORE_EOL;
692             data->minlen_fixed=minlenp; 
693             data->lookbehind_fixed=0;
694         }
695         else { /* *data->longest == data->longest_float */
696             data->offset_float_min = l ? data->last_start_min : data->pos_min;
697             data->offset_float_max = (l
698                                       ? data->last_start_max
699                                       : data->pos_min + data->pos_delta);
700             if (is_inf || (U32)data->offset_float_max > (U32)I32_MAX)
701                 data->offset_float_max = I32_MAX;
702             if (data->flags & SF_BEFORE_EOL)
703                 data->flags
704                     |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
705             else
706                 data->flags &= ~SF_FL_BEFORE_EOL;
707             data->minlen_float=minlenp;
708             data->lookbehind_float=0;
709         }
710     }
711     SvCUR_set(data->last_found, 0);
712     {
713         SV * const sv = data->last_found;
714         if (SvUTF8(sv) && SvMAGICAL(sv)) {
715             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
716             if (mg)
717                 mg->mg_len = 0;
718         }
719     }
720     data->last_end = -1;
721     data->flags &= ~SF_BEFORE_EOL;
722     DEBUG_STUDYDATA("commit: ",data,0);
723 }
724
725 /* Can match anything (initialization) */
726 STATIC void
727 S_cl_anything(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
728 {
729     PERL_ARGS_ASSERT_CL_ANYTHING;
730
731     ANYOF_BITMAP_SETALL(cl);
732     cl->flags = ANYOF_CLASS|ANYOF_EOS|ANYOF_UNICODE_ALL
733                 |ANYOF_LOC_NONBITMAP_FOLD|ANYOF_NON_UTF8_LATIN1_ALL;
734
735     /* If any portion of the regex is to operate under locale rules,
736      * initialization includes it.  The reason this isn't done for all regexes
737      * is that the optimizer was written under the assumption that locale was
738      * all-or-nothing.  Given the complexity and lack of documentation in the
739      * optimizer, and that there are inadequate test cases for locale, so many
740      * parts of it may not work properly, it is safest to avoid locale unless
741      * necessary. */
742     if (RExC_contains_locale) {
743         ANYOF_CLASS_SETALL(cl);     /* /l uses class */
744         cl->flags |= ANYOF_LOCALE;
745     }
746     else {
747         ANYOF_CLASS_ZERO(cl);       /* Only /l uses class now */
748     }
749 }
750
751 /* Can match anything (initialization) */
752 STATIC int
753 S_cl_is_anything(const struct regnode_charclass_class *cl)
754 {
755     int value;
756
757     PERL_ARGS_ASSERT_CL_IS_ANYTHING;
758
759     for (value = 0; value <= ANYOF_MAX; value += 2)
760         if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
761             return 1;
762     if (!(cl->flags & ANYOF_UNICODE_ALL))
763         return 0;
764     if (!ANYOF_BITMAP_TESTALLSET((const void*)cl))
765         return 0;
766     return 1;
767 }
768
769 /* Can match anything (initialization) */
770 STATIC void
771 S_cl_init(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
772 {
773     PERL_ARGS_ASSERT_CL_INIT;
774
775     Zero(cl, 1, struct regnode_charclass_class);
776     cl->type = ANYOF;
777     cl_anything(pRExC_state, cl);
778     ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
779 }
780
781 /* These two functions currently do the exact same thing */
782 #define cl_init_zero            S_cl_init
783
784 /* 'AND' a given class with another one.  Can create false positives.  'cl'
785  * should not be inverted.  'and_with->flags & ANYOF_CLASS' should be 0 if
786  * 'and_with' is a regnode_charclass instead of a regnode_charclass_class. */
787 STATIC void
788 S_cl_and(struct regnode_charclass_class *cl,
789         const struct regnode_charclass_class *and_with)
790 {
791     PERL_ARGS_ASSERT_CL_AND;
792
793     assert(and_with->type == ANYOF);
794
795     /* I (khw) am not sure all these restrictions are necessary XXX */
796     if (!(ANYOF_CLASS_TEST_ANY_SET(and_with))
797         && !(ANYOF_CLASS_TEST_ANY_SET(cl))
798         && (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
799         && !(and_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
800         && !(cl->flags & ANYOF_LOC_NONBITMAP_FOLD)) {
801         int i;
802
803         if (and_with->flags & ANYOF_INVERT)
804             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
805                 cl->bitmap[i] &= ~and_with->bitmap[i];
806         else
807             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
808                 cl->bitmap[i] &= and_with->bitmap[i];
809     } /* XXXX: logic is complicated otherwise, leave it along for a moment. */
810
811     if (and_with->flags & ANYOF_INVERT) {
812
813         /* Here, the and'ed node is inverted.  Get the AND of the flags that
814          * aren't affected by the inversion.  Those that are affected are
815          * handled individually below */
816         U8 affected_flags = cl->flags & ~INVERSION_UNAFFECTED_FLAGS;
817         cl->flags &= (and_with->flags & INVERSION_UNAFFECTED_FLAGS);
818         cl->flags |= affected_flags;
819
820         /* We currently don't know how to deal with things that aren't in the
821          * bitmap, but we know that the intersection is no greater than what
822          * is already in cl, so let there be false positives that get sorted
823          * out after the synthetic start class succeeds, and the node is
824          * matched for real. */
825
826         /* The inversion of these two flags indicate that the resulting
827          * intersection doesn't have them */
828         if (and_with->flags & ANYOF_UNICODE_ALL) {
829             cl->flags &= ~ANYOF_UNICODE_ALL;
830         }
831         if (and_with->flags & ANYOF_NON_UTF8_LATIN1_ALL) {
832             cl->flags &= ~ANYOF_NON_UTF8_LATIN1_ALL;
833         }
834     }
835     else {   /* and'd node is not inverted */
836         U8 outside_bitmap_but_not_utf8; /* Temp variable */
837
838         if (! ANYOF_NONBITMAP(and_with)) {
839
840             /* Here 'and_with' doesn't match anything outside the bitmap
841              * (except possibly ANYOF_UNICODE_ALL), which means the
842              * intersection can't either, except for ANYOF_UNICODE_ALL, in
843              * which case we don't know what the intersection is, but it's no
844              * greater than what cl already has, so can just leave it alone,
845              * with possible false positives */
846             if (! (and_with->flags & ANYOF_UNICODE_ALL)) {
847                 ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
848                 cl->flags &= ~ANYOF_NONBITMAP_NON_UTF8;
849             }
850         }
851         else if (! ANYOF_NONBITMAP(cl)) {
852
853             /* Here, 'and_with' does match something outside the bitmap, and cl
854              * doesn't have a list of things to match outside the bitmap.  If
855              * cl can match all code points above 255, the intersection will
856              * be those above-255 code points that 'and_with' matches.  If cl
857              * can't match all Unicode code points, it means that it can't
858              * match anything outside the bitmap (since the 'if' that got us
859              * into this block tested for that), so we leave the bitmap empty.
860              */
861             if (cl->flags & ANYOF_UNICODE_ALL) {
862                 ARG_SET(cl, ARG(and_with));
863
864                 /* and_with's ARG may match things that don't require UTF8.
865                  * And now cl's will too, in spite of this being an 'and'.  See
866                  * the comments below about the kludge */
867                 cl->flags |= and_with->flags & ANYOF_NONBITMAP_NON_UTF8;
868             }
869         }
870         else {
871             /* Here, both 'and_with' and cl match something outside the
872              * bitmap.  Currently we do not do the intersection, so just match
873              * whatever cl had at the beginning.  */
874         }
875
876
877         /* Take the intersection of the two sets of flags.  However, the
878          * ANYOF_NONBITMAP_NON_UTF8 flag is treated as an 'or'.  This is a
879          * kludge around the fact that this flag is not treated like the others
880          * which are initialized in cl_anything().  The way the optimizer works
881          * is that the synthetic start class (SSC) is initialized to match
882          * anything, and then the first time a real node is encountered, its
883          * values are AND'd with the SSC's with the result being the values of
884          * the real node.  However, there are paths through the optimizer where
885          * the AND never gets called, so those initialized bits are set
886          * inappropriately, which is not usually a big deal, as they just cause
887          * false positives in the SSC, which will just mean a probably
888          * imperceptible slow down in execution.  However this bit has a
889          * higher false positive consequence in that it can cause utf8.pm,
890          * utf8_heavy.pl ... to be loaded when not necessary, which is a much
891          * bigger slowdown and also causes significant extra memory to be used.
892          * In order to prevent this, the code now takes a different tack.  The
893          * bit isn't set unless some part of the regular expression needs it,
894          * but once set it won't get cleared.  This means that these extra
895          * modules won't get loaded unless there was some path through the
896          * pattern that would have required them anyway, and  so any false
897          * positives that occur by not ANDing them out when they could be
898          * aren't as severe as they would be if we treated this bit like all
899          * the others */
900         outside_bitmap_but_not_utf8 = (cl->flags | and_with->flags)
901                                       & ANYOF_NONBITMAP_NON_UTF8;
902         cl->flags &= and_with->flags;
903         cl->flags |= outside_bitmap_but_not_utf8;
904     }
905 }
906
907 /* 'OR' a given class with another one.  Can create false positives.  'cl'
908  * should not be inverted.  'or_with->flags & ANYOF_CLASS' should be 0 if
909  * 'or_with' is a regnode_charclass instead of a regnode_charclass_class. */
910 STATIC void
911 S_cl_or(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, const struct regnode_charclass_class *or_with)
912 {
913     PERL_ARGS_ASSERT_CL_OR;
914
915     if (or_with->flags & ANYOF_INVERT) {
916
917         /* Here, the or'd node is to be inverted.  This means we take the
918          * complement of everything not in the bitmap, but currently we don't
919          * know what that is, so give up and match anything */
920         if (ANYOF_NONBITMAP(or_with)) {
921             cl_anything(pRExC_state, cl);
922         }
923         /* We do not use
924          * (B1 | CL1) | (!B2 & !CL2) = (B1 | !B2 & !CL2) | (CL1 | (!B2 & !CL2))
925          *   <= (B1 | !B2) | (CL1 | !CL2)
926          * which is wasteful if CL2 is small, but we ignore CL2:
927          *   (B1 | CL1) | (!B2 & !CL2) <= (B1 | CL1) | !B2 = (B1 | !B2) | CL1
928          * XXXX Can we handle case-fold?  Unclear:
929          *   (OK1(i) | OK1(i')) | !(OK1(i) | OK1(i')) =
930          *   (OK1(i) | OK1(i')) | (!OK1(i) & !OK1(i'))
931          */
932         else if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
933              && !(or_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
934              && !(cl->flags & ANYOF_LOC_NONBITMAP_FOLD) ) {
935             int i;
936
937             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
938                 cl->bitmap[i] |= ~or_with->bitmap[i];
939         } /* XXXX: logic is complicated otherwise */
940         else {
941             cl_anything(pRExC_state, cl);
942         }
943
944         /* And, we can just take the union of the flags that aren't affected
945          * by the inversion */
946         cl->flags |= or_with->flags & INVERSION_UNAFFECTED_FLAGS;
947
948         /* For the remaining flags:
949             ANYOF_UNICODE_ALL and inverted means to not match anything above
950                     255, which means that the union with cl should just be
951                     what cl has in it, so can ignore this flag
952             ANYOF_NON_UTF8_LATIN1_ALL and inverted means if not utf8 and ord
953                     is 127-255 to match them, but then invert that, so the
954                     union with cl should just be what cl has in it, so can
955                     ignore this flag
956          */
957     } else {    /* 'or_with' is not inverted */
958         /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
959         if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
960              && (!(or_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
961                  || (cl->flags & ANYOF_LOC_NONBITMAP_FOLD)) ) {
962             int i;
963
964             /* OR char bitmap and class bitmap separately */
965             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
966                 cl->bitmap[i] |= or_with->bitmap[i];
967             if (ANYOF_CLASS_TEST_ANY_SET(or_with)) {
968                 for (i = 0; i < ANYOF_CLASSBITMAP_SIZE; i++)
969                     cl->classflags[i] |= or_with->classflags[i];
970                 cl->flags |= ANYOF_CLASS;
971             }
972         }
973         else { /* XXXX: logic is complicated, leave it along for a moment. */
974             cl_anything(pRExC_state, cl);
975         }
976
977         if (ANYOF_NONBITMAP(or_with)) {
978
979             /* Use the added node's outside-the-bit-map match if there isn't a
980              * conflict.  If there is a conflict (both nodes match something
981              * outside the bitmap, but what they match outside is not the same
982              * pointer, and hence not easily compared until XXX we extend
983              * inversion lists this far), give up and allow the start class to
984              * match everything outside the bitmap.  If that stuff is all above
985              * 255, can just set UNICODE_ALL, otherwise caould be anything. */
986             if (! ANYOF_NONBITMAP(cl)) {
987                 ARG_SET(cl, ARG(or_with));
988             }
989             else if (ARG(cl) != ARG(or_with)) {
990
991                 if ((or_with->flags & ANYOF_NONBITMAP_NON_UTF8)) {
992                     cl_anything(pRExC_state, cl);
993                 }
994                 else {
995                     cl->flags |= ANYOF_UNICODE_ALL;
996                 }
997             }
998         }
999
1000         /* Take the union */
1001         cl->flags |= or_with->flags;
1002     }
1003 }
1004
1005 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
1006 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
1007 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
1008 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list ? (TRIE_LIST_CUR( idx ) - 1) : 0 )
1009
1010
1011 #ifdef DEBUGGING
1012 /*
1013    dump_trie(trie,widecharmap,revcharmap)
1014    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
1015    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
1016
1017    These routines dump out a trie in a somewhat readable format.
1018    The _interim_ variants are used for debugging the interim
1019    tables that are used to generate the final compressed
1020    representation which is what dump_trie expects.
1021
1022    Part of the reason for their existence is to provide a form
1023    of documentation as to how the different representations function.
1024
1025 */
1026
1027 /*
1028   Dumps the final compressed table form of the trie to Perl_debug_log.
1029   Used for debugging make_trie().
1030 */
1031
1032 STATIC void
1033 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
1034             AV *revcharmap, U32 depth)
1035 {
1036     U32 state;
1037     SV *sv=sv_newmortal();
1038     int colwidth= widecharmap ? 6 : 4;
1039     U16 word;
1040     GET_RE_DEBUG_FLAGS_DECL;
1041
1042     PERL_ARGS_ASSERT_DUMP_TRIE;
1043
1044     PerlIO_printf( Perl_debug_log, "%*sChar : %-6s%-6s%-4s ",
1045         (int)depth * 2 + 2,"",
1046         "Match","Base","Ofs" );
1047
1048     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
1049         SV ** const tmp = av_fetch( revcharmap, state, 0);
1050         if ( tmp ) {
1051             PerlIO_printf( Perl_debug_log, "%*s", 
1052                 colwidth,
1053                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1054                             PL_colors[0], PL_colors[1],
1055                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1056                             PERL_PV_ESCAPE_FIRSTCHAR 
1057                 ) 
1058             );
1059         }
1060     }
1061     PerlIO_printf( Perl_debug_log, "\n%*sState|-----------------------",
1062         (int)depth * 2 + 2,"");
1063
1064     for( state = 0 ; state < trie->uniquecharcount ; state++ )
1065         PerlIO_printf( Perl_debug_log, "%.*s", colwidth, "--------");
1066     PerlIO_printf( Perl_debug_log, "\n");
1067
1068     for( state = 1 ; state < trie->statecount ; state++ ) {
1069         const U32 base = trie->states[ state ].trans.base;
1070
1071         PerlIO_printf( Perl_debug_log, "%*s#%4"UVXf"|", (int)depth * 2 + 2,"", (UV)state);
1072
1073         if ( trie->states[ state ].wordnum ) {
1074             PerlIO_printf( Perl_debug_log, " W%4X", trie->states[ state ].wordnum );
1075         } else {
1076             PerlIO_printf( Perl_debug_log, "%6s", "" );
1077         }
1078
1079         PerlIO_printf( Perl_debug_log, " @%4"UVXf" ", (UV)base );
1080
1081         if ( base ) {
1082             U32 ofs = 0;
1083
1084             while( ( base + ofs  < trie->uniquecharcount ) ||
1085                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
1086                      && trie->trans[ base + ofs - trie->uniquecharcount ].check != state))
1087                     ofs++;
1088
1089             PerlIO_printf( Perl_debug_log, "+%2"UVXf"[ ", (UV)ofs);
1090
1091             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
1092                 if ( ( base + ofs >= trie->uniquecharcount ) &&
1093                      ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
1094                      trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
1095                 {
1096                    PerlIO_printf( Perl_debug_log, "%*"UVXf,
1097                     colwidth,
1098                     (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next );
1099                 } else {
1100                     PerlIO_printf( Perl_debug_log, "%*s",colwidth,"   ." );
1101                 }
1102             }
1103
1104             PerlIO_printf( Perl_debug_log, "]");
1105
1106         }
1107         PerlIO_printf( Perl_debug_log, "\n" );
1108     }
1109     PerlIO_printf(Perl_debug_log, "%*sword_info N:(prev,len)=", (int)depth*2, "");
1110     for (word=1; word <= trie->wordcount; word++) {
1111         PerlIO_printf(Perl_debug_log, " %d:(%d,%d)",
1112             (int)word, (int)(trie->wordinfo[word].prev),
1113             (int)(trie->wordinfo[word].len));
1114     }
1115     PerlIO_printf(Perl_debug_log, "\n" );
1116 }    
1117 /*
1118   Dumps a fully constructed but uncompressed trie in list form.
1119   List tries normally only are used for construction when the number of 
1120   possible chars (trie->uniquecharcount) is very high.
1121   Used for debugging make_trie().
1122 */
1123 STATIC void
1124 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
1125                          HV *widecharmap, AV *revcharmap, U32 next_alloc,
1126                          U32 depth)
1127 {
1128     U32 state;
1129     SV *sv=sv_newmortal();
1130     int colwidth= widecharmap ? 6 : 4;
1131     GET_RE_DEBUG_FLAGS_DECL;
1132
1133     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
1134
1135     /* print out the table precompression.  */
1136     PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s%s",
1137         (int)depth * 2 + 2,"", (int)depth * 2 + 2,"",
1138         "------:-----+-----------------\n" );
1139     
1140     for( state=1 ; state < next_alloc ; state ++ ) {
1141         U16 charid;
1142     
1143         PerlIO_printf( Perl_debug_log, "%*s %4"UVXf" :",
1144             (int)depth * 2 + 2,"", (UV)state  );
1145         if ( ! trie->states[ state ].wordnum ) {
1146             PerlIO_printf( Perl_debug_log, "%5s| ","");
1147         } else {
1148             PerlIO_printf( Perl_debug_log, "W%4x| ",
1149                 trie->states[ state ].wordnum
1150             );
1151         }
1152         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
1153             SV ** const tmp = av_fetch( revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0);
1154             if ( tmp ) {
1155                 PerlIO_printf( Perl_debug_log, "%*s:%3X=%4"UVXf" | ",
1156                     colwidth,
1157                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1158                             PL_colors[0], PL_colors[1],
1159                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1160                             PERL_PV_ESCAPE_FIRSTCHAR 
1161                     ) ,
1162                     TRIE_LIST_ITEM(state,charid).forid,
1163                     (UV)TRIE_LIST_ITEM(state,charid).newstate
1164                 );
1165                 if (!(charid % 10)) 
1166                     PerlIO_printf(Perl_debug_log, "\n%*s| ",
1167                         (int)((depth * 2) + 14), "");
1168             }
1169         }
1170         PerlIO_printf( Perl_debug_log, "\n");
1171     }
1172 }    
1173
1174 /*
1175   Dumps a fully constructed but uncompressed trie in table form.
1176   This is the normal DFA style state transition table, with a few 
1177   twists to facilitate compression later. 
1178   Used for debugging make_trie().
1179 */
1180 STATIC void
1181 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
1182                           HV *widecharmap, AV *revcharmap, U32 next_alloc,
1183                           U32 depth)
1184 {
1185     U32 state;
1186     U16 charid;
1187     SV *sv=sv_newmortal();
1188     int colwidth= widecharmap ? 6 : 4;
1189     GET_RE_DEBUG_FLAGS_DECL;
1190
1191     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
1192     
1193     /*
1194        print out the table precompression so that we can do a visual check
1195        that they are identical.
1196      */
1197     
1198     PerlIO_printf( Perl_debug_log, "%*sChar : ",(int)depth * 2 + 2,"" );
1199
1200     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1201         SV ** const tmp = av_fetch( revcharmap, charid, 0);
1202         if ( tmp ) {
1203             PerlIO_printf( Perl_debug_log, "%*s", 
1204                 colwidth,
1205                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth, 
1206                             PL_colors[0], PL_colors[1],
1207                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1208                             PERL_PV_ESCAPE_FIRSTCHAR 
1209                 ) 
1210             );
1211         }
1212     }
1213
1214     PerlIO_printf( Perl_debug_log, "\n%*sState+-",(int)depth * 2 + 2,"" );
1215
1216     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
1217         PerlIO_printf( Perl_debug_log, "%.*s", colwidth,"--------");
1218     }
1219
1220     PerlIO_printf( Perl_debug_log, "\n" );
1221
1222     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
1223
1224         PerlIO_printf( Perl_debug_log, "%*s%4"UVXf" : ", 
1225             (int)depth * 2 + 2,"",
1226             (UV)TRIE_NODENUM( state ) );
1227
1228         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1229             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
1230             if (v)
1231                 PerlIO_printf( Perl_debug_log, "%*"UVXf, colwidth, v );
1232             else
1233                 PerlIO_printf( Perl_debug_log, "%*s", colwidth, "." );
1234         }
1235         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
1236             PerlIO_printf( Perl_debug_log, " (%4"UVXf")\n", (UV)trie->trans[ state ].check );
1237         } else {
1238             PerlIO_printf( Perl_debug_log, " (%4"UVXf") W%4X\n", (UV)trie->trans[ state ].check,
1239             trie->states[ TRIE_NODENUM( state ) ].wordnum );
1240         }
1241     }
1242 }
1243
1244 #endif
1245
1246
1247 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
1248   startbranch: the first branch in the whole branch sequence
1249   first      : start branch of sequence of branch-exact nodes.
1250                May be the same as startbranch
1251   last       : Thing following the last branch.
1252                May be the same as tail.
1253   tail       : item following the branch sequence
1254   count      : words in the sequence
1255   flags      : currently the OP() type we will be building one of /EXACT(|F|Fl)/
1256   depth      : indent depth
1257
1258 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
1259
1260 A trie is an N'ary tree where the branches are determined by digital
1261 decomposition of the key. IE, at the root node you look up the 1st character and
1262 follow that branch repeat until you find the end of the branches. Nodes can be
1263 marked as "accepting" meaning they represent a complete word. Eg:
1264
1265   /he|she|his|hers/
1266
1267 would convert into the following structure. Numbers represent states, letters
1268 following numbers represent valid transitions on the letter from that state, if
1269 the number is in square brackets it represents an accepting state, otherwise it
1270 will be in parenthesis.
1271
1272       +-h->+-e->[3]-+-r->(8)-+-s->[9]
1273       |    |
1274       |   (2)
1275       |    |
1276      (1)   +-i->(6)-+-s->[7]
1277       |
1278       +-s->(3)-+-h->(4)-+-e->[5]
1279
1280       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
1281
1282 This shows that when matching against the string 'hers' we will begin at state 1
1283 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
1284 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
1285 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
1286 single traverse. We store a mapping from accepting to state to which word was
1287 matched, and then when we have multiple possibilities we try to complete the
1288 rest of the regex in the order in which they occured in the alternation.
1289
1290 The only prior NFA like behaviour that would be changed by the TRIE support is
1291 the silent ignoring of duplicate alternations which are of the form:
1292
1293  / (DUPE|DUPE) X? (?{ ... }) Y /x
1294
1295 Thus EVAL blocks following a trie may be called a different number of times with
1296 and without the optimisation. With the optimisations dupes will be silently
1297 ignored. This inconsistent behaviour of EVAL type nodes is well established as
1298 the following demonstrates:
1299
1300  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
1301
1302 which prints out 'word' three times, but
1303
1304  'words'=~/(word|word|word)(?{ print $1 })S/
1305
1306 which doesnt print it out at all. This is due to other optimisations kicking in.
1307
1308 Example of what happens on a structural level:
1309
1310 The regexp /(ac|ad|ab)+/ will produce the following debug output:
1311
1312    1: CURLYM[1] {1,32767}(18)
1313    5:   BRANCH(8)
1314    6:     EXACT <ac>(16)
1315    8:   BRANCH(11)
1316    9:     EXACT <ad>(16)
1317   11:   BRANCH(14)
1318   12:     EXACT <ab>(16)
1319   16:   SUCCEED(0)
1320   17:   NOTHING(18)
1321   18: END(0)
1322
1323 This would be optimizable with startbranch=5, first=5, last=16, tail=16
1324 and should turn into:
1325
1326    1: CURLYM[1] {1,32767}(18)
1327    5:   TRIE(16)
1328         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
1329           <ac>
1330           <ad>
1331           <ab>
1332   16:   SUCCEED(0)
1333   17:   NOTHING(18)
1334   18: END(0)
1335
1336 Cases where tail != last would be like /(?foo|bar)baz/:
1337
1338    1: BRANCH(4)
1339    2:   EXACT <foo>(8)
1340    4: BRANCH(7)
1341    5:   EXACT <bar>(8)
1342    7: TAIL(8)
1343    8: EXACT <baz>(10)
1344   10: END(0)
1345
1346 which would be optimizable with startbranch=1, first=1, last=7, tail=8
1347 and would end up looking like:
1348
1349     1: TRIE(8)
1350       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
1351         <foo>
1352         <bar>
1353    7: TAIL(8)
1354    8: EXACT <baz>(10)
1355   10: END(0)
1356
1357     d = uvuni_to_utf8_flags(d, uv, 0);
1358
1359 is the recommended Unicode-aware way of saying
1360
1361     *(d++) = uv;
1362 */
1363
1364 #define TRIE_STORE_REVCHAR                                                 \
1365     STMT_START {                                                           \
1366         if (UTF) {                                                         \
1367             SV *zlopp = newSV(2);                                          \
1368             unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp);      \
1369             unsigned const char *const kapow = uvuni_to_utf8(flrbbbbb, uvc & 0xFF); \
1370             SvCUR_set(zlopp, kapow - flrbbbbb);                            \
1371             SvPOK_on(zlopp);                                               \
1372             SvUTF8_on(zlopp);                                              \
1373             av_push(revcharmap, zlopp);                                    \
1374         } else {                                                           \
1375             char ooooff = (char)uvc;                                               \
1376             av_push(revcharmap, newSVpvn(&ooooff, 1));                     \
1377         }                                                                  \
1378         } STMT_END
1379
1380 #define TRIE_READ_CHAR STMT_START {                                           \
1381     wordlen++;                                                                \
1382     if ( UTF ) {                                                              \
1383         if ( folder ) {                                                       \
1384             if ( foldlen > 0 ) {                                              \
1385                uvc = utf8n_to_uvuni( scan, UTF8_MAXLEN, &len, uniflags );     \
1386                foldlen -= len;                                                \
1387                scan += len;                                                   \
1388                len = 0;                                                       \
1389             } else {                                                          \
1390                 uvc = utf8n_to_uvuni( (const U8*)uc, UTF8_MAXLEN, &len, uniflags);\
1391                 uvc = to_uni_fold( uvc, foldbuf, &foldlen );                  \
1392                 foldlen -= UNISKIP( uvc );                                    \
1393                 scan = foldbuf + UNISKIP( uvc );                              \
1394             }                                                                 \
1395         } else {                                                              \
1396             uvc = utf8n_to_uvuni( (const U8*)uc, UTF8_MAXLEN, &len, uniflags);\
1397         }                                                                     \
1398     } else {                                                                  \
1399         uvc = (U32)*uc;                                                       \
1400         len = 1;                                                              \
1401     }                                                                         \
1402 } STMT_END
1403
1404
1405
1406 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
1407     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
1408         U32 ging = TRIE_LIST_LEN( state ) *= 2;                 \
1409         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
1410     }                                                           \
1411     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
1412     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
1413     TRIE_LIST_CUR( state )++;                                   \
1414 } STMT_END
1415
1416 #define TRIE_LIST_NEW(state) STMT_START {                       \
1417     Newxz( trie->states[ state ].trans.list,               \
1418         4, reg_trie_trans_le );                                 \
1419      TRIE_LIST_CUR( state ) = 1;                                \
1420      TRIE_LIST_LEN( state ) = 4;                                \
1421 } STMT_END
1422
1423 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
1424     U16 dupe= trie->states[ state ].wordnum;                    \
1425     regnode * const noper_next = regnext( noper );              \
1426                                                                 \
1427     DEBUG_r({                                                   \
1428         /* store the word for dumping */                        \
1429         SV* tmp;                                                \
1430         if (OP(noper) != NOTHING)                               \
1431             tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF);    \
1432         else                                                    \
1433             tmp = newSVpvn_utf8( "", 0, UTF );                  \
1434         av_push( trie_words, tmp );                             \
1435     });                                                         \
1436                                                                 \
1437     curword++;                                                  \
1438     trie->wordinfo[curword].prev   = 0;                         \
1439     trie->wordinfo[curword].len    = wordlen;                   \
1440     trie->wordinfo[curword].accept = state;                     \
1441                                                                 \
1442     if ( noper_next < tail ) {                                  \
1443         if (!trie->jump)                                        \
1444             trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, sizeof(U16) ); \
1445         trie->jump[curword] = (U16)(noper_next - convert);      \
1446         if (!jumper)                                            \
1447             jumper = noper_next;                                \
1448         if (!nextbranch)                                        \
1449             nextbranch= regnext(cur);                           \
1450     }                                                           \
1451                                                                 \
1452     if ( dupe ) {                                               \
1453         /* It's a dupe. Pre-insert into the wordinfo[].prev   */\
1454         /* chain, so that when the bits of chain are later    */\
1455         /* linked together, the dups appear in the chain      */\
1456         trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
1457         trie->wordinfo[dupe].prev = curword;                    \
1458     } else {                                                    \
1459         /* we haven't inserted this word yet.                */ \
1460         trie->states[ state ].wordnum = curword;                \
1461     }                                                           \
1462 } STMT_END
1463
1464
1465 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
1466      ( ( base + charid >=  ucharcount                                   \
1467          && base + charid < ubound                                      \
1468          && state == trie->trans[ base - ucharcount + charid ].check    \
1469          && trie->trans[ base - ucharcount + charid ].next )            \
1470            ? trie->trans[ base - ucharcount + charid ].next             \
1471            : ( state==1 ? special : 0 )                                 \
1472       )
1473
1474 #define MADE_TRIE       1
1475 #define MADE_JUMP_TRIE  2
1476 #define MADE_EXACT_TRIE 4
1477
1478 STATIC I32
1479 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *first, regnode *last, regnode *tail, U32 word_count, U32 flags, U32 depth)
1480 {
1481     dVAR;
1482     /* first pass, loop through and scan words */
1483     reg_trie_data *trie;
1484     HV *widecharmap = NULL;
1485     AV *revcharmap = newAV();
1486     regnode *cur;
1487     const U32 uniflags = UTF8_ALLOW_DEFAULT;
1488     STRLEN len = 0;
1489     UV uvc = 0;
1490     U16 curword = 0;
1491     U32 next_alloc = 0;
1492     regnode *jumper = NULL;
1493     regnode *nextbranch = NULL;
1494     regnode *convert = NULL;
1495     U32 *prev_states; /* temp array mapping each state to previous one */
1496     /* we just use folder as a flag in utf8 */
1497     const U8 * folder = NULL;
1498
1499 #ifdef DEBUGGING
1500     const U32 data_slot = add_data( pRExC_state, 4, "tuuu" );
1501     AV *trie_words = NULL;
1502     /* along with revcharmap, this only used during construction but both are
1503      * useful during debugging so we store them in the struct when debugging.
1504      */
1505 #else
1506     const U32 data_slot = add_data( pRExC_state, 2, "tu" );
1507     STRLEN trie_charcount=0;
1508 #endif
1509     SV *re_trie_maxbuff;
1510     GET_RE_DEBUG_FLAGS_DECL;
1511
1512     PERL_ARGS_ASSERT_MAKE_TRIE;
1513 #ifndef DEBUGGING
1514     PERL_UNUSED_ARG(depth);
1515 #endif
1516
1517     switch (flags) {
1518         case EXACTFA:
1519         case EXACTFU: folder = PL_fold_latin1; break;
1520         case EXACTF:  folder = PL_fold; break;
1521         case EXACTFL: folder = PL_fold_locale; break;
1522     }
1523
1524     trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
1525     trie->refcount = 1;
1526     trie->startstate = 1;
1527     trie->wordcount = word_count;
1528     RExC_rxi->data->data[ data_slot ] = (void*)trie;
1529     trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
1530     if (!(UTF && folder))
1531         trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
1532     trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
1533                        trie->wordcount+1, sizeof(reg_trie_wordinfo));
1534
1535     DEBUG_r({
1536         trie_words = newAV();
1537     });
1538
1539     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
1540     if (!SvIOK(re_trie_maxbuff)) {
1541         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
1542     }
1543     DEBUG_OPTIMISE_r({
1544                 PerlIO_printf( Perl_debug_log,
1545                   "%*smake_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
1546                   (int)depth * 2 + 2, "", 
1547                   REG_NODE_NUM(startbranch),REG_NODE_NUM(first), 
1548                   REG_NODE_NUM(last), REG_NODE_NUM(tail),
1549                   (int)depth);
1550     });
1551    
1552    /* Find the node we are going to overwrite */
1553     if ( first == startbranch && OP( last ) != BRANCH ) {
1554         /* whole branch chain */
1555         convert = first;
1556     } else {
1557         /* branch sub-chain */
1558         convert = NEXTOPER( first );
1559     }
1560         
1561     /*  -- First loop and Setup --
1562
1563        We first traverse the branches and scan each word to determine if it
1564        contains widechars, and how many unique chars there are, this is
1565        important as we have to build a table with at least as many columns as we
1566        have unique chars.
1567
1568        We use an array of integers to represent the character codes 0..255
1569        (trie->charmap) and we use a an HV* to store Unicode characters. We use the
1570        native representation of the character value as the key and IV's for the
1571        coded index.
1572
1573        *TODO* If we keep track of how many times each character is used we can
1574        remap the columns so that the table compression later on is more
1575        efficient in terms of memory by ensuring the most common value is in the
1576        middle and the least common are on the outside.  IMO this would be better
1577        than a most to least common mapping as theres a decent chance the most
1578        common letter will share a node with the least common, meaning the node
1579        will not be compressible. With a middle is most common approach the worst
1580        case is when we have the least common nodes twice.
1581
1582      */
1583
1584     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1585         regnode * const noper = NEXTOPER( cur );
1586         const U8 *uc = (U8*)STRING( noper );
1587         const U8 * const e  = uc + STR_LEN( noper );
1588         STRLEN foldlen = 0;
1589         U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1590         const U8 *scan = (U8*)NULL;
1591         U32 wordlen      = 0;         /* required init */
1592         STRLEN chars = 0;
1593         bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the bitmap?*/
1594
1595         if (OP(noper) == NOTHING) {
1596             trie->minlen= 0;
1597             continue;
1598         }
1599         if ( set_bit ) /* bitmap only alloced when !(UTF&&Folding) */
1600             TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
1601                                           regardless of encoding */
1602
1603         for ( ; uc < e ; uc += len ) {
1604             TRIE_CHARCOUNT(trie)++;
1605             TRIE_READ_CHAR;
1606             chars++;
1607             if ( uvc < 256 ) {
1608                 if ( !trie->charmap[ uvc ] ) {
1609                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
1610                     if ( folder )
1611                         trie->charmap[ folder[ uvc ] ] = trie->charmap[ uvc ];
1612                     TRIE_STORE_REVCHAR;
1613                 }
1614                 if ( set_bit ) {
1615                     /* store the codepoint in the bitmap, and its folded
1616                      * equivalent. */
1617                     TRIE_BITMAP_SET(trie,uvc);
1618
1619                     /* store the folded codepoint */
1620                     if ( folder ) TRIE_BITMAP_SET(trie,folder[ uvc ]);
1621
1622                     if ( !UTF ) {
1623                         /* store first byte of utf8 representation of
1624                            variant codepoints */
1625                         if (! UNI_IS_INVARIANT(uvc)) {
1626                             TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));
1627                         }
1628                     }
1629                     set_bit = 0; /* We've done our bit :-) */
1630                 }
1631             } else {
1632                 SV** svpp;
1633                 if ( !widecharmap )
1634                     widecharmap = newHV();
1635
1636                 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
1637
1638                 if ( !svpp )
1639                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%"UVXf, uvc );
1640
1641                 if ( !SvTRUE( *svpp ) ) {
1642                     sv_setiv( *svpp, ++trie->uniquecharcount );
1643                     TRIE_STORE_REVCHAR;
1644                 }
1645             }
1646         }
1647         if( cur == first ) {
1648             trie->minlen=chars;
1649             trie->maxlen=chars;
1650         } else if (chars < trie->minlen) {
1651             trie->minlen=chars;
1652         } else if (chars > trie->maxlen) {
1653             trie->maxlen=chars;
1654         }
1655
1656     } /* end first pass */
1657     DEBUG_TRIE_COMPILE_r(
1658         PerlIO_printf( Perl_debug_log, "%*sTRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
1659                 (int)depth * 2 + 2,"",
1660                 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
1661                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
1662                 (int)trie->minlen, (int)trie->maxlen )
1663     );
1664
1665     /*
1666         We now know what we are dealing with in terms of unique chars and
1667         string sizes so we can calculate how much memory a naive
1668         representation using a flat table  will take. If it's over a reasonable
1669         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
1670         conservative but potentially much slower representation using an array
1671         of lists.
1672
1673         At the end we convert both representations into the same compressed
1674         form that will be used in regexec.c for matching with. The latter
1675         is a form that cannot be used to construct with but has memory
1676         properties similar to the list form and access properties similar
1677         to the table form making it both suitable for fast searches and
1678         small enough that its feasable to store for the duration of a program.
1679
1680         See the comment in the code where the compressed table is produced
1681         inplace from the flat tabe representation for an explanation of how
1682         the compression works.
1683
1684     */
1685
1686
1687     Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
1688     prev_states[1] = 0;
1689
1690     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1) > SvIV(re_trie_maxbuff) ) {
1691         /*
1692             Second Pass -- Array Of Lists Representation
1693
1694             Each state will be represented by a list of charid:state records
1695             (reg_trie_trans_le) the first such element holds the CUR and LEN
1696             points of the allocated array. (See defines above).
1697
1698             We build the initial structure using the lists, and then convert
1699             it into the compressed table form which allows faster lookups
1700             (but cant be modified once converted).
1701         */
1702
1703         STRLEN transcount = 1;
1704
1705         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, 
1706             "%*sCompiling trie using list compiler\n",
1707             (int)depth * 2 + 2, ""));
1708         
1709         trie->states = (reg_trie_state *)
1710             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1711                                   sizeof(reg_trie_state) );
1712         TRIE_LIST_NEW(1);
1713         next_alloc = 2;
1714
1715         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1716
1717             regnode * const noper = NEXTOPER( cur );
1718             U8 *uc           = (U8*)STRING( noper );
1719             const U8 * const e = uc + STR_LEN( noper );
1720             U32 state        = 1;         /* required init */
1721             U16 charid       = 0;         /* sanity init */
1722             U8 *scan         = (U8*)NULL; /* sanity init */
1723             STRLEN foldlen   = 0;         /* required init */
1724             U32 wordlen      = 0;         /* required init */
1725             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1726
1727             if (OP(noper) != NOTHING) {
1728                 for ( ; uc < e ; uc += len ) {
1729
1730                     TRIE_READ_CHAR;
1731
1732                     if ( uvc < 256 ) {
1733                         charid = trie->charmap[ uvc ];
1734                     } else {
1735                         SV** const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
1736                         if ( !svpp ) {
1737                             charid = 0;
1738                         } else {
1739                             charid=(U16)SvIV( *svpp );
1740                         }
1741                     }
1742                     /* charid is now 0 if we dont know the char read, or nonzero if we do */
1743                     if ( charid ) {
1744
1745                         U16 check;
1746                         U32 newstate = 0;
1747
1748                         charid--;
1749                         if ( !trie->states[ state ].trans.list ) {
1750                             TRIE_LIST_NEW( state );
1751                         }
1752                         for ( check = 1; check <= TRIE_LIST_USED( state ); check++ ) {
1753                             if ( TRIE_LIST_ITEM( state, check ).forid == charid ) {
1754                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
1755                                 break;
1756                             }
1757                         }
1758                         if ( ! newstate ) {
1759                             newstate = next_alloc++;
1760                             prev_states[newstate] = state;
1761                             TRIE_LIST_PUSH( state, charid, newstate );
1762                             transcount++;
1763                         }
1764                         state = newstate;
1765                     } else {
1766                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1767                     }
1768                 }
1769             }
1770             TRIE_HANDLE_WORD(state);
1771
1772         } /* end second pass */
1773
1774         /* next alloc is the NEXT state to be allocated */
1775         trie->statecount = next_alloc; 
1776         trie->states = (reg_trie_state *)
1777             PerlMemShared_realloc( trie->states,
1778                                    next_alloc
1779                                    * sizeof(reg_trie_state) );
1780
1781         /* and now dump it out before we compress it */
1782         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
1783                                                          revcharmap, next_alloc,
1784                                                          depth+1)
1785         );
1786
1787         trie->trans = (reg_trie_trans *)
1788             PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
1789         {
1790             U32 state;
1791             U32 tp = 0;
1792             U32 zp = 0;
1793
1794
1795             for( state=1 ; state < next_alloc ; state ++ ) {
1796                 U32 base=0;
1797
1798                 /*
1799                 DEBUG_TRIE_COMPILE_MORE_r(
1800                     PerlIO_printf( Perl_debug_log, "tp: %d zp: %d ",tp,zp)
1801                 );
1802                 */
1803
1804                 if (trie->states[state].trans.list) {
1805                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
1806                     U16 maxid=minid;
1807                     U16 idx;
1808
1809                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1810                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
1811                         if ( forid < minid ) {
1812                             minid=forid;
1813                         } else if ( forid > maxid ) {
1814                             maxid=forid;
1815                         }
1816                     }
1817                     if ( transcount < tp + maxid - minid + 1) {
1818                         transcount *= 2;
1819                         trie->trans = (reg_trie_trans *)
1820                             PerlMemShared_realloc( trie->trans,
1821                                                      transcount
1822                                                      * sizeof(reg_trie_trans) );
1823                         Zero( trie->trans + (transcount / 2), transcount / 2 , reg_trie_trans );
1824                     }
1825                     base = trie->uniquecharcount + tp - minid;
1826                     if ( maxid == minid ) {
1827                         U32 set = 0;
1828                         for ( ; zp < tp ; zp++ ) {
1829                             if ( ! trie->trans[ zp ].next ) {
1830                                 base = trie->uniquecharcount + zp - minid;
1831                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1832                                 trie->trans[ zp ].check = state;
1833                                 set = 1;
1834                                 break;
1835                             }
1836                         }
1837                         if ( !set ) {
1838                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1839                             trie->trans[ tp ].check = state;
1840                             tp++;
1841                             zp = tp;
1842                         }
1843                     } else {
1844                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1845                             const U32 tid = base -  trie->uniquecharcount + TRIE_LIST_ITEM( state, idx ).forid;
1846                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state, idx ).newstate;
1847                             trie->trans[ tid ].check = state;
1848                         }
1849                         tp += ( maxid - minid + 1 );
1850                     }
1851                     Safefree(trie->states[ state ].trans.list);
1852                 }
1853                 /*
1854                 DEBUG_TRIE_COMPILE_MORE_r(
1855                     PerlIO_printf( Perl_debug_log, " base: %d\n",base);
1856                 );
1857                 */
1858                 trie->states[ state ].trans.base=base;
1859             }
1860             trie->lasttrans = tp + 1;
1861         }
1862     } else {
1863         /*
1864            Second Pass -- Flat Table Representation.
1865
1866            we dont use the 0 slot of either trans[] or states[] so we add 1 to each.
1867            We know that we will need Charcount+1 trans at most to store the data
1868            (one row per char at worst case) So we preallocate both structures
1869            assuming worst case.
1870
1871            We then construct the trie using only the .next slots of the entry
1872            structs.
1873
1874            We use the .check field of the first entry of the node temporarily to
1875            make compression both faster and easier by keeping track of how many non
1876            zero fields are in the node.
1877
1878            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
1879            transition.
1880
1881            There are two terms at use here: state as a TRIE_NODEIDX() which is a
1882            number representing the first entry of the node, and state as a
1883            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1) and
1884            TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3) if there
1885            are 2 entrys per node. eg:
1886
1887              A B       A B
1888           1. 2 4    1. 3 7
1889           2. 0 3    3. 0 5
1890           3. 0 0    5. 0 0
1891           4. 0 0    7. 0 0
1892
1893            The table is internally in the right hand, idx form. However as we also
1894            have to deal with the states array which is indexed by nodenum we have to
1895            use TRIE_NODENUM() to convert.
1896
1897         */
1898         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log, 
1899             "%*sCompiling trie using table compiler\n",
1900             (int)depth * 2 + 2, ""));
1901
1902         trie->trans = (reg_trie_trans *)
1903             PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
1904                                   * trie->uniquecharcount + 1,
1905                                   sizeof(reg_trie_trans) );
1906         trie->states = (reg_trie_state *)
1907             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1908                                   sizeof(reg_trie_state) );
1909         next_alloc = trie->uniquecharcount + 1;
1910
1911
1912         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1913
1914             regnode * const noper   = NEXTOPER( cur );
1915             const U8 *uc     = (U8*)STRING( noper );
1916             const U8 * const e = uc + STR_LEN( noper );
1917
1918             U32 state        = 1;         /* required init */
1919
1920             U16 charid       = 0;         /* sanity init */
1921             U32 accept_state = 0;         /* sanity init */
1922             U8 *scan         = (U8*)NULL; /* sanity init */
1923
1924             STRLEN foldlen   = 0;         /* required init */
1925             U32 wordlen      = 0;         /* required init */
1926             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1927
1928             if ( OP(noper) != NOTHING ) {
1929                 for ( ; uc < e ; uc += len ) {
1930
1931                     TRIE_READ_CHAR;
1932
1933                     if ( uvc < 256 ) {
1934                         charid = trie->charmap[ uvc ];
1935                     } else {
1936                         SV* const * const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
1937                         charid = svpp ? (U16)SvIV(*svpp) : 0;
1938                     }
1939                     if ( charid ) {
1940                         charid--;
1941                         if ( !trie->trans[ state + charid ].next ) {
1942                             trie->trans[ state + charid ].next = next_alloc;
1943                             trie->trans[ state ].check++;
1944                             prev_states[TRIE_NODENUM(next_alloc)]
1945                                     = TRIE_NODENUM(state);
1946                             next_alloc += trie->uniquecharcount;
1947                         }
1948                         state = trie->trans[ state + charid ].next;
1949                     } else {
1950                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1951                     }
1952                     /* charid is now 0 if we dont know the char read, or nonzero if we do */
1953                 }
1954             }
1955             accept_state = TRIE_NODENUM( state );
1956             TRIE_HANDLE_WORD(accept_state);
1957
1958         } /* end second pass */
1959
1960         /* and now dump it out before we compress it */
1961         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
1962                                                           revcharmap,
1963                                                           next_alloc, depth+1));
1964
1965         {
1966         /*
1967            * Inplace compress the table.*
1968
1969            For sparse data sets the table constructed by the trie algorithm will
1970            be mostly 0/FAIL transitions or to put it another way mostly empty.
1971            (Note that leaf nodes will not contain any transitions.)
1972
1973            This algorithm compresses the tables by eliminating most such
1974            transitions, at the cost of a modest bit of extra work during lookup:
1975
1976            - Each states[] entry contains a .base field which indicates the
1977            index in the state[] array wheres its transition data is stored.
1978
1979            - If .base is 0 there are no valid transitions from that node.
1980
1981            - If .base is nonzero then charid is added to it to find an entry in
1982            the trans array.
1983
1984            -If trans[states[state].base+charid].check!=state then the
1985            transition is taken to be a 0/Fail transition. Thus if there are fail
1986            transitions at the front of the node then the .base offset will point
1987            somewhere inside the previous nodes data (or maybe even into a node
1988            even earlier), but the .check field determines if the transition is
1989            valid.
1990
1991            XXX - wrong maybe?
1992            The following process inplace converts the table to the compressed
1993            table: We first do not compress the root node 1,and mark all its
1994            .check pointers as 1 and set its .base pointer as 1 as well. This
1995            allows us to do a DFA construction from the compressed table later,
1996            and ensures that any .base pointers we calculate later are greater
1997            than 0.
1998
1999            - We set 'pos' to indicate the first entry of the second node.
2000
2001            - We then iterate over the columns of the node, finding the first and
2002            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
2003            and set the .check pointers accordingly, and advance pos
2004            appropriately and repreat for the next node. Note that when we copy
2005            the next pointers we have to convert them from the original
2006            NODEIDX form to NODENUM form as the former is not valid post
2007            compression.
2008
2009            - If a node has no transitions used we mark its base as 0 and do not
2010            advance the pos pointer.
2011
2012            - If a node only has one transition we use a second pointer into the
2013            structure to fill in allocated fail transitions from other states.
2014            This pointer is independent of the main pointer and scans forward
2015            looking for null transitions that are allocated to a state. When it
2016            finds one it writes the single transition into the "hole".  If the
2017            pointer doesnt find one the single transition is appended as normal.
2018
2019            - Once compressed we can Renew/realloc the structures to release the
2020            excess space.
2021
2022            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
2023            specifically Fig 3.47 and the associated pseudocode.
2024
2025            demq
2026         */
2027         const U32 laststate = TRIE_NODENUM( next_alloc );
2028         U32 state, charid;
2029         U32 pos = 0, zp=0;
2030         trie->statecount = laststate;
2031
2032         for ( state = 1 ; state < laststate ; state++ ) {
2033             U8 flag = 0;
2034             const U32 stateidx = TRIE_NODEIDX( state );
2035             const U32 o_used = trie->trans[ stateidx ].check;
2036             U32 used = trie->trans[ stateidx ].check;
2037             trie->trans[ stateidx ].check = 0;
2038
2039             for ( charid = 0 ; used && charid < trie->uniquecharcount ; charid++ ) {
2040                 if ( flag || trie->trans[ stateidx + charid ].next ) {
2041                     if ( trie->trans[ stateidx + charid ].next ) {
2042                         if (o_used == 1) {
2043                             for ( ; zp < pos ; zp++ ) {
2044                                 if ( ! trie->trans[ zp ].next ) {
2045                                     break;
2046                                 }
2047                             }
2048                             trie->states[ state ].trans.base = zp + trie->uniquecharcount - charid ;
2049                             trie->trans[ zp ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2050                             trie->trans[ zp ].check = state;
2051                             if ( ++zp > pos ) pos = zp;
2052                             break;
2053                         }
2054                         used--;
2055                     }
2056                     if ( !flag ) {
2057                         flag = 1;
2058                         trie->states[ state ].trans.base = pos + trie->uniquecharcount - charid ;
2059                     }
2060                     trie->trans[ pos ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2061                     trie->trans[ pos ].check = state;
2062                     pos++;
2063                 }
2064             }
2065         }
2066         trie->lasttrans = pos + 1;
2067         trie->states = (reg_trie_state *)
2068             PerlMemShared_realloc( trie->states, laststate
2069                                    * sizeof(reg_trie_state) );
2070         DEBUG_TRIE_COMPILE_MORE_r(
2071                 PerlIO_printf( Perl_debug_log,
2072                     "%*sAlloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n",
2073                     (int)depth * 2 + 2,"",
2074                     (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1 ),
2075                     (IV)next_alloc,
2076                     (IV)pos,
2077                     ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
2078             );
2079
2080         } /* end table compress */
2081     }
2082     DEBUG_TRIE_COMPILE_MORE_r(
2083             PerlIO_printf(Perl_debug_log, "%*sStatecount:%"UVxf" Lasttrans:%"UVxf"\n",
2084                 (int)depth * 2 + 2, "",
2085                 (UV)trie->statecount,
2086                 (UV)trie->lasttrans)
2087     );
2088     /* resize the trans array to remove unused space */
2089     trie->trans = (reg_trie_trans *)
2090         PerlMemShared_realloc( trie->trans, trie->lasttrans
2091                                * sizeof(reg_trie_trans) );
2092
2093     {   /* Modify the program and insert the new TRIE node */ 
2094         U8 nodetype =(U8)(flags & 0xFF);
2095         char *str=NULL;
2096         
2097 #ifdef DEBUGGING
2098         regnode *optimize = NULL;
2099 #ifdef RE_TRACK_PATTERN_OFFSETS
2100
2101         U32 mjd_offset = 0;
2102         U32 mjd_nodelen = 0;
2103 #endif /* RE_TRACK_PATTERN_OFFSETS */
2104 #endif /* DEBUGGING */
2105         /*
2106            This means we convert either the first branch or the first Exact,
2107            depending on whether the thing following (in 'last') is a branch
2108            or not and whther first is the startbranch (ie is it a sub part of
2109            the alternation or is it the whole thing.)
2110            Assuming its a sub part we convert the EXACT otherwise we convert
2111            the whole branch sequence, including the first.
2112          */
2113         /* Find the node we are going to overwrite */
2114         if ( first != startbranch || OP( last ) == BRANCH ) {
2115             /* branch sub-chain */
2116             NEXT_OFF( first ) = (U16)(last - first);
2117 #ifdef RE_TRACK_PATTERN_OFFSETS
2118             DEBUG_r({
2119                 mjd_offset= Node_Offset((convert));
2120                 mjd_nodelen= Node_Length((convert));
2121             });
2122 #endif
2123             /* whole branch chain */
2124         }
2125 #ifdef RE_TRACK_PATTERN_OFFSETS
2126         else {
2127             DEBUG_r({
2128                 const  regnode *nop = NEXTOPER( convert );
2129                 mjd_offset= Node_Offset((nop));
2130                 mjd_nodelen= Node_Length((nop));
2131             });
2132         }
2133         DEBUG_OPTIMISE_r(
2134             PerlIO_printf(Perl_debug_log, "%*sMJD offset:%"UVuf" MJD length:%"UVuf"\n",
2135                 (int)depth * 2 + 2, "",
2136                 (UV)mjd_offset, (UV)mjd_nodelen)
2137         );
2138 #endif
2139         /* But first we check to see if there is a common prefix we can 
2140            split out as an EXACT and put in front of the TRIE node.  */
2141         trie->startstate= 1;
2142         if ( trie->bitmap && !widecharmap && !trie->jump  ) {
2143             U32 state;
2144             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
2145                 U32 ofs = 0;
2146                 I32 idx = -1;
2147                 U32 count = 0;
2148                 const U32 base = trie->states[ state ].trans.base;
2149
2150                 if ( trie->states[state].wordnum )
2151                         count = 1;
2152
2153                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2154                     if ( ( base + ofs >= trie->uniquecharcount ) &&
2155                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
2156                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
2157                     {
2158                         if ( ++count > 1 ) {
2159                             SV **tmp = av_fetch( revcharmap, ofs, 0);
2160                             const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
2161                             if ( state == 1 ) break;
2162                             if ( count == 2 ) {
2163                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
2164                                 DEBUG_OPTIMISE_r(
2165                                     PerlIO_printf(Perl_debug_log,
2166                                         "%*sNew Start State=%"UVuf" Class: [",
2167                                         (int)depth * 2 + 2, "",
2168                                         (UV)state));
2169                                 if (idx >= 0) {
2170                                     SV ** const tmp = av_fetch( revcharmap, idx, 0);
2171                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
2172
2173                                     TRIE_BITMAP_SET(trie,*ch);
2174                                     if ( folder )
2175                                         TRIE_BITMAP_SET(trie, folder[ *ch ]);
2176                                     DEBUG_OPTIMISE_r(
2177                                         PerlIO_printf(Perl_debug_log, "%s", (char*)ch)
2178                                     );
2179                                 }
2180                             }
2181                             TRIE_BITMAP_SET(trie,*ch);
2182                             if ( folder )
2183                                 TRIE_BITMAP_SET(trie,folder[ *ch ]);
2184                             DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"%s", ch));
2185                         }
2186                         idx = ofs;
2187                     }
2188                 }
2189                 if ( count == 1 ) {
2190                     SV **tmp = av_fetch( revcharmap, idx, 0);
2191                     STRLEN len;
2192                     char *ch = SvPV( *tmp, len );
2193                     DEBUG_OPTIMISE_r({
2194                         SV *sv=sv_newmortal();
2195                         PerlIO_printf( Perl_debug_log,
2196                             "%*sPrefix State: %"UVuf" Idx:%"UVuf" Char='%s'\n",
2197                             (int)depth * 2 + 2, "",
2198                             (UV)state, (UV)idx, 
2199                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6, 
2200                                 PL_colors[0], PL_colors[1],
2201                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2202                                 PERL_PV_ESCAPE_FIRSTCHAR 
2203                             )
2204                         );
2205                     });
2206                     if ( state==1 ) {
2207                         OP( convert ) = nodetype;
2208                         str=STRING(convert);
2209                         STR_LEN(convert)=0;
2210                     }
2211                     STR_LEN(convert) += len;
2212                     while (len--)
2213                         *str++ = *ch++;
2214                 } else {
2215 #ifdef DEBUGGING            
2216                     if (state>1)
2217                         DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"]\n"));
2218 #endif
2219                     break;
2220                 }
2221             }
2222             trie->prefixlen = (state-1);
2223             if (str) {
2224                 regnode *n = convert+NODE_SZ_STR(convert);
2225                 NEXT_OFF(convert) = NODE_SZ_STR(convert);
2226                 trie->startstate = state;
2227                 trie->minlen -= (state - 1);
2228                 trie->maxlen -= (state - 1);
2229 #ifdef DEBUGGING
2230                /* At least the UNICOS C compiler choked on this
2231                 * being argument to DEBUG_r(), so let's just have
2232                 * it right here. */
2233                if (
2234 #ifdef PERL_EXT_RE_BUILD
2235                    1
2236 #else
2237                    DEBUG_r_TEST
2238 #endif
2239                    ) {
2240                    regnode *fix = convert;
2241                    U32 word = trie->wordcount;
2242                    mjd_nodelen++;
2243                    Set_Node_Offset_Length(convert, mjd_offset, state - 1);
2244                    while( ++fix < n ) {
2245                        Set_Node_Offset_Length(fix, 0, 0);
2246                    }
2247                    while (word--) {
2248                        SV ** const tmp = av_fetch( trie_words, word, 0 );
2249                        if (tmp) {
2250                            if ( STR_LEN(convert) <= SvCUR(*tmp) )
2251                                sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
2252                            else
2253                                sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
2254                        }
2255                    }
2256                }
2257 #endif
2258                 if (trie->maxlen) {
2259                     convert = n;
2260                 } else {
2261                     NEXT_OFF(convert) = (U16)(tail - convert);
2262                     DEBUG_r(optimize= n);
2263                 }
2264             }
2265         }
2266         if (!jumper) 
2267             jumper = last; 
2268         if ( trie->maxlen ) {
2269             NEXT_OFF( convert ) = (U16)(tail - convert);
2270             ARG_SET( convert, data_slot );
2271             /* Store the offset to the first unabsorbed branch in 
2272                jump[0], which is otherwise unused by the jump logic. 
2273                We use this when dumping a trie and during optimisation. */
2274             if (trie->jump) 
2275                 trie->jump[0] = (U16)(nextbranch - convert);
2276             
2277             /* If the start state is not accepting (meaning there is no empty string/NOTHING)
2278              *   and there is a bitmap
2279              *   and the first "jump target" node we found leaves enough room
2280              * then convert the TRIE node into a TRIEC node, with the bitmap
2281              * embedded inline in the opcode - this is hypothetically faster.
2282              */
2283             if ( !trie->states[trie->startstate].wordnum
2284                  && trie->bitmap
2285                  && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
2286             {
2287                 OP( convert ) = TRIEC;
2288                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
2289                 PerlMemShared_free(trie->bitmap);
2290                 trie->bitmap= NULL;
2291             } else 
2292                 OP( convert ) = TRIE;
2293
2294             /* store the type in the flags */
2295             convert->flags = nodetype;
2296             DEBUG_r({
2297             optimize = convert 
2298                       + NODE_STEP_REGNODE 
2299                       + regarglen[ OP( convert ) ];
2300             });
2301             /* XXX We really should free up the resource in trie now, 
2302                    as we won't use them - (which resources?) dmq */
2303         }
2304         /* needed for dumping*/
2305         DEBUG_r(if (optimize) {
2306             regnode *opt = convert;
2307
2308             while ( ++opt < optimize) {
2309                 Set_Node_Offset_Length(opt,0,0);
2310             }
2311             /* 
2312                 Try to clean up some of the debris left after the 
2313                 optimisation.
2314              */
2315             while( optimize < jumper ) {
2316                 mjd_nodelen += Node_Length((optimize));
2317                 OP( optimize ) = OPTIMIZED;
2318                 Set_Node_Offset_Length(optimize,0,0);
2319                 optimize++;
2320             }
2321             Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
2322         });
2323     } /* end node insert */
2324
2325     /*  Finish populating the prev field of the wordinfo array.  Walk back
2326      *  from each accept state until we find another accept state, and if
2327      *  so, point the first word's .prev field at the second word. If the
2328      *  second already has a .prev field set, stop now. This will be the
2329      *  case either if we've already processed that word's accept state,
2330      *  or that state had multiple words, and the overspill words were
2331      *  already linked up earlier.
2332      */
2333     {
2334         U16 word;
2335         U32 state;
2336         U16 prev;
2337
2338         for (word=1; word <= trie->wordcount; word++) {
2339             prev = 0;
2340             if (trie->wordinfo[word].prev)
2341                 continue;
2342             state = trie->wordinfo[word].accept;
2343             while (state) {
2344                 state = prev_states[state];
2345                 if (!state)
2346                     break;
2347                 prev = trie->states[state].wordnum;
2348                 if (prev)
2349                     break;
2350             }
2351             trie->wordinfo[word].prev = prev;
2352         }
2353         Safefree(prev_states);
2354     }
2355
2356
2357     /* and now dump out the compressed format */
2358     DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
2359
2360     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
2361 #ifdef DEBUGGING
2362     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
2363     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
2364 #else
2365     SvREFCNT_dec(revcharmap);
2366 #endif
2367     return trie->jump 
2368            ? MADE_JUMP_TRIE 
2369            : trie->startstate>1 
2370              ? MADE_EXACT_TRIE 
2371              : MADE_TRIE;
2372 }
2373
2374 STATIC void
2375 S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source,  regnode *stclass, U32 depth)
2376 {
2377 /* The Trie is constructed and compressed now so we can build a fail array if it's needed
2378
2379    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and 3.32 in the
2380    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi, Ullman 1985/88
2381    ISBN 0-201-10088-6
2382
2383    We find the fail state for each state in the trie, this state is the longest proper
2384    suffix of the current state's 'word' that is also a proper prefix of another word in our
2385    trie. State 1 represents the word '' and is thus the default fail state. This allows
2386    the DFA not to have to restart after its tried and failed a word at a given point, it
2387    simply continues as though it had been matching the other word in the first place.
2388    Consider
2389       'abcdgu'=~/abcdefg|cdgu/
2390    When we get to 'd' we are still matching the first word, we would encounter 'g' which would
2391    fail, which would bring us to the state representing 'd' in the second word where we would
2392    try 'g' and succeed, proceeding to match 'cdgu'.
2393  */
2394  /* add a fail transition */
2395     const U32 trie_offset = ARG(source);
2396     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
2397     U32 *q;
2398     const U32 ucharcount = trie->uniquecharcount;
2399     const U32 numstates = trie->statecount;
2400     const U32 ubound = trie->lasttrans + ucharcount;
2401     U32 q_read = 0;
2402     U32 q_write = 0;
2403     U32 charid;
2404     U32 base = trie->states[ 1 ].trans.base;
2405     U32 *fail;
2406     reg_ac_data *aho;
2407     const U32 data_slot = add_data( pRExC_state, 1, "T" );
2408     GET_RE_DEBUG_FLAGS_DECL;
2409
2410     PERL_ARGS_ASSERT_MAKE_TRIE_FAILTABLE;
2411 #ifndef DEBUGGING
2412     PERL_UNUSED_ARG(depth);
2413 #endif
2414
2415
2416     ARG_SET( stclass, data_slot );
2417     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
2418     RExC_rxi->data->data[ data_slot ] = (void*)aho;
2419     aho->trie=trie_offset;
2420     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
2421     Copy( trie->states, aho->states, numstates, reg_trie_state );
2422     Newxz( q, numstates, U32);
2423     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
2424     aho->refcount = 1;
2425     fail = aho->fail;
2426     /* initialize fail[0..1] to be 1 so that we always have
2427        a valid final fail state */
2428     fail[ 0 ] = fail[ 1 ] = 1;
2429
2430     for ( charid = 0; charid < ucharcount ; charid++ ) {
2431         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
2432         if ( newstate ) {
2433             q[ q_write ] = newstate;
2434             /* set to point at the root */
2435             fail[ q[ q_write++ ] ]=1;
2436         }
2437     }
2438     while ( q_read < q_write) {
2439         const U32 cur = q[ q_read++ % numstates ];
2440         base = trie->states[ cur ].trans.base;
2441
2442         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
2443             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
2444             if (ch_state) {
2445                 U32 fail_state = cur;
2446                 U32 fail_base;
2447                 do {
2448                     fail_state = fail[ fail_state ];
2449                     fail_base = aho->states[ fail_state ].trans.base;
2450                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
2451
2452                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
2453                 fail[ ch_state ] = fail_state;
2454                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
2455                 {
2456                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
2457                 }
2458                 q[ q_write++ % numstates] = ch_state;
2459             }
2460         }
2461     }
2462     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
2463        when we fail in state 1, this allows us to use the
2464        charclass scan to find a valid start char. This is based on the principle
2465        that theres a good chance the string being searched contains lots of stuff
2466        that cant be a start char.
2467      */
2468     fail[ 0 ] = fail[ 1 ] = 0;
2469     DEBUG_TRIE_COMPILE_r({
2470         PerlIO_printf(Perl_debug_log,
2471                       "%*sStclass Failtable (%"UVuf" states): 0", 
2472                       (int)(depth * 2), "", (UV)numstates
2473         );
2474         for( q_read=1; q_read<numstates; q_read++ ) {
2475             PerlIO_printf(Perl_debug_log, ", %"UVuf, (UV)fail[q_read]);
2476         }
2477         PerlIO_printf(Perl_debug_log, "\n");
2478     });
2479     Safefree(q);
2480     /*RExC_seen |= REG_SEEN_TRIEDFA;*/
2481 }
2482
2483
2484 /*
2485  * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2486  * These need to be revisited when a newer toolchain becomes available.
2487  */
2488 #if defined(__sparc64__) && defined(__GNUC__)
2489 #   if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2490 #       undef  SPARC64_GCC_WORKAROUND
2491 #       define SPARC64_GCC_WORKAROUND 1
2492 #   endif
2493 #endif
2494
2495 #define DEBUG_PEEP(str,scan,depth) \
2496     DEBUG_OPTIMISE_r({if (scan){ \
2497        SV * const mysv=sv_newmortal(); \
2498        regnode *Next = regnext(scan); \
2499        regprop(RExC_rx, mysv, scan); \
2500        PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s (%d)\n", \
2501        (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\
2502        Next ? (REG_NODE_NUM(Next)) : 0 ); \
2503    }});
2504
2505
2506
2507
2508
2509 #define JOIN_EXACT(scan,min,flags) \
2510     if (PL_regkind[OP(scan)] == EXACT) \
2511         join_exact(pRExC_state,(scan),(min),(flags),NULL,depth+1)
2512
2513 STATIC U32
2514 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, I32 *min, U32 flags,regnode *val, U32 depth) {
2515     /* Merge several consecutive EXACTish nodes into one. */
2516     regnode *n = regnext(scan);
2517     U32 stringok = 1;
2518     regnode *next = scan + NODE_SZ_STR(scan);
2519     U32 merged = 0;
2520     U32 stopnow = 0;
2521 #ifdef DEBUGGING
2522     regnode *stop = scan;
2523     GET_RE_DEBUG_FLAGS_DECL;
2524 #else
2525     PERL_UNUSED_ARG(depth);
2526 #endif
2527
2528     PERL_ARGS_ASSERT_JOIN_EXACT;
2529 #ifndef EXPERIMENTAL_INPLACESCAN
2530     PERL_UNUSED_ARG(flags);
2531     PERL_UNUSED_ARG(val);
2532 #endif
2533     DEBUG_PEEP("join",scan,depth);
2534     
2535     /* Skip NOTHING, merge EXACT*. */
2536     while (n &&
2537            ( PL_regkind[OP(n)] == NOTHING ||
2538              (stringok && (OP(n) == OP(scan))))
2539            && NEXT_OFF(n)
2540            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX) {
2541         
2542         if (OP(n) == TAIL || n > next)
2543             stringok = 0;
2544         if (PL_regkind[OP(n)] == NOTHING) {
2545             DEBUG_PEEP("skip:",n,depth);
2546             NEXT_OFF(scan) += NEXT_OFF(n);
2547             next = n + NODE_STEP_REGNODE;
2548 #ifdef DEBUGGING
2549             if (stringok)
2550                 stop = n;
2551 #endif
2552             n = regnext(n);
2553         }
2554         else if (stringok) {
2555             const unsigned int oldl = STR_LEN(scan);
2556             regnode * const nnext = regnext(n);
2557             
2558             DEBUG_PEEP("merg",n,depth);
2559             
2560             merged++;
2561             if (oldl + STR_LEN(n) > U8_MAX)
2562                 break;
2563             NEXT_OFF(scan) += NEXT_OFF(n);
2564             STR_LEN(scan) += STR_LEN(n);
2565             next = n + NODE_SZ_STR(n);
2566             /* Now we can overwrite *n : */
2567             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
2568 #ifdef DEBUGGING
2569             stop = next - 1;
2570 #endif
2571             n = nnext;
2572             if (stopnow) break;
2573         }
2574
2575 #ifdef EXPERIMENTAL_INPLACESCAN
2576         if (flags && !NEXT_OFF(n)) {
2577             DEBUG_PEEP("atch", val, depth);
2578             if (reg_off_by_arg[OP(n)]) {
2579                 ARG_SET(n, val - n);
2580             }
2581             else {
2582                 NEXT_OFF(n) = val - n;
2583             }
2584             stopnow = 1;
2585         }
2586 #endif
2587     }
2588 #define GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS   0x0390
2589 #define IOTA_D_T        GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS
2590 #define GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS     0x03B0
2591 #define UPSILON_D_T     GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS
2592
2593     if (UTF
2594         && ( OP(scan) == EXACTF || OP(scan) == EXACTFU || OP(scan) == EXACTFA)
2595         && ( STR_LEN(scan) >= 6 ) )
2596     {
2597     /*
2598     Two problematic code points in Unicode casefolding of EXACT nodes:
2599     
2600     U+0390 - GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
2601     U+03B0 - GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
2602     
2603     which casefold to
2604     
2605     Unicode                      UTF-8
2606     
2607     U+03B9 U+0308 U+0301         0xCE 0xB9 0xCC 0x88 0xCC 0x81
2608     U+03C5 U+0308 U+0301         0xCF 0x85 0xCC 0x88 0xCC 0x81
2609     
2610     This means that in case-insensitive matching (or "loose matching",
2611     as Unicode calls it), an EXACTF of length six (the UTF-8 encoded byte
2612     length of the above casefolded versions) can match a target string
2613     of length two (the byte length of UTF-8 encoded U+0390 or U+03B0).
2614     This would rather mess up the minimum length computation.
2615     
2616     What we'll do is to look for the tail four bytes, and then peek
2617     at the preceding two bytes to see whether we need to decrease
2618     the minimum length by four (six minus two).
2619     
2620     Thanks to the design of UTF-8, there cannot be false matches:
2621     A sequence of valid UTF-8 bytes cannot be a subsequence of
2622     another valid sequence of UTF-8 bytes.
2623     
2624     */
2625          char * const s0 = STRING(scan), *s, *t;
2626          char * const s1 = s0 + STR_LEN(scan) - 1;
2627          char * const s2 = s1 - 4;
2628 #ifdef EBCDIC /* RD tunifold greek 0390 and 03B0 */
2629          const char t0[] = "\xaf\x49\xaf\x42";
2630 #else
2631          const char t0[] = "\xcc\x88\xcc\x81";
2632 #endif
2633          const char * const t1 = t0 + 3;
2634     
2635          for (s = s0 + 2;
2636               s < s2 && (t = ninstr(s, s1, t0, t1));
2637               s = t + 4) {
2638 #ifdef EBCDIC
2639               if (((U8)t[-1] == 0x68 && (U8)t[-2] == 0xB4) ||
2640                   ((U8)t[-1] == 0x46 && (U8)t[-2] == 0xB5))
2641 #else
2642               if (((U8)t[-1] == 0xB9 && (U8)t[-2] == 0xCE) ||
2643                   ((U8)t[-1] == 0x85 && (U8)t[-2] == 0xCF))
2644 #endif
2645                    *min -= 4;
2646          }
2647     }
2648     
2649 #ifdef DEBUGGING
2650     /* Allow dumping */
2651     n = scan + NODE_SZ_STR(scan);
2652     while (n <= stop) {
2653         if (PL_regkind[OP(n)] != NOTHING || OP(n) == NOTHING) {
2654             OP(n) = OPTIMIZED;
2655             NEXT_OFF(n) = 0;
2656         }
2657         n++;
2658     }
2659 #endif
2660     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
2661     return stopnow;
2662 }
2663
2664 /* REx optimizer.  Converts nodes into quicker variants "in place".
2665    Finds fixed substrings.  */
2666
2667 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
2668    to the position after last scanned or to NULL. */
2669
2670 #define INIT_AND_WITHP \
2671     assert(!and_withp); \
2672     Newx(and_withp,1,struct regnode_charclass_class); \
2673     SAVEFREEPV(and_withp)
2674
2675 /* this is a chain of data about sub patterns we are processing that
2676    need to be handled separately/specially in study_chunk. Its so
2677    we can simulate recursion without losing state.  */
2678 struct scan_frame;
2679 typedef struct scan_frame {
2680     regnode *last;  /* last node to process in this frame */
2681     regnode *next;  /* next node to process when last is reached */
2682     struct scan_frame *prev; /*previous frame*/
2683     I32 stop; /* what stopparen do we use */
2684 } scan_frame;
2685
2686
2687 #define SCAN_COMMIT(s, data, m) scan_commit(s, data, m, is_inf)
2688
2689 #define CASE_SYNST_FNC(nAmE)                                       \
2690 case nAmE:                                                         \
2691     if (flags & SCF_DO_STCLASS_AND) {                              \
2692             for (value = 0; value < 256; value++)                  \
2693                 if (!is_ ## nAmE ## _cp(value))                       \
2694                     ANYOF_BITMAP_CLEAR(data->start_class, value);  \
2695     }                                                              \
2696     else {                                                         \
2697             for (value = 0; value < 256; value++)                  \
2698                 if (is_ ## nAmE ## _cp(value))                        \
2699                     ANYOF_BITMAP_SET(data->start_class, value);    \
2700     }                                                              \
2701     break;                                                         \
2702 case N ## nAmE:                                                    \
2703     if (flags & SCF_DO_STCLASS_AND) {                              \
2704             for (value = 0; value < 256; value++)                   \
2705                 if (is_ ## nAmE ## _cp(value))                         \
2706                     ANYOF_BITMAP_CLEAR(data->start_class, value);   \
2707     }                                                               \
2708     else {                                                          \
2709             for (value = 0; value < 256; value++)                   \
2710                 if (!is_ ## nAmE ## _cp(value))                        \
2711                     ANYOF_BITMAP_SET(data->start_class, value);     \
2712     }                                                               \
2713     break
2714
2715
2716
2717 STATIC I32
2718 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
2719                         I32 *minlenp, I32 *deltap,
2720                         regnode *last,
2721                         scan_data_t *data,
2722                         I32 stopparen,
2723                         U8* recursed,
2724                         struct regnode_charclass_class *and_withp,
2725                         U32 flags, U32 depth)
2726                         /* scanp: Start here (read-write). */
2727                         /* deltap: Write maxlen-minlen here. */
2728                         /* last: Stop before this one. */
2729                         /* data: string data about the pattern */
2730                         /* stopparen: treat close N as END */
2731                         /* recursed: which subroutines have we recursed into */
2732                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
2733 {
2734     dVAR;
2735     I32 min = 0, pars = 0, code;
2736     regnode *scan = *scanp, *next;
2737     I32 delta = 0;
2738     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
2739     int is_inf_internal = 0;            /* The studied chunk is infinite */
2740     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
2741     scan_data_t data_fake;
2742     SV *re_trie_maxbuff = NULL;
2743     regnode *first_non_open = scan;
2744     I32 stopmin = I32_MAX;
2745     scan_frame *frame = NULL;
2746     GET_RE_DEBUG_FLAGS_DECL;
2747
2748     PERL_ARGS_ASSERT_STUDY_CHUNK;
2749
2750 #ifdef DEBUGGING
2751     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
2752 #endif
2753
2754     if ( depth == 0 ) {
2755         while (first_non_open && OP(first_non_open) == OPEN)
2756             first_non_open=regnext(first_non_open);
2757     }
2758
2759
2760   fake_study_recurse:
2761     while ( scan && OP(scan) != END && scan < last ){
2762         /* Peephole optimizer: */
2763         DEBUG_STUDYDATA("Peep:", data,depth);
2764         DEBUG_PEEP("Peep",scan,depth);
2765         JOIN_EXACT(scan,&min,0);
2766
2767         /* Follow the next-chain of the current node and optimize
2768            away all the NOTHINGs from it.  */
2769         if (OP(scan) != CURLYX) {
2770             const int max = (reg_off_by_arg[OP(scan)]
2771                        ? I32_MAX
2772                        /* I32 may be smaller than U16 on CRAYs! */
2773                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
2774             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
2775             int noff;
2776             regnode *n = scan;
2777         
2778             /* Skip NOTHING and LONGJMP. */
2779             while ((n = regnext(n))
2780                    && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
2781                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
2782                    && off + noff < max)
2783                 off += noff;
2784             if (reg_off_by_arg[OP(scan)])
2785                 ARG(scan) = off;
2786             else
2787                 NEXT_OFF(scan) = off;
2788         }
2789
2790
2791
2792         /* The principal pseudo-switch.  Cannot be a switch, since we
2793            look into several different things.  */
2794         if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
2795                    || OP(scan) == IFTHEN) {
2796             next = regnext(scan);
2797             code = OP(scan);
2798             /* demq: the op(next)==code check is to see if we have "branch-branch" AFAICT */
2799         
2800             if (OP(next) == code || code == IFTHEN) {
2801                 /* NOTE - There is similar code to this block below for handling
2802                    TRIE nodes on a re-study.  If you change stuff here check there
2803                    too. */
2804                 I32 max1 = 0, min1 = I32_MAX, num = 0;
2805                 struct regnode_charclass_class accum;
2806                 regnode * const startbranch=scan;
2807                 
2808                 if (flags & SCF_DO_SUBSTR)
2809                     SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot merge strings after this. */
2810                 if (flags & SCF_DO_STCLASS)
2811                     cl_init_zero(pRExC_state, &accum);
2812
2813                 while (OP(scan) == code) {
2814                     I32 deltanext, minnext, f = 0, fake;
2815                     struct regnode_charclass_class this_class;
2816
2817                     num++;
2818                     data_fake.flags = 0;
2819                     if (data) {
2820                         data_fake.whilem_c = data->whilem_c;
2821                         data_fake.last_closep = data->last_closep;
2822                     }
2823                     else
2824                         data_fake.last_closep = &fake;
2825
2826                     data_fake.pos_delta = delta;
2827                     next = regnext(scan);
2828                     scan = NEXTOPER(scan);
2829                     if (code != BRANCH)
2830                         scan = NEXTOPER(scan);
2831                     if (flags & SCF_DO_STCLASS) {
2832                         cl_init(pRExC_state, &this_class);
2833                         data_fake.start_class = &this_class;
2834                         f = SCF_DO_STCLASS_AND;
2835                     }
2836                     if (flags & SCF_WHILEM_VISITED_POS)
2837                         f |= SCF_WHILEM_VISITED_POS;
2838
2839                     /* we suppose the run is continuous, last=next...*/
2840                     minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
2841                                           next, &data_fake,
2842                                           stopparen, recursed, NULL, f,depth+1);
2843                     if (min1 > minnext)
2844                         min1 = minnext;
2845                     if (max1 < minnext + deltanext)
2846                         max1 = minnext + deltanext;
2847                     if (deltanext == I32_MAX)
2848                         is_inf = is_inf_internal = 1;
2849                     scan = next;
2850                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
2851                         pars++;
2852                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
2853                         if ( stopmin > minnext) 
2854                             stopmin = min + min1;
2855                         flags &= ~SCF_DO_SUBSTR;
2856                         if (data)
2857                             data->flags |= SCF_SEEN_ACCEPT;
2858                     }
2859                     if (data) {
2860                         if (data_fake.flags & SF_HAS_EVAL)
2861                             data->flags |= SF_HAS_EVAL;
2862                         data->whilem_c = data_fake.whilem_c;
2863                     }
2864                     if (flags & SCF_DO_STCLASS)
2865                         cl_or(pRExC_state, &accum, &this_class);
2866                 }
2867                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
2868                     min1 = 0;
2869                 if (flags & SCF_DO_SUBSTR) {
2870                     data->pos_min += min1;
2871                     data->pos_delta += max1 - min1;
2872                     if (max1 != min1 || is_inf)
2873                         data->longest = &(data->longest_float);
2874                 }
2875                 min += min1;
2876                 delta += max1 - min1;
2877                 if (flags & SCF_DO_STCLASS_OR) {
2878                     cl_or(pRExC_state, data->start_class, &accum);
2879                     if (min1) {
2880                         cl_and(data->start_class, and_withp);
2881                         flags &= ~SCF_DO_STCLASS;
2882                     }
2883                 }
2884                 else if (flags & SCF_DO_STCLASS_AND) {
2885                     if (min1) {
2886                         cl_and(data->start_class, &accum);
2887                         flags &= ~SCF_DO_STCLASS;
2888                     }
2889                     else {
2890                         /* Switch to OR mode: cache the old value of
2891                          * data->start_class */
2892                         INIT_AND_WITHP;
2893                         StructCopy(data->start_class, and_withp,
2894                                    struct regnode_charclass_class);
2895                         flags &= ~SCF_DO_STCLASS_AND;
2896                         StructCopy(&accum, data->start_class,
2897                                    struct regnode_charclass_class);
2898                         flags |= SCF_DO_STCLASS_OR;
2899                         data->start_class->flags |= ANYOF_EOS;
2900                     }
2901                 }
2902
2903                 if (PERL_ENABLE_TRIE_OPTIMISATION && OP( startbranch ) == BRANCH ) {
2904                 /* demq.
2905
2906                    Assuming this was/is a branch we are dealing with: 'scan' now
2907                    points at the item that follows the branch sequence, whatever
2908                    it is. We now start at the beginning of the sequence and look
2909                    for subsequences of
2910
2911                    BRANCH->EXACT=>x1
2912                    BRANCH->EXACT=>x2
2913                    tail
2914
2915                    which would be constructed from a pattern like /A|LIST|OF|WORDS/
2916
2917                    If we can find such a subsequence we need to turn the first
2918                    element into a trie and then add the subsequent branch exact
2919                    strings to the trie.
2920
2921                    We have two cases
2922
2923                      1. patterns where the whole set of branches can be converted. 
2924
2925                      2. patterns where only a subset can be converted.
2926
2927                    In case 1 we can replace the whole set with a single regop
2928                    for the trie. In case 2 we need to keep the start and end
2929                    branches so
2930
2931                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
2932                      becomes BRANCH TRIE; BRANCH X;
2933
2934                   There is an additional case, that being where there is a 
2935                   common prefix, which gets split out into an EXACT like node
2936                   preceding the TRIE node.
2937
2938                   If x(1..n)==tail then we can do a simple trie, if not we make
2939                   a "jump" trie, such that when we match the appropriate word
2940                   we "jump" to the appropriate tail node. Essentially we turn
2941                   a nested if into a case structure of sorts.
2942
2943                 */
2944                 
2945                     int made=0;
2946                     if (!re_trie_maxbuff) {
2947                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
2948                         if (!SvIOK(re_trie_maxbuff))
2949                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
2950                     }
2951                     if ( SvIV(re_trie_maxbuff)>=0  ) {
2952                         regnode *cur;
2953                         regnode *first = (regnode *)NULL;
2954                         regnode *last = (regnode *)NULL;
2955                         regnode *tail = scan;
2956                         U8 optype = 0;
2957                         U32 count=0;
2958
2959 #ifdef DEBUGGING
2960                         SV * const mysv = sv_newmortal();       /* for dumping */
2961 #endif
2962                         /* var tail is used because there may be a TAIL
2963                            regop in the way. Ie, the exacts will point to the
2964                            thing following the TAIL, but the last branch will
2965                            point at the TAIL. So we advance tail. If we
2966                            have nested (?:) we may have to move through several
2967                            tails.
2968                          */
2969
2970                         while ( OP( tail ) == TAIL ) {
2971                             /* this is the TAIL generated by (?:) */
2972                             tail = regnext( tail );
2973                         }
2974
2975                         
2976                         DEBUG_OPTIMISE_r({
2977                             regprop(RExC_rx, mysv, tail );
2978                             PerlIO_printf( Perl_debug_log, "%*s%s%s\n",
2979                                 (int)depth * 2 + 2, "", 
2980                                 "Looking for TRIE'able sequences. Tail node is: ", 
2981                                 SvPV_nolen_const( mysv )
2982                             );
2983                         });
2984                         
2985                         /*
2986
2987                            step through the branches, cur represents each
2988                            branch, noper is the first thing to be matched
2989                            as part of that branch and noper_next is the
2990                            regnext() of that node. if noper is an EXACT
2991                            and noper_next is the same as scan (our current
2992                            position in the regex) then the EXACT branch is
2993                            a possible optimization target. Once we have
2994                            two or more consecutive such branches we can
2995                            create a trie of the EXACT's contents and stich
2996                            it in place. If the sequence represents all of
2997                            the branches we eliminate the whole thing and
2998                            replace it with a single TRIE. If it is a
2999                            subsequence then we need to stitch it in. This
3000                            means the first branch has to remain, and needs
3001                            to be repointed at the item on the branch chain
3002                            following the last branch optimized. This could
3003                            be either a BRANCH, in which case the
3004                            subsequence is internal, or it could be the
3005                            item following the branch sequence in which
3006                            case the subsequence is at the end.
3007
3008                         */
3009
3010                         /* dont use tail as the end marker for this traverse */
3011                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
3012                             regnode * const noper = NEXTOPER( cur );
3013 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
3014                             regnode * const noper_next = regnext( noper );
3015 #endif
3016
3017                             DEBUG_OPTIMISE_r({
3018                                 regprop(RExC_rx, mysv, cur);
3019                                 PerlIO_printf( Perl_debug_log, "%*s- %s (%d)",
3020                                    (int)depth * 2 + 2,"", SvPV_nolen_const( mysv ), REG_NODE_NUM(cur) );
3021
3022                                 regprop(RExC_rx, mysv, noper);
3023                                 PerlIO_printf( Perl_debug_log, " -> %s",
3024                                     SvPV_nolen_const(mysv));
3025
3026                                 if ( noper_next ) {
3027                                   regprop(RExC_rx, mysv, noper_next );
3028                                   PerlIO_printf( Perl_debug_log,"\t=> %s\t",
3029                                     SvPV_nolen_const(mysv));
3030                                 }
3031                                 PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d)\n",
3032                                    REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur) );
3033                             });
3034                             if ( (((first && optype!=NOTHING) ? OP( noper ) == optype
3035                                          : PL_regkind[ OP( noper ) ] == EXACT )
3036                                   || OP(noper) == NOTHING )
3037 #ifdef NOJUMPTRIE
3038                                   && noper_next == tail
3039 #endif
3040                                   && count < U16_MAX)
3041                             {
3042                                 count++;
3043                                 if ( !first || optype == NOTHING ) {
3044                                     if (!first) first = cur;
3045                                     optype = OP( noper );
3046                                 } else {
3047                                     last = cur;
3048                                 }
3049                             } else {
3050 /* 
3051     Currently the trie logic handles case insensitive matching properly only
3052     when the pattern is UTF-8 and the node is EXACTFU (thus forcing unicode
3053     semantics).
3054
3055     If/when this is fixed the following define can be swapped
3056     in below to fully enable trie logic.
3057
3058 #define TRIE_TYPE_IS_SAFE 1
3059
3060 */
3061 #define TRIE_TYPE_IS_SAFE ((UTF && optype == EXACTFU) || optype==EXACT)
3062
3063                                 if ( last && TRIE_TYPE_IS_SAFE ) {
3064                                     make_trie( pRExC_state, 
3065                                             startbranch, first, cur, tail, count, 
3066                                             optype, depth+1 );
3067                                 }
3068                                 if ( PL_regkind[ OP( noper ) ] == EXACT
3069 #ifdef NOJUMPTRIE
3070                                      && noper_next == tail
3071 #endif
3072                                 ){
3073                                     count = 1;
3074                                     first = cur;
3075                                     optype = OP( noper );
3076                                 } else {
3077                                     count = 0;
3078                                     first = NULL;
3079                                     optype = 0;
3080                                 }
3081                                 last = NULL;
3082                             }
3083                         }
3084                         DEBUG_OPTIMISE_r({
3085                             regprop(RExC_rx, mysv, cur);
3086                             PerlIO_printf( Perl_debug_log,
3087                               "%*s- %s (%d) <SCAN FINISHED>\n", (int)depth * 2 + 2,
3088                               "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
3089
3090                         });
3091                         
3092                         if ( last && TRIE_TYPE_IS_SAFE ) {
3093                             made= make_trie( pRExC_state, startbranch, first, scan, tail, count, optype, depth+1 );
3094 #ifdef TRIE_STUDY_OPT   
3095                             if ( ((made == MADE_EXACT_TRIE && 
3096                                  startbranch == first) 
3097                                  || ( first_non_open == first )) && 
3098                                  depth==0 ) {
3099                                 flags |= SCF_TRIE_RESTUDY;
3100                                 if ( startbranch == first 
3101                                      && scan == tail ) 
3102                                 {
3103                                     RExC_seen &=~REG_TOP_LEVEL_BRANCHES;
3104                                 }
3105                             }
3106 #endif
3107                         }
3108                     }
3109                     
3110                 } /* do trie */
3111                 
3112             }
3113             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
3114                 scan = NEXTOPER(NEXTOPER(scan));
3115             } else                      /* single branch is optimized. */
3116                 scan = NEXTOPER(scan);
3117             continue;
3118         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB || OP(scan) == GOSTART) {
3119             scan_frame *newframe = NULL;
3120             I32 paren;
3121             regnode *start;
3122             regnode *end;
3123
3124             if (OP(scan) != SUSPEND) {
3125             /* set the pointer */
3126                 if (OP(scan) == GOSUB) {
3127                     paren = ARG(scan);
3128                     RExC_recurse[ARG2L(scan)] = scan;
3129                     start = RExC_open_parens[paren-1];
3130                     end   = RExC_close_parens[paren-1];
3131                 } else {
3132                     paren = 0;
3133                     start = RExC_rxi->program + 1;
3134                     end   = RExC_opend;
3135                 }
3136                 if (!recursed) {
3137                     Newxz(recursed, (((RExC_npar)>>3) +1), U8);
3138                     SAVEFREEPV(recursed);
3139                 }
3140                 if (!PAREN_TEST(recursed,paren+1)) {
3141                     PAREN_SET(recursed,paren+1);
3142                     Newx(newframe,1,scan_frame);
3143                 } else {
3144                     if (flags & SCF_DO_SUBSTR) {
3145                         SCAN_COMMIT(pRExC_state,data,minlenp);
3146                         data->longest = &(data->longest_float);
3147                     }
3148                     is_inf = is_inf_internal = 1;
3149                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3150                         cl_anything(pRExC_state, data->start_class);
3151                     flags &= ~SCF_DO_STCLASS;
3152                 }
3153             } else {
3154                 Newx(newframe,1,scan_frame);
3155                 paren = stopparen;
3156                 start = scan+2;
3157                 end = regnext(scan);
3158             }
3159             if (newframe) {
3160                 assert(start);
3161                 assert(end);
3162                 SAVEFREEPV(newframe);
3163                 newframe->next = regnext(scan);
3164                 newframe->last = last;
3165                 newframe->stop = stopparen;
3166                 newframe->prev = frame;
3167
3168                 frame = newframe;
3169                 scan =  start;
3170                 stopparen = paren;
3171                 last = end;
3172
3173                 continue;
3174             }
3175         }
3176         else if (OP(scan) == EXACT) {
3177             I32 l = STR_LEN(scan);
3178             UV uc;
3179             if (UTF) {
3180                 const U8 * const s = (U8*)STRING(scan);
3181                 l = utf8_length(s, s + l);
3182                 uc = utf8_to_uvchr(s, NULL);
3183             } else {
3184                 uc = *((U8*)STRING(scan));
3185             }
3186             min += l;
3187             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
3188                 /* The code below prefers earlier match for fixed
3189                    offset, later match for variable offset.  */
3190                 if (data->last_end == -1) { /* Update the start info. */
3191                     data->last_start_min = data->pos_min;
3192                     data->last_start_max = is_inf
3193                         ? I32_MAX : data->pos_min + data->pos_delta;
3194                 }
3195                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
3196                 if (UTF)
3197                     SvUTF8_on(data->last_found);
3198                 {
3199                     SV * const sv = data->last_found;
3200                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3201                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
3202                     if (mg && mg->mg_len >= 0)
3203                         mg->mg_len += utf8_length((U8*)STRING(scan),
3204                                                   (U8*)STRING(scan)+STR_LEN(scan));
3205                 }
3206                 data->last_end = data->pos_min + l;
3207                 data->pos_min += l; /* As in the first entry. */
3208                 data->flags &= ~SF_BEFORE_EOL;
3209             }
3210             if (flags & SCF_DO_STCLASS_AND) {
3211                 /* Check whether it is compatible with what we know already! */
3212                 int compat = 1;
3213
3214
3215                 /* If compatible, we or it in below.  It is compatible if is
3216                  * in the bitmp and either 1) its bit or its fold is set, or 2)
3217                  * it's for a locale.  Even if there isn't unicode semantics
3218                  * here, at runtime there may be because of matching against a
3219                  * utf8 string, so accept a possible false positive for
3220                  * latin1-range folds */
3221                 if (uc >= 0x100 ||
3222                     (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3223                     && !ANYOF_BITMAP_TEST(data->start_class, uc)
3224                     && (!(data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD)
3225                         || !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3226                     )
3227                 {
3228                     compat = 0;
3229                 }
3230                 ANYOF_CLASS_ZERO(data->start_class);
3231                 ANYOF_BITMAP_ZERO(data->start_class);
3232                 if (compat)
3233                     ANYOF_BITMAP_SET(data->start_class, uc);
3234                 else if (uc >= 0x100) {
3235                     int i;
3236
3237                     /* Some Unicode code points fold to the Latin1 range; as
3238                      * XXX temporary code, instead of figuring out if this is
3239                      * one, just assume it is and set all the start class bits
3240                      * that could be some such above 255 code point's fold
3241                      * which will generate fals positives.  As the code
3242                      * elsewhere that does compute the fold settles down, it
3243                      * can be extracted out and re-used here */
3244                     for (i = 0; i < 256; i++){
3245                         if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
3246                             ANYOF_BITMAP_SET(data->start_class, i);
3247                         }
3248                     }
3249                 }
3250                 data->start_class->flags &= ~ANYOF_EOS;
3251                 if (uc < 0x100)
3252                   data->start_class->flags &= ~ANYOF_UNICODE_ALL;
3253             }
3254             else if (flags & SCF_DO_STCLASS_OR) {
3255                 /* false positive possible if the class is case-folded */
3256                 if (uc < 0x100)
3257                     ANYOF_BITMAP_SET(data->start_class, uc);
3258                 else
3259                     data->start_class->flags |= ANYOF_UNICODE_ALL;
3260                 data->start_class->flags &= ~ANYOF_EOS;
3261                 cl_and(data->start_class, and_withp);
3262             }
3263             flags &= ~SCF_DO_STCLASS;
3264         }
3265         else if (PL_regkind[OP(scan)] == EXACT) { /* But OP != EXACT! */
3266             I32 l = STR_LEN(scan);
3267             UV uc = *((U8*)STRING(scan));
3268
3269             /* Search for fixed substrings supports EXACT only. */
3270             if (flags & SCF_DO_SUBSTR) {
3271                 assert(data);
3272                 SCAN_COMMIT(pRExC_state, data, minlenp);
3273             }
3274             if (UTF) {
3275                 const U8 * const s = (U8 *)STRING(scan);
3276                 l = utf8_length(s, s + l);
3277                 uc = utf8_to_uvchr(s, NULL);
3278             }
3279             min += l;
3280             if (flags & SCF_DO_SUBSTR)
3281                 data->pos_min += l;
3282             if (flags & SCF_DO_STCLASS_AND) {
3283                 /* Check whether it is compatible with what we know already! */
3284                 int compat = 1;
3285                 if (uc >= 0x100 ||
3286                  (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3287                   && !ANYOF_BITMAP_TEST(data->start_class, uc)
3288                   && !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3289                 {
3290                     compat = 0;
3291                 }
3292                 ANYOF_CLASS_ZERO(data->start_class);
3293                 ANYOF_BITMAP_ZERO(data->start_class);
3294                 if (compat) {
3295                     ANYOF_BITMAP_SET(data->start_class, uc);
3296                     data->start_class->flags &= ~ANYOF_EOS;
3297                     data->start_class->flags |= ANYOF_LOC_NONBITMAP_FOLD;
3298                     if (OP(scan) == EXACTFL) {
3299                         /* XXX This set is probably no longer necessary, and
3300                          * probably wrong as LOCALE now is on in the initial
3301                          * state */
3302                         data->start_class->flags |= ANYOF_LOCALE;
3303                     }
3304                     else {
3305
3306                         /* Also set the other member of the fold pair.  In case
3307                          * that unicode semantics is called for at runtime, use
3308                          * the full latin1 fold.  (Can't do this for locale,
3309                          * because not known until runtime */
3310                         ANYOF_BITMAP_SET(data->start_class, PL_fold_latin1[uc]);
3311                     }
3312                 }
3313                 else if (uc >= 0x100) {
3314                     int i;
3315                     for (i = 0; i < 256; i++){
3316                         if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
3317                             ANYOF_BITMAP_SET(data->start_class, i);
3318                         }
3319                     }
3320                 }
3321             }
3322             else if (flags & SCF_DO_STCLASS_OR) {
3323                 if (data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD) {
3324                     /* false positive possible if the class is case-folded.
3325                        Assume that the locale settings are the same... */
3326                     if (uc < 0x100) {
3327                         ANYOF_BITMAP_SET(data->start_class, uc);
3328                         if (OP(scan) != EXACTFL) {
3329
3330                             /* And set the other member of the fold pair, but
3331                              * can't do that in locale because not known until
3332                              * run-time */
3333                             ANYOF_BITMAP_SET(data->start_class,
3334                                              PL_fold_latin1[uc]);
3335                         }
3336                     }
3337                     data->start_class->flags &= ~ANYOF_EOS;
3338                 }
3339                 cl_and(data->start_class, and_withp);
3340             }
3341             flags &= ~SCF_DO_STCLASS;
3342         }
3343         else if (REGNODE_VARIES(OP(scan))) {
3344             I32 mincount, maxcount, minnext, deltanext, fl = 0;
3345             I32 f = flags, pos_before = 0;
3346             regnode * const oscan = scan;
3347             struct regnode_charclass_class this_class;
3348             struct regnode_charclass_class *oclass = NULL;
3349             I32 next_is_eval = 0;
3350
3351             switch (PL_regkind[OP(scan)]) {
3352             case WHILEM:                /* End of (?:...)* . */
3353                 scan = NEXTOPER(scan);
3354                 goto finish;
3355             case PLUS:
3356                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
3357                     next = NEXTOPER(scan);
3358                     if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
3359                         mincount = 1;
3360                         maxcount = REG_INFTY;
3361                         next = regnext(scan);
3362                         scan = NEXTOPER(scan);
3363                         goto do_curly;
3364                     }
3365                 }
3366                 if (flags & SCF_DO_SUBSTR)
3367                     data->pos_min++;
3368                 min++;
3369                 /* Fall through. */
3370             case STAR:
3371                 if (flags & SCF_DO_STCLASS) {
3372                     mincount = 0;
3373                     maxcount = REG_INFTY;
3374                     next = regnext(scan);
3375                     scan = NEXTOPER(scan);
3376                     goto do_curly;
3377                 }
3378                 is_inf = is_inf_internal = 1;
3379                 scan = regnext(scan);
3380                 if (flags & SCF_DO_SUBSTR) {
3381                     SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot extend fixed substrings */
3382                     data->longest = &(data->longest_float);
3383                 }
3384                 goto optimize_curly_tail;
3385             case CURLY:
3386                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
3387                     && (scan->flags == stopparen))
3388                 {
3389                     mincount = 1;
3390                     maxcount = 1;
3391                 } else {
3392                     mincount = ARG1(scan);
3393                     maxcount = ARG2(scan);
3394                 }
3395                 next = regnext(scan);
3396                 if (OP(scan) == CURLYX) {
3397                     I32 lp = (data ? *(data->last_closep) : 0);
3398                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
3399                 }
3400                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3401                 next_is_eval = (OP(scan) == EVAL);
3402               do_curly:
3403                 if (flags & SCF_DO_SUBSTR) {
3404                     if (mincount == 0) SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot extend fixed substrings */
3405                     pos_before = data->pos_min;
3406                 }
3407                 if (data) {
3408                     fl = data->flags;
3409                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
3410                     if (is_inf)
3411                         data->flags |= SF_IS_INF;
3412                 }
3413                 if (flags & SCF_DO_STCLASS) {
3414                     cl_init(pRExC_state, &this_class);
3415                     oclass = data->start_class;
3416                     data->start_class = &this_class;
3417                     f |= SCF_DO_STCLASS_AND;
3418                     f &= ~SCF_DO_STCLASS_OR;
3419                 }
3420                 /* Exclude from super-linear cache processing any {n,m}
3421                    regops for which the combination of input pos and regex
3422                    pos is not enough information to determine if a match
3423                    will be possible.
3424
3425                    For example, in the regex /foo(bar\s*){4,8}baz/ with the
3426                    regex pos at the \s*, the prospects for a match depend not
3427                    only on the input position but also on how many (bar\s*)
3428                    repeats into the {4,8} we are. */
3429                if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
3430                     f &= ~SCF_WHILEM_VISITED_POS;
3431
3432                 /* This will finish on WHILEM, setting scan, or on NULL: */
3433                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, 
3434                                       last, data, stopparen, recursed, NULL,
3435                                       (mincount == 0
3436                                         ? (f & ~SCF_DO_SUBSTR) : f),depth+1);
3437
3438                 if (flags & SCF_DO_STCLASS)
3439                     data->start_class = oclass;
3440                 if (mincount == 0 || minnext == 0) {
3441                     if (flags & SCF_DO_STCLASS_OR) {
3442                         cl_or(pRExC_state, data->start_class, &this_class);
3443                     }
3444                     else if (flags & SCF_DO_STCLASS_AND) {
3445                         /* Switch to OR mode: cache the old value of
3446                          * data->start_class */
3447                         INIT_AND_WITHP;
3448                         StructCopy(data->start_class, and_withp,
3449                                    struct regnode_charclass_class);
3450                         flags &= ~SCF_DO_STCLASS_AND;
3451                         StructCopy(&this_class, data->start_class,
3452                                    struct regnode_charclass_class);
3453                         flags |= SCF_DO_STCLASS_OR;
3454                         data->start_class->flags |= ANYOF_EOS;
3455                     }
3456                 } else {                /* Non-zero len */
3457                     if (flags & SCF_DO_STCLASS_OR) {
3458                         cl_or(pRExC_state, data->start_class, &this_class);
3459                         cl_and(data->start_class, and_withp);
3460                     }
3461                     else if (flags & SCF_DO_STCLASS_AND)
3462                         cl_and(data->start_class, &this_class);
3463                     flags &= ~SCF_DO_STCLASS;
3464                 }
3465                 if (!scan)              /* It was not CURLYX, but CURLY. */
3466                     scan = next;
3467                 if ( /* ? quantifier ok, except for (?{ ... }) */
3468                     (next_is_eval || !(mincount == 0 && maxcount == 1))
3469                     && (minnext == 0) && (deltanext == 0)
3470                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
3471                     && maxcount <= REG_INFTY/3) /* Complement check for big count */
3472                 {
3473                     ckWARNreg(RExC_parse,
3474                               "Quantifier unexpected on zero-length expression");
3475                 }
3476
3477                 min += minnext * mincount;
3478                 is_inf_internal |= ((maxcount == REG_INFTY
3479                                      && (minnext + deltanext) > 0)
3480                                     || deltanext == I32_MAX);
3481                 is_inf |= is_inf_internal;
3482                 delta += (minnext + deltanext) * maxcount - minnext * mincount;
3483
3484                 /* Try powerful optimization CURLYX => CURLYN. */
3485                 if (  OP(oscan) == CURLYX && data
3486                       && data->flags & SF_IN_PAR
3487                       && !(data->flags & SF_HAS_EVAL)
3488                       && !deltanext && minnext == 1 ) {
3489                     /* Try to optimize to CURLYN.  */
3490                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
3491                     regnode * const nxt1 = nxt;
3492 #ifdef DEBUGGING
3493                     regnode *nxt2;
3494 #endif
3495
3496                     /* Skip open. */
3497                     nxt = regnext(nxt);
3498                     if (!REGNODE_SIMPLE(OP(nxt))
3499                         && !(PL_regkind[OP(nxt)] == EXACT
3500                              && STR_LEN(nxt) == 1))
3501                         goto nogo;
3502 #ifdef DEBUGGING
3503                     nxt2 = nxt;
3504 #endif
3505                     nxt = regnext(nxt);
3506                     if (OP(nxt) != CLOSE)
3507                         goto nogo;
3508                     if (RExC_open_parens) {
3509                         RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3510                         RExC_close_parens[ARG(nxt1)-1]=nxt+2; /*close->while*/
3511                     }
3512                     /* Now we know that nxt2 is the only contents: */
3513                     oscan->flags = (U8)ARG(nxt);
3514                     OP(oscan) = CURLYN;
3515                     OP(nxt1) = NOTHING; /* was OPEN. */
3516
3517 #ifdef DEBUGGING
3518                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3519                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
3520                     NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
3521                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
3522                     OP(nxt + 1) = OPTIMIZED; /* was count. */
3523                     NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
3524 #endif
3525                 }
3526               nogo:
3527
3528                 /* Try optimization CURLYX => CURLYM. */
3529                 if (  OP(oscan) == CURLYX && data
3530                       && !(data->flags & SF_HAS_PAR)
3531                       && !(data->flags & SF_HAS_EVAL)
3532                       && !deltanext     /* atom is fixed width */
3533                       && minnext != 0   /* CURLYM can't handle zero width */
3534                 ) {
3535                     /* XXXX How to optimize if data == 0? */
3536                     /* Optimize to a simpler form.  */
3537                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
3538                     regnode *nxt2;
3539
3540                     OP(oscan) = CURLYM;
3541                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
3542                             && (OP(nxt2) != WHILEM))
3543                         nxt = nxt2;
3544                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
3545                     /* Need to optimize away parenths. */
3546                     if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
3547                         /* Set the parenth number.  */
3548                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
3549
3550                         oscan->flags = (U8)ARG(nxt);
3551                         if (RExC_open_parens) {
3552                             RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3553                             RExC_close_parens[ARG(nxt1)-1]=nxt2+1; /*close->NOTHING*/
3554                         }
3555                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
3556                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
3557
3558 #ifdef DEBUGGING
3559                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3560                         OP(nxt + 1) = OPTIMIZED; /* was count. */
3561                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
3562                         NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
3563 #endif
3564 #if 0
3565                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
3566                             regnode *nnxt = regnext(nxt1);
3567                             if (nnxt == nxt) {
3568                                 if (reg_off_by_arg[OP(nxt1)])
3569                                     ARG_SET(nxt1, nxt2 - nxt1);
3570                                 else if (nxt2 - nxt1 < U16_MAX)
3571                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
3572                                 else
3573                                     OP(nxt) = NOTHING;  /* Cannot beautify */
3574                             }
3575                             nxt1 = nnxt;
3576                         }
3577 #endif
3578                         /* Optimize again: */
3579                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
3580                                     NULL, stopparen, recursed, NULL, 0,depth+1);
3581                     }
3582                     else
3583                         oscan->flags = 0;
3584                 }
3585                 else if ((OP(oscan) == CURLYX)
3586                          && (flags & SCF_WHILEM_VISITED_POS)
3587                          /* See the comment on a similar expression above.
3588                             However, this time it's not a subexpression
3589                             we care about, but the expression itself. */
3590                          && (maxcount == REG_INFTY)
3591                          && data && ++data->whilem_c < 16) {
3592                     /* This stays as CURLYX, we can put the count/of pair. */
3593                     /* Find WHILEM (as in regexec.c) */
3594                     regnode *nxt = oscan + NEXT_OFF(oscan);
3595
3596                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
3597                         nxt += ARG(nxt);
3598                     PREVOPER(nxt)->flags = (U8)(data->whilem_c
3599                         | (RExC_whilem_seen << 4)); /* On WHILEM */
3600                 }
3601                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
3602                     pars++;
3603                 if (flags & SCF_DO_SUBSTR) {
3604                     SV *last_str = NULL;
3605                     int counted = mincount != 0;
3606
3607                     if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
3608 #if defined(SPARC64_GCC_WORKAROUND)
3609                         I32 b = 0;
3610                         STRLEN l = 0;
3611                         const char *s = NULL;
3612                         I32 old = 0;
3613
3614                         if (pos_before >= data->last_start_min)
3615                             b = pos_before;
3616                         else
3617                             b = data->last_start_min;
3618
3619                         l = 0;
3620                         s = SvPV_const(data->last_found, l);
3621                         old = b - data->last_start_min;
3622
3623 #else
3624                         I32 b = pos_before >= data->last_start_min
3625                             ? pos_before : data->last_start_min;
3626                         STRLEN l;
3627                         const char * const s = SvPV_const(data->last_found, l);
3628                         I32 old = b - data->last_start_min;
3629 #endif
3630
3631                         if (UTF)
3632                             old = utf8_hop((U8*)s, old) - (U8*)s;
3633                         l -= old;
3634                         /* Get the added string: */
3635                         last_str = newSVpvn_utf8(s  + old, l, UTF);
3636                         if (deltanext == 0 && pos_before == b) {
3637                             /* What was added is a constant string */
3638                             if (mincount > 1) {
3639                                 SvGROW(last_str, (mincount * l) + 1);
3640                                 repeatcpy(SvPVX(last_str) + l,
3641                                           SvPVX_const(last_str), l, mincount - 1);
3642                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
3643                                 /* Add additional parts. */
3644                                 SvCUR_set(data->last_found,
3645                                           SvCUR(data->last_found) - l);
3646                                 sv_catsv(data->last_found, last_str);
3647                                 {
3648                                     SV * sv = data->last_found;
3649                                     MAGIC *mg =
3650                                         SvUTF8(sv) && SvMAGICAL(sv) ?
3651                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
3652                                     if (mg && mg->mg_len >= 0)
3653                                         mg->mg_len += CHR_SVLEN(last_str) - l;
3654                                 }
3655                                 data->last_end += l * (mincount - 1);
3656                             }
3657                         } else {
3658                             /* start offset must point into the last copy */
3659                             data->last_start_min += minnext * (mincount - 1);
3660                             data->last_start_max += is_inf ? I32_MAX
3661                                 : (maxcount - 1) * (minnext + data->pos_delta);
3662                         }
3663                     }
3664                     /* It is counted once already... */
3665                     data->pos_min += minnext * (mincount - counted);
3666                     data->pos_delta += - counted * deltanext +
3667                         (minnext + deltanext) * maxcount - minnext * mincount;
3668                     if (mincount != maxcount) {
3669                          /* Cannot extend fixed substrings found inside
3670                             the group.  */
3671                         SCAN_COMMIT(pRExC_state,data,minlenp);
3672                         if (mincount && last_str) {
3673                             SV * const sv = data->last_found;
3674                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3675                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
3676
3677                             if (mg)
3678                                 mg->mg_len = -1;
3679                             sv_setsv(sv, last_str);
3680                             data->last_end = data->pos_min;
3681                             data->last_start_min =
3682                                 data->pos_min - CHR_SVLEN(last_str);
3683                             data->last_start_max = is_inf
3684                                 ? I32_MAX
3685                                 : data->pos_min + data->pos_delta
3686                                 - CHR_SVLEN(last_str);
3687                         }
3688                         data->longest = &(data->longest_float);
3689                     }
3690                     SvREFCNT_dec(last_str);
3691                 }
3692                 if (data && (fl & SF_HAS_EVAL))
3693                     data->flags |= SF_HAS_EVAL;
3694               optimize_curly_tail:
3695                 if (OP(oscan) != CURLYX) {
3696                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
3697                            && NEXT_OFF(next))
3698                         NEXT_OFF(oscan) += NEXT_OFF(next);
3699                 }
3700                 continue;
3701             default:                    /* REF, ANYOFV, and CLUMP only? */
3702                 if (flags & SCF_DO_SUBSTR) {
3703                     SCAN_COMMIT(pRExC_state,data,minlenp);      /* Cannot expect anything... */
3704                     data->longest = &(data->longest_float);
3705                 }
3706                 is_inf = is_inf_internal = 1;
3707                 if (flags & SCF_DO_STCLASS_OR)
3708                     cl_anything(pRExC_state, data->start_class);
3709                 flags &= ~SCF_DO_STCLASS;
3710                 break;
3711             }
3712         }
3713         else if (OP(scan) == LNBREAK) {
3714             if (flags & SCF_DO_STCLASS) {
3715                 int value = 0;
3716                 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
3717                 if (flags & SCF_DO_STCLASS_AND) {
3718                     for (value = 0; value < 256; value++)
3719                         if (!is_VERTWS_cp(value))
3720                             ANYOF_BITMAP_CLEAR(data->start_class, value);
3721                 }
3722                 else {
3723                     for (value = 0; value < 256; value++)
3724                         if (is_VERTWS_cp(value))
3725                             ANYOF_BITMAP_SET(data->start_class, value);
3726                 }
3727                 if (flags & SCF_DO_STCLASS_OR)
3728                     cl_and(data->start_class, and_withp);
3729                 flags &= ~SCF_DO_STCLASS;
3730             }
3731             min += 1;
3732             delta += 1;
3733             if (flags & SCF_DO_SUBSTR) {
3734                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
3735                 data->pos_min += 1;
3736                 data->pos_delta += 1;
3737                 data->longest = &(data->longest_float);
3738             }
3739         }
3740         else if (OP(scan) == FOLDCHAR) {
3741             int d = ARG(scan) == LATIN_SMALL_LETTER_SHARP_S ? 1 : 2;
3742             flags &= ~SCF_DO_STCLASS;
3743             min += 1;
3744             delta += d;
3745             if (flags & SCF_DO_SUBSTR) {
3746                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
3747                 data->pos_min += 1;
3748                 data->pos_delta += d;
3749                 data->longest = &(data->longest_float);
3750             }
3751         }
3752         else if (REGNODE_SIMPLE(OP(scan))) {
3753             int value = 0;
3754
3755             if (flags & SCF_DO_SUBSTR) {
3756                 SCAN_COMMIT(pRExC_state,data,minlenp);
3757                 data->pos_min++;
3758             }
3759             min++;
3760             if (flags & SCF_DO_STCLASS) {
3761                 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
3762
3763                 /* Some of the logic below assumes that switching
3764                    locale on will only add false positives. */
3765                 switch (PL_regkind[OP(scan)]) {
3766                 case SANY:
3767                 default:
3768                   do_default:
3769                     /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */
3770                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3771                         cl_anything(pRExC_state, data->start_class);
3772                     break;
3773                 case REG_ANY:
3774                     if (OP(scan) == SANY)
3775                         goto do_default;
3776                     if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
3777                         value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
3778                                  || ANYOF_CLASS_TEST_ANY_SET(data->start_class));
3779                         cl_anything(pRExC_state, data->start_class);
3780                     }
3781                     if (flags & SCF_DO_STCLASS_AND || !value)
3782                         ANYOF_BITMAP_CLEAR(data->start_class,'\n');
3783                     break;
3784                 case ANYOF:
3785                     if (flags & SCF_DO_STCLASS_AND)
3786                         cl_and(data->start_class,
3787                                (struct regnode_charclass_class*)scan);
3788                     else
3789                         cl_or(pRExC_state, data->start_class,
3790                               (struct regnode_charclass_class*)scan);
3791                     break;
3792                 case ALNUM:
3793                     if (flags & SCF_DO_STCLASS_AND) {
3794                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3795                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
3796                             if (OP(scan) == ALNUMU) {
3797                                 for (value = 0; value < 256; value++) {
3798                                     if (!isWORDCHAR_L1(value)) {
3799                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3800                                     }
3801                                 }
3802                             } else {
3803                                 for (value = 0; value < 256; value++) {
3804                                     if (!isALNUM(value)) {
3805                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3806                                     }
3807                                 }
3808                             }
3809                         }
3810                     }
3811                     else {
3812                         if (data->start_class->flags & ANYOF_LOCALE)
3813                             ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
3814
3815                         /* Even if under locale, set the bits for non-locale
3816                          * in case it isn't a true locale-node.  This will
3817                          * create false positives if it truly is locale */
3818                         if (OP(scan) == ALNUMU) {
3819                             for (value = 0; value < 256; value++) {
3820                                 if (isWORDCHAR_L1(value)) {
3821                                     ANYOF_BITMAP_SET(data->start_class, value);
3822                                 }
3823                             }
3824                         } else {
3825                             for (value = 0; value < 256; value++) {
3826                                 if (isALNUM(value)) {
3827                                     ANYOF_BITMAP_SET(data->start_class, value);
3828                                 }
3829                             }
3830                         }
3831                     }
3832                     break;
3833                 case NALNUM:
3834                     if (flags & SCF_DO_STCLASS_AND) {
3835                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3836                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
3837                             if (OP(scan) == NALNUMU) {
3838                                 for (value = 0; value < 256; value++) {
3839                                     if (isWORDCHAR_L1(value)) {
3840                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3841                                     }
3842                                 }
3843                             } else {
3844                                 for (value = 0; value < 256; value++) {
3845                                     if (isALNUM(value)) {
3846                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3847                                     }
3848                                 }
3849                             }
3850                         }
3851                     }
3852                     else {
3853                         if (data->start_class->flags & ANYOF_LOCALE)
3854                             ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
3855
3856                         /* Even if under locale, set the bits for non-locale in
3857                          * case it isn't a true locale-node.  This will create
3858                          * false positives if it truly is locale */
3859                         if (OP(scan) == NALNUMU) {
3860                             for (value = 0; value < 256; value++) {
3861                                 if (! isWORDCHAR_L1(value)) {
3862                                     ANYOF_BITMAP_SET(data->start_class, value);
3863                                 }
3864                             }
3865                         } else {
3866                             for (value = 0; value < 256; value++) {
3867                                 if (! isALNUM(value)) {
3868                                     ANYOF_BITMAP_SET(data->start_class, value);
3869                                 }
3870                             }
3871                         }
3872                     }
3873                     break;
3874                 case SPACE:
3875                     if (flags & SCF_DO_STCLASS_AND) {
3876                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3877                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
3878                             if (OP(scan) == SPACEU) {
3879                                 for (value = 0; value < 256; value++) {
3880                                     if (!isSPACE_L1(value)) {
3881                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3882                                     }
3883                                 }
3884                             } else {
3885                                 for (value = 0; value < 256; value++) {
3886                                     if (!isSPACE(value)) {
3887                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3888                                     }
3889                                 }
3890                             }
3891                         }
3892                     }
3893                     else {
3894                         if (data->start_class->flags & ANYOF_LOCALE) {
3895                             ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
3896                         }
3897                         if (OP(scan) == SPACEU) {
3898                             for (value = 0; value < 256; value++) {
3899                                 if (isSPACE_L1(value)) {
3900                                     ANYOF_BITMAP_SET(data->start_class, value);
3901                                 }
3902                             }
3903                         } else {
3904                             for (value = 0; value < 256; value++) {
3905                                 if (isSPACE(value)) {
3906                                     ANYOF_BITMAP_SET(data->start_class, value);
3907                                 }
3908                             }
3909                         }
3910                     }
3911                     break;
3912                 case NSPACE:
3913                     if (flags & SCF_DO_STCLASS_AND) {
3914                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3915                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
3916                             if (OP(scan) == NSPACEU) {
3917                                 for (value = 0; value < 256; value++) {
3918                                     if (isSPACE_L1(value)) {
3919                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3920                                     }
3921                                 }
3922                             } else {
3923                                 for (value = 0; value < 256; value++) {
3924                                     if (isSPACE(value)) {
3925                                         ANYOF_BITMAP_CLEAR(data->start_class, value);
3926                                     }
3927                                 }
3928                             }
3929                         }
3930                     }
3931                     else {
3932                         if (data->start_class->flags & ANYOF_LOCALE)
3933                             ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
3934                         if (OP(scan) == NSPACEU) {
3935                             for (value = 0; value < 256; value++) {
3936                                 if (!isSPACE_L1(value)) {
3937                                     ANYOF_BITMAP_SET(data->start_class, value);
3938                                 }
3939                             }
3940                         }
3941                         else {
3942                             for (value = 0; value < 256; value++) {
3943                                 if (!isSPACE(value)) {
3944                                     ANYOF_BITMAP_SET(data->start_class, value);
3945                                 }
3946                             }
3947                         }
3948                     }
3949                     break;
3950                 case DIGIT:
3951                     if (flags & SCF_DO_STCLASS_AND) {
3952                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3953                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NDIGIT);
3954                             for (value = 0; value < 256; value++)
3955                                 if (!isDIGIT(value))
3956                                     ANYOF_BITMAP_CLEAR(data->start_class, value);
3957                         }
3958                     }
3959                     else {
3960                         if (data->start_class->flags & ANYOF_LOCALE)
3961                             ANYOF_CLASS_SET(data->start_class,ANYOF_DIGIT);
3962                         for (value = 0; value < 256; value++)
3963                             if (isDIGIT(value))
3964                                 ANYOF_BITMAP_SET(data->start_class, value);
3965                     }
3966                     break;
3967                 case NDIGIT:
3968                     if (flags & SCF_DO_STCLASS_AND) {
3969                         if (!(data->start_class->flags & ANYOF_LOCALE))
3970                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_DIGIT);
3971                         for (value = 0; value < 256; value++)
3972                             if (isDIGIT(value))
3973                                 ANYOF_BITMAP_CLEAR(data->start_class, value);
3974                     }
3975                     else {
3976                         if (data->start_class->flags & ANYOF_LOCALE)
3977                             ANYOF_CLASS_SET(data->start_class,ANYOF_NDIGIT);
3978                         for (value = 0; value < 256; value++)
3979                             if (!isDIGIT(value))
3980                                 ANYOF_BITMAP_SET(data->start_class, value);
3981                     }
3982                     break;
3983                 CASE_SYNST_FNC(VERTWS);
3984                 CASE_SYNST_FNC(HORIZWS);
3985                 
3986                 }
3987                 if (flags & SCF_DO_STCLASS_OR)
3988                     cl_and(data->start_class, and_withp);
3989                 flags &= ~SCF_DO_STCLASS;
3990             }
3991         }
3992         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
3993             data->flags |= (OP(scan) == MEOL
3994                             ? SF_BEFORE_MEOL
3995                             : SF_BEFORE_SEOL);
3996         }
3997         else if (  PL_regkind[OP(scan)] == BRANCHJ
3998                  /* Lookbehind, or need to calculate parens/evals/stclass: */
3999                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
4000                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
4001             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY 
4002                 || OP(scan) == UNLESSM )
4003             {
4004                 /* Negative Lookahead/lookbehind
4005                    In this case we can't do fixed string optimisation.
4006                 */
4007
4008                 I32 deltanext, minnext, fake = 0;
4009                 regnode *nscan;
4010                 struct regnode_charclass_class intrnl;
4011                 int f = 0;
4012
4013                 data_fake.flags = 0;
4014                 if (data) {
4015                     data_fake.whilem_c = data->whilem_c;
4016                     data_fake.last_closep = data->last_closep;
4017                 }
4018                 else
4019                     data_fake.last_closep = &fake;
4020                 data_fake.pos_delta = delta;
4021                 if ( flags & SCF_DO_STCLASS && !scan->flags
4022                      && OP(scan) == IFMATCH ) { /* Lookahead */
4023                     cl_init(pRExC_state, &intrnl);
4024                     data_fake.start_class = &intrnl;
4025                     f |= SCF_DO_STCLASS_AND;
4026                 }
4027                 if (flags & SCF_WHILEM_VISITED_POS)
4028                     f |= SCF_WHILEM_VISITED_POS;
4029                 next = regnext(scan);
4030                 nscan = NEXTOPER(NEXTOPER(scan));
4031                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext, 
4032                     last, &data_fake, stopparen, recursed, NULL, f, depth+1);
4033                 if (scan->flags) {
4034                     if (deltanext) {
4035                         FAIL("Variable length lookbehind not implemented");
4036                     }
4037                     else if (minnext > (I32)U8_MAX) {
4038                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4039                     }
4040                     scan->flags = (U8)minnext;
4041                 }
4042                 if (data) {
4043                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4044                         pars++;
4045                     if (data_fake.flags & SF_HAS_EVAL)
4046                         data->flags |= SF_HAS_EVAL;
4047                     data->whilem_c = data_fake.whilem_c;
4048                 }
4049                 if (f & SCF_DO_STCLASS_AND) {
4050                     if (flags & SCF_DO_STCLASS_OR) {
4051                         /* OR before, AND after: ideally we would recurse with
4052                          * data_fake to get the AND applied by study of the
4053                          * remainder of the pattern, and then derecurse;
4054                          * *** HACK *** for now just treat as "no information".
4055                          * See [perl #56690].
4056                          */
4057                         cl_init(pRExC_state, data->start_class);
4058                     }  else {
4059                         /* AND before and after: combine and continue */
4060                         const int was = (data->start_class->flags & ANYOF_EOS);
4061
4062                         cl_and(data->start_class, &intrnl);
4063                         if (was)
4064                             data->start_class->flags |= ANYOF_EOS;
4065                     }
4066                 }
4067             }
4068 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
4069             else {
4070                 /* Positive Lookahead/lookbehind
4071                    In this case we can do fixed string optimisation,
4072                    but we must be careful about it. Note in the case of
4073                    lookbehind the positions will be offset by the minimum
4074                    length of the pattern, something we won't know about
4075                    until after the recurse.
4076                 */
4077                 I32 deltanext, fake = 0;
4078                 regnode *nscan;
4079                 struct regnode_charclass_class intrnl;
4080                 int f = 0;
4081                 /* We use SAVEFREEPV so that when the full compile 
4082                     is finished perl will clean up the allocated 
4083                     minlens when it's all done. This way we don't
4084                     have to worry about freeing them when we know
4085                     they wont be used, which would be a pain.
4086                  */
4087                 I32 *minnextp;
4088                 Newx( minnextp, 1, I32 );
4089                 SAVEFREEPV(minnextp);
4090
4091                 if (data) {
4092                     StructCopy(data, &data_fake, scan_data_t);
4093                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
4094                         f |= SCF_DO_SUBSTR;
4095                         if (scan->flags) 
4096                             SCAN_COMMIT(pRExC_state, &data_fake,minlenp);
4097                         data_fake.last_found=newSVsv(data->last_found);
4098                     }
4099                 }
4100                 else
4101                     data_fake.last_closep = &fake;
4102                 data_fake.flags = 0;
4103                 data_fake.pos_delta = delta;
4104                 if (is_inf)
4105                     data_fake.flags |= SF_IS_INF;
4106                 if ( flags & SCF_DO_STCLASS && !scan->flags
4107                      && OP(scan) == IFMATCH ) { /* Lookahead */
4108                     cl_init(pRExC_state, &intrnl);
4109                     data_fake.start_class = &intrnl;
4110                     f |= SCF_DO_STCLASS_AND;
4111                 }
4112                 if (flags & SCF_WHILEM_VISITED_POS)
4113                     f |= SCF_WHILEM_VISITED_POS;
4114                 next = regnext(scan);
4115                 nscan = NEXTOPER(NEXTOPER(scan));
4116
4117                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp, &deltanext, 
4118                     last, &data_fake, stopparen, recursed, NULL, f,depth+1);
4119                 if (scan->flags) {
4120                     if (deltanext) {
4121                         FAIL("Variable length lookbehind not implemented");
4122                     }
4123                     else if (*minnextp > (I32)U8_MAX) {
4124                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4125                     }
4126                     scan->flags = (U8)*minnextp;
4127                 }
4128
4129                 *minnextp += min;
4130
4131                 if (f & SCF_DO_STCLASS_AND) {
4132                     const int was = (data->start_class->flags & ANYOF_EOS);
4133
4134                     cl_and(data->start_class, &intrnl);
4135                     if (was)
4136                         data->start_class->flags |= ANYOF_EOS;
4137                 }
4138                 if (data) {
4139                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4140                         pars++;
4141                     if (data_fake.flags & SF_HAS_EVAL)
4142                         data->flags |= SF_HAS_EVAL;
4143                     data->whilem_c = data_fake.whilem_c;
4144                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
4145                         if (RExC_rx->minlen<*minnextp)
4146                             RExC_rx->minlen=*minnextp;
4147                         SCAN_COMMIT(pRExC_state, &data_fake, minnextp);
4148                         SvREFCNT_dec(data_fake.last_found);
4149                         
4150                         if ( data_fake.minlen_fixed != minlenp ) 
4151                         {
4152                             data->offset_fixed= data_fake.offset_fixed;
4153                             data->minlen_fixed= data_fake.minlen_fixed;
4154                             data->lookbehind_fixed+= scan->flags;
4155                         }
4156                         if ( data_fake.minlen_float != minlenp )
4157                         {
4158                             data->minlen_float= data_fake.minlen_float;
4159                             data->offset_float_min=data_fake.offset_float_min;
4160                             data->offset_float_max=data_fake.offset_float_max;
4161                             data->lookbehind_float+= scan->flags;
4162                         }
4163                     }
4164                 }
4165
4166
4167             }
4168 #endif
4169         }
4170         else if (OP(scan) == OPEN) {
4171             if (stopparen != (I32)ARG(scan))
4172                 pars++;
4173         }
4174         else if (OP(scan) == CLOSE) {
4175             if (stopparen == (I32)ARG(scan)) {
4176                 break;
4177             }
4178             if ((I32)ARG(scan) == is_par) {
4179                 next = regnext(scan);
4180
4181                 if ( next && (OP(next) != WHILEM) && next < last)
4182                     is_par = 0;         /* Disable optimization */
4183             }
4184             if (data)
4185                 *(data->last_closep) = ARG(scan);
4186         }
4187         else if (OP(scan) == EVAL) {
4188                 if (data)
4189                     data->flags |= SF_HAS_EVAL;
4190         }
4191         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
4192             if (flags & SCF_DO_SUBSTR) {
4193                 SCAN_COMMIT(pRExC_state,data,minlenp);
4194                 flags &= ~SCF_DO_SUBSTR;
4195             }
4196             if (data && OP(scan)==ACCEPT) {
4197                 data->flags |= SCF_SEEN_ACCEPT;
4198                 if (stopmin > min)
4199                     stopmin = min;
4200             }
4201         }
4202         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
4203         {
4204                 if (flags & SCF_DO_SUBSTR) {
4205                     SCAN_COMMIT(pRExC_state,data,minlenp);
4206                     data->longest = &(data->longest_float);
4207                 }
4208                 is_inf = is_inf_internal = 1;
4209                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4210                     cl_anything(pRExC_state, data->start_class);
4211                 flags &= ~SCF_DO_STCLASS;
4212         }
4213         else if (OP(scan) == GPOS) {
4214             if (!(RExC_rx->extflags & RXf_GPOS_FLOAT) &&
4215                 !(delta || is_inf || (data && data->pos_delta))) 
4216             {
4217                 if (!(RExC_rx->extflags & RXf_ANCH) && (flags & SCF_DO_SUBSTR))
4218                     RExC_rx->extflags |= RXf_ANCH_GPOS;
4219                 if (RExC_rx->gofs < (U32)min)
4220                     RExC_rx->gofs = min;
4221             } else {
4222                 RExC_rx->extflags |= RXf_GPOS_FLOAT;
4223                 RExC_rx->gofs = 0;
4224             }       
4225         }
4226 #ifdef TRIE_STUDY_OPT
4227 #ifdef FULL_TRIE_STUDY
4228         else if (PL_regkind[OP(scan)] == TRIE) {
4229             /* NOTE - There is similar code to this block above for handling
4230                BRANCH nodes on the initial study.  If you change stuff here
4231                check there too. */
4232             regnode *trie_node= scan;
4233             regnode *tail= regnext(scan);
4234             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4235             I32 max1 = 0, min1 = I32_MAX;
4236             struct regnode_charclass_class accum;
4237
4238             if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
4239                 SCAN_COMMIT(pRExC_state, data,minlenp); /* Cannot merge strings after this. */
4240             if (flags & SCF_DO_STCLASS)
4241                 cl_init_zero(pRExC_state, &accum);
4242                 
4243             if (!trie->jump) {
4244                 min1= trie->minlen;
4245                 max1= trie->maxlen;
4246             } else {
4247                 const regnode *nextbranch= NULL;
4248                 U32 word;
4249                 
4250                 for ( word=1 ; word <= trie->wordcount ; word++) 
4251                 {
4252                     I32 deltanext=0, minnext=0, f = 0, fake;
4253                     struct regnode_charclass_class this_class;
4254                     
4255                     data_fake.flags = 0;
4256                     if (data) {
4257                         data_fake.whilem_c = data->whilem_c;
4258                         data_fake.last_closep = data->last_closep;
4259                     }
4260                     else
4261                         data_fake.last_closep = &fake;
4262                     data_fake.pos_delta = delta;
4263                     if (flags & SCF_DO_STCLASS) {
4264                         cl_init(pRExC_state, &this_class);
4265                         data_fake.start_class = &this_class;
4266                         f = SCF_DO_STCLASS_AND;
4267                     }
4268                     if (flags & SCF_WHILEM_VISITED_POS)
4269                         f |= SCF_WHILEM_VISITED_POS;
4270     
4271                     if (trie->jump[word]) {
4272                         if (!nextbranch)
4273                             nextbranch = trie_node + trie->jump[0];
4274                         scan= trie_node + trie->jump[word];
4275                         /* We go from the jump point to the branch that follows
4276                            it. Note this means we need the vestigal unused branches
4277                            even though they arent otherwise used.
4278                          */
4279                         minnext = study_chunk(pRExC_state, &scan, minlenp, 
4280                             &deltanext, (regnode *)nextbranch, &data_fake, 
4281                             stopparen, recursed, NULL, f,depth+1);
4282                     }
4283                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
4284                         nextbranch= regnext((regnode*)nextbranch);
4285                     
4286                     if (min1 > (I32)(minnext + trie->minlen))
4287                         min1 = minnext + trie->minlen;
4288                     if (max1 < (I32)(minnext + deltanext + trie->maxlen))
4289                         max1 = minnext + deltanext + trie->maxlen;
4290                     if (deltanext == I32_MAX)
4291                         is_inf = is_inf_internal = 1;
4292                     
4293                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4294                         pars++;
4295                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
4296                         if ( stopmin > min + min1) 
4297                             stopmin = min + min1;
4298                         flags &= ~SCF_DO_SUBSTR;
4299                         if (data)
4300                             data->flags |= SCF_SEEN_ACCEPT;
4301                     }
4302                     if (data) {
4303                         if (data_fake.flags & SF_HAS_EVAL)
4304                             data->flags |= SF_HAS_EVAL;
4305                         data->whilem_c = data_fake.whilem_c;
4306                     }
4307                     if (flags & SCF_DO_STCLASS)
4308                         cl_or(pRExC_state, &accum, &this_class);
4309                 }
4310             }
4311             if (flags & SCF_DO_SUBSTR) {
4312                 data->pos_min += min1;
4313                 data->pos_delta += max1 - min1;
4314                 if (max1 != min1 || is_inf)
4315                     data->longest = &(data->longest_float);
4316             }
4317             min += min1;
4318             delta += max1 - min1;
4319             if (flags & SCF_DO_STCLASS_OR) {
4320                 cl_or(pRExC_state, data->start_class, &accum);
4321                 if (min1) {
4322                     cl_and(data->start_class, and_withp);
4323                     flags &= ~SCF_DO_STCLASS;
4324                 }
4325             }
4326             else if (flags & SCF_DO_STCLASS_AND) {
4327                 if (min1) {
4328                     cl_and(data->start_class, &accum);
4329                     flags &= ~SCF_DO_STCLASS;
4330                 }
4331                 else {
4332                     /* Switch to OR mode: cache the old value of
4333                      * data->start_class */
4334                     INIT_AND_WITHP;
4335                     StructCopy(data->start_class, and_withp,
4336                                struct regnode_charclass_class);
4337                     flags &= ~SCF_DO_STCLASS_AND;
4338                     StructCopy(&accum, data->start_class,
4339                                struct regnode_charclass_class);
4340                     flags |= SCF_DO_STCLASS_OR;
4341                     data->start_class->flags |= ANYOF_EOS;
4342                 }
4343             }
4344             scan= tail;
4345             continue;
4346         }
4347 #else
4348         else if (PL_regkind[OP(scan)] == TRIE) {
4349             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4350             U8*bang=NULL;
4351             
4352             min += trie->minlen;
4353             delta += (trie->maxlen - trie->minlen);
4354             flags &= ~SCF_DO_STCLASS; /* xxx */
4355             if (flags & SCF_DO_SUBSTR) {
4356                 SCAN_COMMIT(pRExC_state,data,minlenp);  /* Cannot expect anything... */
4357                 data->pos_min += trie->minlen;
4358                 data->pos_delta += (trie->maxlen - trie->minlen);
4359                 if (trie->maxlen != trie->minlen)
4360                     data->longest = &(data->longest_float);
4361             }
4362             if (trie->jump) /* no more substrings -- for now /grr*/
4363                 flags &= ~SCF_DO_SUBSTR; 
4364         }
4365 #endif /* old or new */
4366 #endif /* TRIE_STUDY_OPT */     
4367
4368         /* Else: zero-length, ignore. */
4369         scan = regnext(scan);
4370     }
4371     if (frame) {
4372         last = frame->last;
4373         scan = frame->next;
4374         stopparen = frame->stop;
4375         frame = frame->prev;
4376         goto fake_study_recurse;
4377     }
4378
4379   finish:
4380     assert(!frame);
4381     DEBUG_STUDYDATA("pre-fin:",data,depth);
4382
4383     *scanp = scan;
4384     *deltap = is_inf_internal ? I32_MAX : delta;
4385     if (flags & SCF_DO_SUBSTR && is_inf)
4386         data->pos_delta = I32_MAX - data->pos_min;
4387     if (is_par > (I32)U8_MAX)
4388         is_par = 0;
4389     if (is_par && pars==1 && data) {
4390         data->flags |= SF_IN_PAR;
4391         data->flags &= ~SF_HAS_PAR;
4392     }
4393     else if (pars && data) {
4394         data->flags |= SF_HAS_PAR;
4395         data->flags &= ~SF_IN_PAR;
4396     }
4397     if (flags & SCF_DO_STCLASS_OR)
4398         cl_and(data->start_class, and_withp);
4399     if (flags & SCF_TRIE_RESTUDY)
4400         data->flags |=  SCF_TRIE_RESTUDY;
4401     
4402     DEBUG_STUDYDATA("post-fin:",data,depth);
4403     
4404     return min < stopmin ? min : stopmin;
4405 }
4406
4407 STATIC U32
4408 S_add_data(RExC_state_t *pRExC_state, U32 n, const char *s)
4409 {
4410     U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
4411
4412     PERL_ARGS_ASSERT_ADD_DATA;
4413
4414     Renewc(RExC_rxi->data,
4415            sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
4416            char, struct reg_data);
4417     if(count)
4418         Renew(RExC_rxi->data->what, count + n, U8);
4419     else
4420         Newx(RExC_rxi->data->what, n, U8);
4421     RExC_rxi->data->count = count + n;
4422     Copy(s, RExC_rxi->data->what + count, n, U8);
4423     return count;
4424 }
4425
4426 /*XXX: todo make this not included in a non debugging perl */
4427 #ifndef PERL_IN_XSUB_RE
4428 void
4429 Perl_reginitcolors(pTHX)
4430 {
4431     dVAR;
4432     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
4433     if (s) {
4434         char *t = savepv(s);
4435         int i = 0;
4436         PL_colors[0] = t;
4437         while (++i < 6) {
4438             t = strchr(t, '\t');
4439             if (t) {
4440                 *t = '\0';
4441                 PL_colors[i] = ++t;
4442             }
4443             else
4444                 PL_colors[i] = t = (char *)"";
4445         }
4446     } else {
4447         int i = 0;
4448         while (i < 6)
4449             PL_colors[i++] = (char *)"";
4450     }
4451     PL_colorset = 1;
4452 }
4453 #endif
4454
4455
4456 #ifdef TRIE_STUDY_OPT
4457 #define CHECK_RESTUDY_GOTO                                  \
4458         if (                                                \
4459               (data.flags & SCF_TRIE_RESTUDY)               \
4460               && ! restudied++                              \
4461         )     goto reStudy
4462 #else
4463 #define CHECK_RESTUDY_GOTO
4464 #endif        
4465
4466 /*
4467  - pregcomp - compile a regular expression into internal code
4468  *
4469  * We can't allocate space until we know how big the compiled form will be,
4470  * but we can't compile it (and thus know how big it is) until we've got a
4471  * place to put the code.  So we cheat:  we compile it twice, once with code
4472  * generation turned off and size counting turned on, and once "for real".
4473  * This also means that we don't allocate space until we are sure that the
4474  * thing really will compile successfully, and we never have to move the
4475  * code and thus invalidate pointers into it.  (Note that it has to be in
4476  * one piece because free() must be able to free it all.) [NB: not true in perl]
4477  *
4478  * Beware that the optimization-preparation code in here knows about some
4479  * of the structure of the compiled regexp.  [I'll say.]
4480  */
4481
4482
4483
4484 #ifndef PERL_IN_XSUB_RE
4485 #define RE_ENGINE_PTR &PL_core_reg_engine
4486 #else
4487 extern const struct regexp_engine my_reg_engine;
4488 #define RE_ENGINE_PTR &my_reg_engine
4489 #endif
4490
4491 #ifndef PERL_IN_XSUB_RE 
4492 REGEXP *
4493 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
4494 {
4495     dVAR;
4496     HV * const table = GvHV(PL_hintgv);
4497
4498     PERL_ARGS_ASSERT_PREGCOMP;
4499
4500     /* Dispatch a request to compile a regexp to correct 
4501        regexp engine. */
4502     if (table) {
4503         SV **ptr= hv_fetchs(table, "regcomp", FALSE);
4504         GET_RE_DEBUG_FLAGS_DECL;
4505         if (ptr && SvIOK(*ptr) && SvIV(*ptr)) {
4506             const regexp_engine *eng=INT2PTR(regexp_engine*,SvIV(*ptr));
4507             DEBUG_COMPILE_r({
4508                 PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
4509                     SvIV(*ptr));
4510             });            
4511             return CALLREGCOMP_ENG(eng, pattern, flags);
4512         } 
4513     }
4514     return Perl_re_compile(aTHX_ pattern, flags);
4515 }
4516 #endif
4517
4518 REGEXP *
4519 Perl_re_compile(pTHX_ SV * const pattern, U32 orig_pm_flags)
4520 {
4521     dVAR;
4522     REGEXP *rx;
4523     struct regexp *r;
4524     register regexp_internal *ri;
4525     STRLEN plen;
4526     char  *exp;
4527     char* xend;
4528     regnode *scan;
4529     I32 flags;
4530     I32 minlen = 0;
4531     U32 pm_flags;
4532
4533     /* these are all flags - maybe they should be turned
4534      * into a single int with different bit masks */
4535     I32 sawlookahead = 0;
4536     I32 sawplus = 0;
4537     I32 sawopen = 0;
4538     bool used_setjump = FALSE;
4539     regex_charset initial_charset = get_regex_charset(orig_pm_flags);
4540
4541     U8 jump_ret = 0;
4542     dJMPENV;
4543     scan_data_t data;
4544     RExC_state_t RExC_state;
4545     RExC_state_t * const pRExC_state = &RExC_state;
4546 #ifdef TRIE_STUDY_OPT    
4547     int restudied;
4548     RExC_state_t copyRExC_state;
4549 #endif    
4550     GET_RE_DEBUG_FLAGS_DECL;
4551
4552     PERL_ARGS_ASSERT_RE_COMPILE;
4553
4554     DEBUG_r(if (!PL_colorset) reginitcolors());
4555
4556     RExC_utf8 = RExC_orig_utf8 = SvUTF8(pattern);
4557     RExC_uni_semantics = 0;
4558     RExC_contains_locale = 0;
4559
4560     /****************** LONG JUMP TARGET HERE***********************/
4561     /* Longjmp back to here if have to switch in midstream to utf8 */
4562     if (! RExC_orig_utf8) {
4563         JMPENV_PUSH(jump_ret);
4564         used_setjump = TRUE;
4565     }
4566
4567     if (jump_ret == 0) {    /* First time through */
4568         exp = SvPV(pattern, plen);
4569         xend = exp + plen;
4570         /* ignore the utf8ness if the pattern is 0 length */
4571         if (plen == 0) {
4572             RExC_utf8 = RExC_orig_utf8 = 0;
4573         }
4574
4575         DEBUG_COMPILE_r({
4576             SV *dsv= sv_newmortal();
4577             RE_PV_QUOTED_DECL(s, RExC_utf8,
4578                 dsv, exp, plen, 60);
4579             PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
4580                            PL_colors[4],PL_colors[5],s);
4581         });
4582     }
4583     else {  /* longjumped back */
4584         STRLEN len = plen;
4585
4586         /* If the cause for the longjmp was other than changing to utf8, pop
4587          * our own setjmp, and longjmp to the correct handler */
4588         if (jump_ret != UTF8_LONGJMP) {
4589             JMPENV_POP;
4590             JMPENV_JUMP(jump_ret);
4591         }
4592
4593         GET_RE_DEBUG_FLAGS;
4594
4595         /* It's possible to write a regexp in ascii that represents Unicode
4596         codepoints outside of the byte range, such as via \x{100}. If we
4597         detect such a sequence we have to convert the entire pattern to utf8
4598         and then recompile, as our sizing calculation will have been based
4599         on 1 byte == 1 character, but we will need to use utf8 to encode
4600         at least some part of the pattern, and therefore must convert the whole
4601         thing.
4602         -- dmq */
4603         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
4604             "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
4605         exp = (char*)Perl_bytes_to_utf8(aTHX_ (U8*)SvPV(pattern, plen), &len);
4606         xend = exp + len;
4607         RExC_orig_utf8 = RExC_utf8 = 1;
4608         SAVEFREEPV(exp);
4609     }
4610
4611 #ifdef TRIE_STUDY_OPT
4612     restudied = 0;
4613 #endif
4614
4615     pm_flags = orig_pm_flags;
4616
4617     if (initial_charset == REGEX_LOCALE_CHARSET) {
4618         RExC_contains_locale = 1;
4619     }
4620     else if (RExC_utf8 && initial_charset == REGEX_DEPENDS_CHARSET) {
4621
4622         /* Set to use unicode semantics if the pattern is in utf8 and has the
4623          * 'depends' charset specified, as it means unicode when utf8  */
4624         set_regex_charset(&pm_flags, REGEX_UNICODE_CHARSET);
4625     }
4626
4627     RExC_precomp = exp;
4628     RExC_flags = pm_flags;
4629     RExC_sawback = 0;
4630
4631     RExC_seen = 0;
4632     RExC_in_lookbehind = 0;
4633     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
4634     RExC_seen_evals = 0;
4635     RExC_extralen = 0;
4636     RExC_override_recoding = 0;
4637
4638     /* First pass: determine size, legality. */
4639     RExC_parse = exp;
4640     RExC_start = exp;
4641     RExC_end = xend;
4642     RExC_naughty = 0;
4643     RExC_npar = 1;
4644     RExC_nestroot = 0;
4645     RExC_size = 0L;
4646     RExC_emit = &PL_regdummy;
4647     RExC_whilem_seen = 0;
4648     RExC_open_parens = NULL;
4649     RExC_close_parens = NULL;
4650     RExC_opend = NULL;
4651     RExC_paren_names = NULL;
4652 #ifdef DEBUGGING
4653     RExC_paren_name_list = NULL;
4654 #endif
4655     RExC_recurse = NULL;
4656     RExC_recurse_count = 0;
4657
4658 #if 0 /* REGC() is (currently) a NOP at the first pass.
4659        * Clever compilers notice this and complain. --jhi */
4660     REGC((U8)REG_MAGIC, (char*)RExC_emit);
4661 #endif
4662     DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n"));
4663     if (reg(pRExC_state, 0, &flags,1) == NULL) {
4664         RExC_precomp = NULL;
4665         return(NULL);
4666     }
4667
4668     /* Here, finished first pass.  Get rid of any added setjmp */
4669     if (used_setjump) {
4670         JMPENV_POP;
4671     }
4672
4673     DEBUG_PARSE_r({
4674         PerlIO_printf(Perl_debug_log, 
4675             "Required size %"IVdf" nodes\n"
4676             "Starting second pass (creation)\n", 
4677             (IV)RExC_size);
4678         RExC_lastnum=0; 
4679         RExC_lastparse=NULL; 
4680     });
4681
4682     /* The first pass could have found things that force Unicode semantics */
4683     if ((RExC_utf8 || RExC_uni_semantics)
4684          && get_regex_charset(pm_flags) == REGEX_DEPENDS_CHARSET)
4685     {
4686         set_regex_charset(&pm_flags, REGEX_UNICODE_CHARSET);
4687     }
4688
4689     /* Small enough for pointer-storage convention?
4690        If extralen==0, this means that we will not need long jumps. */
4691     if (RExC_size >= 0x10000L && RExC_extralen)
4692         RExC_size += RExC_extralen;
4693     else
4694         RExC_extralen = 0;
4695     if (RExC_whilem_seen > 15)
4696         RExC_whilem_seen = 15;
4697
4698     /* Allocate space and zero-initialize. Note, the two step process 
4699        of zeroing when in debug mode, thus anything assigned has to 
4700        happen after that */
4701     rx = (REGEXP*) newSV_type(SVt_REGEXP);
4702     r = (struct regexp*)SvANY(rx);
4703     Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
4704          char, regexp_internal);
4705     if ( r == NULL || ri == NULL )
4706         FAIL("Regexp out of space");
4707 #ifdef DEBUGGING
4708     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
4709     Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode), char);
4710 #else 
4711     /* bulk initialize base fields with 0. */
4712     Zero(ri, sizeof(regexp_internal), char);        
4713 #endif
4714
4715     /* non-zero initialization begins here */
4716     RXi_SET( r, ri );
4717     r->engine= RE_ENGINE_PTR;
4718     r->extflags = pm_flags;
4719     {
4720         bool has_p     = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
4721         bool has_charset = (get_regex_charset(r->extflags) != REGEX_DEPENDS_CHARSET);
4722
4723         /* The caret is output if there are any defaults: if not all the STD
4724          * flags are set, or if no character set specifier is needed */
4725         bool has_default =
4726                     (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
4727                     || ! has_charset);
4728         bool has_runon = ((RExC_seen & REG_SEEN_RUN_ON_COMMENT)==REG_SEEN_RUN_ON_COMMENT);
4729         U16 reganch = (U16)((r->extflags & RXf_PMf_STD_PMMOD)
4730                             >> RXf_PMf_STD_PMMOD_SHIFT);
4731         const char *fptr = STD_PAT_MODS;        /*"msix"*/
4732         char *p;
4733         /* Allocate for the worst case, which is all the std flags are turned
4734          * on.  If more precision is desired, we could do a population count of
4735          * the flags set.  This could be done with a small lookup table, or by
4736          * shifting, masking and adding, or even, when available, assembly
4737          * language for a machine-language population count.
4738          * We never output a minus, as all those are defaults, so are
4739          * covered by the caret */
4740         const STRLEN wraplen = plen + has_p + has_runon
4741             + has_default       /* If needs a caret */
4742
4743                 /* If needs a character set specifier */
4744             + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
4745             + (sizeof(STD_PAT_MODS) - 1)
4746             + (sizeof("(?:)") - 1);
4747
4748         p = sv_grow(MUTABLE_SV(rx), wraplen + 1); /* +1 for the ending NUL */
4749         SvPOK_on(rx);
4750         SvFLAGS(rx) |= SvUTF8(pattern);
4751         *p++='('; *p++='?';
4752
4753         /* If a default, cover it using the caret */
4754         if (has_default) {
4755             *p++= DEFAULT_PAT_MOD;
4756         }
4757         if (has_charset) {
4758             STRLEN len;
4759             const char* const name = get_regex_charset_name(r->extflags, &len);
4760             Copy(name, p, len, char);
4761             p += len;
4762         }
4763         if (has_p)
4764             *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
4765         {
4766             char ch;
4767             while((ch = *fptr++)) {
4768                 if(reganch & 1)
4769                     *p++ = ch;
4770                 reganch >>= 1;
4771             }
4772         }
4773
4774         *p++ = ':';
4775         Copy(RExC_precomp, p, plen, char);
4776         assert ((RX_WRAPPED(rx) - p) < 16);
4777         r->pre_prefix = p - RX_WRAPPED(rx);
4778         p += plen;
4779         if (has_runon)
4780             *p++ = '\n';
4781         *p++ = ')';
4782         *p = 0;
4783         SvCUR_set(rx, p - SvPVX_const(rx));
4784     }
4785
4786     r->intflags = 0;
4787     r->nparens = RExC_npar - 1; /* set early to validate backrefs */
4788     
4789     if (RExC_seen & REG_SEEN_RECURSE) {
4790         Newxz(RExC_open_parens, RExC_npar,regnode *);
4791         SAVEFREEPV(RExC_open_parens);
4792         Newxz(RExC_close_parens,RExC_npar,regnode *);
4793         SAVEFREEPV(RExC_close_parens);
4794     }
4795
4796     /* Useful during FAIL. */
4797 #ifdef RE_TRACK_PATTERN_OFFSETS
4798     Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
4799     DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log,
4800                           "%s %"UVuf" bytes for offset annotations.\n",
4801                           ri->u.offsets ? "Got" : "Couldn't get",
4802                           (UV)((2*RExC_size+1) * sizeof(U32))));
4803 #endif
4804     SetProgLen(ri,RExC_size);
4805     RExC_rx_sv = rx;
4806     RExC_rx = r;
4807     RExC_rxi = ri;
4808     REH_CALL_COMP_BEGIN_HOOK(pRExC_state->rx);
4809
4810     /* Second pass: emit code. */
4811     RExC_flags = pm_flags;      /* don't let top level (?i) bleed */
4812     RExC_parse = exp;
4813     RExC_end = xend;
4814     RExC_naughty = 0;
4815     RExC_npar = 1;
4816     RExC_emit_start = ri->program;
4817     RExC_emit = ri->program;
4818     RExC_emit_bound = ri->program + RExC_size + 1;
4819
4820     /* Store the count of eval-groups for security checks: */
4821     RExC_rx->seen_evals = RExC_seen_evals;
4822     REGC((U8)REG_MAGIC, (char*) RExC_emit++);
4823     if (reg(pRExC_state, 0, &flags,1) == NULL) {
4824         ReREFCNT_dec(rx);   
4825         return(NULL);
4826     }
4827     /* XXXX To minimize changes to RE engine we always allocate
4828        3-units-long substrs field. */
4829     Newx(r->substrs, 1, struct reg_substr_data);
4830     if (RExC_recurse_count) {
4831         Newxz(RExC_recurse,RExC_recurse_count,regnode *);
4832         SAVEFREEPV(RExC_recurse);
4833     }
4834
4835 reStudy:
4836     r->minlen = minlen = sawlookahead = sawplus = sawopen = 0;
4837     Zero(r->substrs, 1, struct reg_substr_data);
4838
4839 #ifdef TRIE_STUDY_OPT
4840     if (!restudied) {
4841         StructCopy(&zero_scan_data, &data, scan_data_t);
4842         copyRExC_state = RExC_state;
4843     } else {
4844         U32 seen=RExC_seen;
4845         DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n"));
4846         
4847         RExC_state = copyRExC_state;
4848         if (seen & REG_TOP_LEVEL_BRANCHES) 
4849             RExC_seen |= REG_TOP_LEVEL_BRANCHES;
4850         else
4851             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES;
4852         if (data.last_found) {
4853             SvREFCNT_dec(data.longest_fixed);
4854             SvREFCNT_dec(data.longest_float);
4855             SvREFCNT_dec(data.last_found);
4856         }
4857         StructCopy(&zero_scan_data, &data, scan_data_t);
4858     }
4859 #else
4860     StructCopy(&zero_scan_data, &data, scan_data_t);
4861 #endif    
4862
4863     /* Dig out information for optimizations. */
4864     r->extflags = RExC_flags; /* was pm_op */
4865     /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
4866  
4867     if (UTF)
4868         SvUTF8_on(rx);  /* Unicode in it? */
4869     ri->regstclass = NULL;
4870     if (RExC_naughty >= 10)     /* Probably an expensive pattern. */
4871         r->intflags |= PREGf_NAUGHTY;
4872     scan = ri->program + 1;             /* First BRANCH. */
4873
4874     /* testing for BRANCH here tells us whether there is "must appear"
4875        data in the pattern. If there is then we can use it for optimisations */
4876     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES)) { /*  Only one top-level choice. */
4877         I32 fake;
4878         STRLEN longest_float_length, longest_fixed_length;
4879         struct regnode_charclass_class ch_class; /* pointed to by data */
4880         int stclass_flag;
4881         I32 last_close = 0; /* pointed to by data */
4882         regnode *first= scan;
4883         regnode *first_next= regnext(first);
4884         /*
4885          * Skip introductions and multiplicators >= 1
4886          * so that we can extract the 'meat' of the pattern that must 
4887          * match in the large if() sequence following.
4888          * NOTE that EXACT is NOT covered here, as it is normally
4889          * picked up by the optimiser separately. 
4890          *
4891          * This is unfortunate as the optimiser isnt handling lookahead
4892          * properly currently.
4893          *
4894          */
4895         while ((OP(first) == OPEN && (sawopen = 1)) ||
4896                /* An OR of *one* alternative - should not happen now. */
4897             (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
4898             /* for now we can't handle lookbehind IFMATCH*/
4899             (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
4900             (OP(first) == PLUS) ||
4901             (OP(first) == MINMOD) ||
4902                /* An {n,m} with n>0 */
4903             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
4904             (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
4905         {
4906                 /* 
4907                  * the only op that could be a regnode is PLUS, all the rest
4908                  * will be regnode_1 or regnode_2.
4909                  *
4910                  */
4911                 if (OP(first) == PLUS)
4912                     sawplus = 1;
4913                 else
4914                     first += regarglen[OP(first)];
4915                 
4916                 first = NEXTOPER(first);
4917                 first_next= regnext(first);
4918         }
4919
4920         /* Starting-point info. */
4921       again:
4922         DEBUG_PEEP("first:",first,0);
4923         /* Ignore EXACT as we deal with it later. */
4924         if (PL_regkind[OP(first)] == EXACT) {
4925             if (OP(first) == EXACT)
4926                 NOOP;   /* Empty, get anchored substr later. */
4927             else
4928                 ri->regstclass = first;
4929         }
4930 #ifdef TRIE_STCLASS     
4931         else if (PL_regkind[OP(first)] == TRIE &&
4932                 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0) 
4933         {
4934             regnode *trie_op;
4935             /* this can happen only on restudy */
4936             if ( OP(first) == TRIE ) {
4937                 struct regnode_1 *trieop = (struct regnode_1 *)
4938                     PerlMemShared_calloc(1, sizeof(struct regnode_1));
4939                 StructCopy(first,trieop,struct regnode_1);
4940                 trie_op=(regnode *)trieop;
4941             } else {
4942                 struct regnode_charclass *trieop = (struct regnode_charclass *)
4943                     PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
4944                 StructCopy(first,trieop,struct regnode_charclass);
4945                 trie_op=(regnode *)trieop;
4946             }
4947             OP(trie_op)+=2;
4948             make_trie_failtable(pRExC_state, (regnode *)first, trie_op, 0);
4949             ri->regstclass = trie_op;
4950         }
4951 #endif  
4952         else if (REGNODE_SIMPLE(OP(first)))
4953             ri->regstclass = first;
4954         else if (PL_regkind[OP(first)] == BOUND ||
4955                  PL_regkind[OP(first)] == NBOUND)
4956             ri->regstclass = first;
4957         else if (PL_regkind[OP(first)] == BOL) {
4958             r->extflags |= (OP(first) == MBOL
4959                            ? RXf_ANCH_MBOL
4960                            : (OP(first) == SBOL
4961                               ? RXf_ANCH_SBOL
4962                               : RXf_ANCH_BOL));
4963             first = NEXTOPER(first);
4964             goto again;
4965         }
4966         else if (OP(first) == GPOS) {
4967             r->extflags |= RXf_ANCH_GPOS;
4968             first = NEXTOPER(first);
4969             goto again;
4970         }
4971         else if ((!sawopen || !RExC_sawback) &&
4972             (OP(first) == STAR &&
4973             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
4974             !(r->extflags & RXf_ANCH) && !(RExC_seen & REG_SEEN_EVAL))
4975         {
4976             /* turn .* into ^.* with an implied $*=1 */
4977             const int type =
4978                 (OP(NEXTOPER(first)) == REG_ANY)
4979                     ? RXf_ANCH_MBOL
4980                     : RXf_ANCH_SBOL;
4981             r->extflags |= type;
4982             r->intflags |= PREGf_IMPLICIT;
4983             first = NEXTOPER(first);
4984             goto again;
4985         }
4986         if (sawplus && !sawlookahead && (!sawopen || !RExC_sawback)
4987             && !(RExC_seen & REG_SEEN_EVAL)) /* May examine pos and $& */
4988             /* x+ must match at the 1st pos of run of x's */
4989             r->intflags |= PREGf_SKIP;
4990
4991         /* Scan is after the zeroth branch, first is atomic matcher. */
4992 #ifdef TRIE_STUDY_OPT
4993         DEBUG_PARSE_r(
4994             if (!restudied)
4995                 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
4996                               (IV)(first - scan + 1))
4997         );
4998 #else
4999         DEBUG_PARSE_r(
5000             PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
5001                 (IV)(first - scan + 1))
5002         );
5003 #endif
5004
5005
5006         /*
5007         * If there's something expensive in the r.e., find the
5008         * longest literal string that must appear and make it the
5009         * regmust.  Resolve ties in favor of later strings, since
5010         * the regstart check works with the beginning of the r.e.
5011         * and avoiding duplication strengthens checking.  Not a
5012         * strong reason, but sufficient in the absence of others.
5013         * [Now we resolve ties in favor of the earlier string if
5014         * it happens that c_offset_min has been invalidated, since the
5015         * earlier string may buy us something the later one won't.]
5016         */
5017         
5018         data.longest_fixed = newSVpvs("");
5019         data.longest_float = newSVpvs("");
5020         data.last_found = newSVpvs("");
5021         data.longest = &(data.longest_fixed);
5022         first = scan;
5023         if (!ri->regstclass) {
5024             cl_init(pRExC_state, &ch_class);
5025             data.start_class = &ch_class;
5026             stclass_flag = SCF_DO_STCLASS_AND;
5027         } else                          /* XXXX Check for BOUND? */
5028             stclass_flag = 0;
5029         data.last_closep = &last_close;
5030         
5031         minlen = study_chunk(pRExC_state, &first, &minlen, &fake, scan + RExC_size, /* Up to end */
5032             &data, -1, NULL, NULL,
5033             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0);
5034
5035         
5036         CHECK_RESTUDY_GOTO;
5037
5038
5039         if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
5040              && data.last_start_min == 0 && data.last_end > 0
5041              && !RExC_seen_zerolen
5042              && !(RExC_seen & REG_SEEN_VERBARG)
5043              && (!(RExC_seen & REG_SEEN_GPOS) || (r->extflags & RXf_ANCH_GPOS)))
5044             r->extflags |= RXf_CHECK_ALL;
5045         scan_commit(pRExC_state, &data,&minlen,0);
5046         SvREFCNT_dec(data.last_found);
5047
5048         /* Note that code very similar to this but for anchored string 
5049            follows immediately below, changes may need to be made to both. 
5050            Be careful. 
5051          */
5052         longest_float_length = CHR_SVLEN(data.longest_float);
5053         if (longest_float_length
5054             || (data.flags & SF_FL_BEFORE_EOL
5055                 && (!(data.flags & SF_FL_BEFORE_MEOL)
5056                     || (RExC_flags & RXf_PMf_MULTILINE)))) 
5057         {
5058             I32 t,ml;
5059
5060             if (SvCUR(data.longest_fixed)  /* ok to leave SvCUR */
5061                 && data.offset_fixed == data.offset_float_min
5062                 && SvCUR(data.longest_fixed) == SvCUR(data.longest_float))
5063                     goto remove_float;          /* As in (a)+. */
5064
5065             /* copy the information about the longest float from the reg_scan_data
5066                over to the program. */
5067             if (SvUTF8(data.longest_float)) {
5068                 r->float_utf8 = data.longest_float;
5069                 r->float_substr = NULL;
5070             } else {
5071                 r->float_substr = data.longest_float;
5072                 r->float_utf8 = NULL;
5073             }
5074             /* float_end_shift is how many chars that must be matched that 
5075                follow this item. We calculate it ahead of time as once the
5076                lookbehind offset is added in we lose the ability to correctly
5077                calculate it.*/
5078             ml = data.minlen_float ? *(data.minlen_float) 
5079                                    : (I32)longest_float_length;
5080             r->float_end_shift = ml - data.offset_float_min
5081                 - longest_float_length + (SvTAIL(data.longest_float) != 0)
5082                 + data.lookbehind_float;
5083             r->float_min_offset = data.offset_float_min - data.lookbehind_float;
5084             r->float_max_offset = data.offset_float_max;
5085             if (data.offset_float_max < I32_MAX) /* Don't offset infinity */
5086                 r->float_max_offset -= data.lookbehind_float;
5087             
5088             t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */
5089                        && (!(data.flags & SF_FL_BEFORE_MEOL)
5090                            || (RExC_flags & RXf_PMf_MULTILINE)));
5091             fbm_compile(data.longest_float, t ? FBMcf_TAIL : 0);
5092         }
5093         else {
5094           remove_float:
5095             r->float_substr = r->float_utf8 = NULL;
5096             SvREFCNT_dec(data.longest_float);
5097             longest_float_length = 0;
5098         }
5099
5100         /* Note that code very similar to this but for floating string 
5101            is immediately above, changes may need to be made to both. 
5102            Be careful. 
5103          */
5104         longest_fixed_length = CHR_SVLEN(data.longest_fixed);
5105         if (longest_fixed_length
5106             || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
5107                 && (!(data.flags & SF_FIX_BEFORE_MEOL)
5108                     || (RExC_flags & RXf_PMf_MULTILINE)))) 
5109         {
5110             I32 t,ml;
5111
5112             /* copy the information about the longest fixed 
5113                from the reg_scan_data over to the program. */
5114             if (SvUTF8(data.longest_fixed)) {
5115                 r->anchored_utf8 = data.longest_fixed;
5116                 r->anchored_substr = NULL;
5117             } else {
5118                 r->anchored_substr = data.longest_fixed;
5119                 r->anchored_utf8 = NULL;
5120             }
5121             /* fixed_end_shift is how many chars that must be matched that 
5122                follow this item. We calculate it ahead of time as once the
5123                lookbehind offset is added in we lose the ability to correctly
5124                calculate it.*/
5125             ml = data.minlen_fixed ? *(data.minlen_fixed) 
5126                                    : (I32)longest_fixed_length;
5127             r->anchored_end_shift = ml - data.offset_fixed
5128                 - longest_fixed_length + (SvTAIL(data.longest_fixed) != 0)
5129                 + data.lookbehind_fixed;
5130             r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
5131
5132             t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */
5133                  && (!(data.flags & SF_FIX_BEFORE_MEOL)
5134                      || (RExC_flags & RXf_PMf_MULTILINE)));
5135             fbm_compile(data.longest_fixed, t ? FBMcf_TAIL : 0);
5136         }
5137         else {
5138             r->anchored_substr = r->anchored_utf8 = NULL;
5139             SvREFCNT_dec(data.longest_fixed);
5140             longest_fixed_length = 0;
5141         }
5142         if (ri->regstclass
5143             && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
5144             ri->regstclass = NULL;
5145
5146         if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
5147             && stclass_flag
5148             && !(data.start_class->flags & ANYOF_EOS)
5149             && !cl_is_anything(data.start_class))
5150         {
5151             const U32 n = add_data(pRExC_state, 1, "f");
5152             data.start_class->flags |= ANYOF_IS_SYNTHETIC;
5153
5154             Newx(RExC_rxi->data->data[n], 1,
5155                 struct regnode_charclass_class);
5156             StructCopy(data.start_class,
5157                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
5158                        struct regnode_charclass_class);
5159             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
5160             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
5161             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
5162                       regprop(r, sv, (regnode*)data.start_class);
5163                       PerlIO_printf(Perl_debug_log,
5164                                     "synthetic stclass \"%s\".\n",
5165                                     SvPVX_const(sv));});
5166         }
5167
5168         /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
5169         if (longest_fixed_length > longest_float_length) {
5170             r->check_end_shift = r->anchored_end_shift;
5171             r->check_substr = r->anchored_substr;
5172             r->check_utf8 = r->anchored_utf8;
5173             r->check_offset_min = r->check_offset_max = r->anchored_offset;
5174             if (r->extflags & RXf_ANCH_SINGLE)
5175                 r->extflags |= RXf_NOSCAN;
5176         }
5177         else {
5178             r->check_end_shift = r->float_end_shift;
5179             r->check_substr = r->float_substr;
5180             r->check_utf8 = r->float_utf8;
5181             r->check_offset_min = r->float_min_offset;
5182             r->check_offset_max = r->float_max_offset;
5183         }
5184         /* XXXX Currently intuiting is not compatible with ANCH_GPOS.
5185            This should be changed ASAP!  */
5186         if ((r->check_substr || r->check_utf8) && !(r->extflags & RXf_ANCH_GPOS)) {
5187             r->extflags |= RXf_USE_INTUIT;
5188             if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
5189                 r->extflags |= RXf_INTUIT_TAIL;
5190         }
5191         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
5192         if ( (STRLEN)minlen < longest_float_length )
5193             minlen= longest_float_length;
5194         if ( (STRLEN)minlen < longest_fixed_length )
5195             minlen= longest_fixed_length;     
5196         */
5197     }
5198     else {
5199         /* Several toplevels. Best we can is to set minlen. */
5200         I32 fake;
5201         struct regnode_charclass_class ch_class;
5202         I32 last_close = 0;
5203         
5204         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n"));
5205
5206         scan = ri->program + 1;
5207         cl_init(pRExC_state, &ch_class);
5208         data.start_class = &ch_class;
5209         data.last_closep = &last_close;
5210
5211         
5212         minlen = study_chunk(pRExC_state, &scan, &minlen, &fake, scan + RExC_size,
5213             &data, -1, NULL, NULL, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0);
5214         
5215         CHECK_RESTUDY_GOTO;
5216
5217         r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
5218                 = r->float_substr = r->float_utf8 = NULL;
5219
5220         if (!(data.start_class->flags & ANYOF_EOS)
5221             && !cl_is_anything(data.start_class))
5222         {
5223             const U32 n = add_data(pRExC_state, 1, "f");
5224             data.start_class->flags |= ANYOF_IS_SYNTHETIC;
5225
5226             Newx(RExC_rxi->data->data[n], 1,
5227                 struct regnode_charclass_class);
5228             StructCopy(data.start_class,
5229                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
5230                        struct regnode_charclass_class);
5231             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
5232             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
5233             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
5234                       regprop(r, sv, (regnode*)data.start_class);
5235                       PerlIO_printf(Perl_debug_log,
5236                                     "synthetic stclass \"%s\".\n",
5237                                     SvPVX_const(sv));});
5238         }
5239     }
5240
5241     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
5242        the "real" pattern. */
5243     DEBUG_OPTIMISE_r({
5244         PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf"\n",
5245                       (IV)minlen, (IV)r->minlen);
5246     });
5247     r->minlenret = minlen;
5248     if (r->minlen < minlen) 
5249         r->minlen = minlen;
5250     
5251     if (RExC_seen & REG_SEEN_GPOS)
5252         r->extflags |= RXf_GPOS_SEEN;
5253     if (RExC_seen & REG_SEEN_LOOKBEHIND)
5254         r->extflags |= RXf_LOOKBEHIND_SEEN;
5255     if (RExC_seen & REG_SEEN_EVAL)
5256         r->extflags |= RXf_EVAL_SEEN;
5257     if (RExC_seen & REG_SEEN_CANY)
5258         r->extflags |= RXf_CANY_SEEN;
5259     if (RExC_seen & REG_SEEN_VERBARG)
5260         r->intflags |= PREGf_VERBARG_SEEN;
5261     if (RExC_seen & REG_SEEN_CUTGROUP)
5262         r->intflags |= PREGf_CUTGROUP_SEEN;
5263     if (RExC_paren_names)
5264         RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
5265     else
5266         RXp_PAREN_NAMES(r) = NULL;
5267
5268 #ifdef STUPID_PATTERN_CHECKS            
5269     if (RX_PRELEN(rx) == 0)
5270         r->extflags |= RXf_NULL;
5271     if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
5272         /* XXX: this should happen BEFORE we compile */
5273         r->extflags |= (RXf_SKIPWHITE|RXf_WHITE); 
5274     else if (RX_PRELEN(rx) == 3 && memEQ("\\s+", RX_PRECOMP(rx), 3))
5275         r->extflags |= RXf_WHITE;
5276     else if (RX_PRELEN(rx) == 1 && RXp_PRECOMP(rx)[0] == '^')
5277         r->extflags |= RXf_START_ONLY;
5278 #else
5279     if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
5280             /* XXX: this should happen BEFORE we compile */
5281             r->extflags |= (RXf_SKIPWHITE|RXf_WHITE); 
5282     else {
5283         regnode *first = ri->program + 1;
5284         U8 fop = OP(first);
5285
5286         if (PL_regkind[fop] == NOTHING && OP(NEXTOPER(first)) == END)
5287             r->extflags |= RXf_NULL;
5288         else if (PL_regkind[fop] == BOL && OP(NEXTOPER(first)) == END)
5289             r->extflags |= RXf_START_ONLY;
5290         else if (fop == PLUS && OP(NEXTOPER(first)) == SPACE
5291                              && OP(regnext(first)) == END)
5292             r->extflags |= RXf_WHITE;    
5293     }
5294 #endif
5295 #ifdef DEBUGGING
5296     if (RExC_paren_names) {
5297         ri->name_list_idx = add_data( pRExC_state, 1, "a" );
5298         ri->data->data[ri->name_list_idx] = (void*)SvREFCNT_inc(RExC_paren_name_list);
5299     } else
5300 #endif
5301         ri->name_list_idx = 0;
5302
5303     if (RExC_recurse_count) {
5304         for ( ; RExC_recurse_count ; RExC_recurse_count-- ) {
5305             const regnode *scan = RExC_recurse[RExC_recurse_count-1];
5306             ARG2L_SET( scan, RExC_open_parens[ARG(scan)-1] - scan );
5307         }
5308     }
5309     Newxz(r->offs, RExC_npar, regexp_paren_pair);
5310     /* assume we don't need to swap parens around before we match */
5311
5312     DEBUG_DUMP_r({
5313         PerlIO_printf(Perl_debug_log,"Final program:\n");
5314         regdump(r);
5315     });
5316 #ifdef RE_TRACK_PATTERN_OFFSETS
5317     DEBUG_OFFSETS_r(if (ri->u.offsets) {
5318         const U32 len = ri->u.offsets[0];
5319         U32 i;
5320         GET_RE_DEBUG_FLAGS_DECL;
5321         PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)ri->u.offsets[0]);
5322         for (i = 1; i <= len; i++) {
5323             if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
5324                 PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
5325                 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
5326             }
5327         PerlIO_printf(Perl_debug_log, "\n");
5328     });
5329 #endif
5330     return rx;
5331 }
5332
5333 #undef RE_ENGINE_PTR
5334
5335
5336 SV*
5337 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
5338                     const U32 flags)
5339 {
5340     PERL_ARGS_ASSERT_REG_NAMED_BUFF;
5341
5342     PERL_UNUSED_ARG(value);
5343
5344     if (flags & RXapif_FETCH) {
5345         return reg_named_buff_fetch(rx, key, flags);
5346     } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
5347         Perl_croak_no_modify(aTHX);
5348         return NULL;
5349     } else if (flags & RXapif_EXISTS) {
5350         return reg_named_buff_exists(rx, key, flags)
5351             ? &PL_sv_yes
5352             : &PL_sv_no;
5353     } else if (flags & RXapif_REGNAMES) {
5354         return reg_named_buff_all(rx, flags);
5355     } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
5356         return reg_named_buff_scalar(rx, flags);
5357     } else {
5358         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
5359         return NULL;
5360     }
5361 }
5362
5363 SV*
5364 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
5365                          const U32 flags)
5366 {
5367     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
5368     PERL_UNUSED_ARG(lastkey);
5369
5370     if (flags & RXapif_FIRSTKEY)
5371         return reg_named_buff_firstkey(rx, flags);
5372     else if (flags & RXapif_NEXTKEY)
5373         return reg_named_buff_nextkey(rx, flags);
5374     else {
5375         Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter", (int)flags);
5376         return NULL;
5377     }
5378 }
5379
5380 SV*
5381 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
5382                           const U32 flags)
5383 {
5384     AV *retarray = NULL;
5385     SV *ret;
5386     struct regexp *const rx = (struct regexp *)SvANY(r);
5387
5388     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
5389
5390     if (flags & RXapif_ALL)
5391         retarray=newAV();
5392
5393     if (rx && RXp_PAREN_NAMES(rx)) {
5394         HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
5395         if (he_str) {
5396             IV i;
5397             SV* sv_dat=HeVAL(he_str);
5398             I32 *nums=(I32*)SvPVX(sv_dat);
5399             for ( i=0; i<SvIVX(sv_dat); i++ ) {
5400                 if ((I32)(rx->nparens) >= nums[i]
5401                     && rx->offs[nums[i]].start != -1
5402                     && rx->offs[nums[i]].end != -1)
5403                 {
5404                     ret = newSVpvs("");
5405                     CALLREG_NUMBUF_FETCH(r,nums[i],ret);
5406                     if (!retarray)
5407                         return ret;
5408                 } else {
5409                     ret = newSVsv(&PL_sv_undef);
5410                 }
5411                 if (retarray)
5412                     av_push(retarray, ret);
5413             }
5414             if (retarray)
5415                 return newRV_noinc(MUTABLE_SV(retarray));
5416         }
5417     }
5418     return NULL;
5419 }
5420
5421 bool
5422 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
5423                            const U32 flags)
5424 {
5425     struct regexp *const rx = (struct regexp *)SvANY(r);
5426
5427     PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
5428
5429     if (rx && RXp_PAREN_NAMES(rx)) {
5430         if (flags & RXapif_ALL) {
5431             return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
5432         } else {
5433             SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
5434             if (sv) {
5435                 SvREFCNT_dec(sv);
5436                 return TRUE;
5437             } else {
5438                 return FALSE;
5439             }
5440         }
5441     } else {
5442         return FALSE;
5443     }
5444 }
5445
5446 SV*
5447 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
5448 {
5449     struct regexp *const rx = (struct regexp *)SvANY(r);
5450
5451     PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
5452
5453     if ( rx && RXp_PAREN_NAMES(rx) ) {
5454         (void)hv_iterinit(RXp_PAREN_NAMES(rx));
5455
5456         return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
5457     } else {
5458         return FALSE;
5459     }
5460 }
5461
5462 SV*
5463 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
5464 {
5465     struct regexp *const rx = (struct regexp *)SvANY(r);
5466     GET_RE_DEBUG_FLAGS_DECL;
5467
5468     PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
5469
5470     if (rx && RXp_PAREN_NAMES(rx)) {
5471         HV *hv = RXp_PAREN_NAMES(rx);
5472         HE *temphe;
5473         while ( (temphe = hv_iternext_flags(hv,0)) ) {
5474             IV i;
5475             IV parno = 0;
5476             SV* sv_dat = HeVAL(temphe);
5477             I32 *nums = (I32*)SvPVX(sv_dat);
5478             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
5479                 if ((I32)(rx->lastparen) >= nums[i] &&
5480                     rx->offs[nums[i]].start != -1 &&
5481                     rx->offs[nums[i]].end != -1)
5482                 {
5483                     parno = nums[i];
5484                     break;
5485                 }
5486             }
5487             if (parno || flags & RXapif_ALL) {
5488                 return newSVhek(HeKEY_hek(temphe));
5489             }
5490         }
5491     }
5492     return NULL;
5493 }
5494
5495 SV*
5496 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
5497 {
5498     SV *ret;
5499     AV *av;
5500     I32 length;
5501     struct regexp *const rx = (struct regexp *)SvANY(r);
5502
5503     PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
5504
5505     if (rx && RXp_PAREN_NAMES(rx)) {
5506         if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
5507             return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
5508         } else if (flags & RXapif_ONE) {
5509             ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
5510             av = MUTABLE_AV(SvRV(ret));
5511             length = av_len(av);
5512             SvREFCNT_dec(ret);
5513             return newSViv(length + 1);
5514         } else {
5515             Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar", (int)flags);
5516             return NULL;
5517         }
5518     }
5519     return &PL_sv_undef;
5520 }
5521
5522 SV*
5523 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
5524 {
5525     struct regexp *const rx = (struct regexp *)SvANY(r);
5526     AV *av = newAV();
5527
5528     PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
5529
5530     if (rx && RXp_PAREN_NAMES(rx)) {
5531         HV *hv= RXp_PAREN_NAMES(rx);
5532         HE *temphe;
5533         (void)hv_iterinit(hv);
5534         while ( (temphe = hv_iternext_flags(hv,0)) ) {
5535             IV i;
5536             IV parno = 0;
5537             SV* sv_dat = HeVAL(temphe);
5538             I32 *nums = (I32*)SvPVX(sv_dat);
5539             for ( i = 0; i < SvIVX(sv_dat); i++ ) {
5540                 if ((I32)(rx->lastparen) >= nums[i] &&
5541                     rx->offs[nums[i]].start != -1 &&
5542                     rx->offs[nums[i]].end != -1)
5543                 {
5544                     parno = nums[i];
5545                     break;
5546                 }
5547             }
5548             if (parno || flags & RXapif_ALL) {
5549                 av_push(av, newSVhek(HeKEY_hek(temphe)));
5550             }
5551         }
5552     }
5553
5554     return newRV_noinc(MUTABLE_SV(av));
5555 }
5556
5557 void
5558 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
5559                              SV * const sv)
5560 {
5561     struct regexp *const rx = (struct regexp *)SvANY(r);
5562     char *s = NULL;
5563     I32 i = 0;
5564     I32 s1, t1;
5565
5566     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
5567         
5568     if (!rx->subbeg) {
5569         sv_setsv(sv,&PL_sv_undef);
5570         return;
5571     } 
5572     else               
5573     if (paren == RX_BUFF_IDX_PREMATCH && rx->offs[0].start != -1) {
5574         /* $` */
5575         i = rx->offs[0].start;
5576         s = rx->subbeg;
5577     }
5578     else 
5579     if (paren == RX_BUFF_IDX_POSTMATCH && rx->offs[0].end != -1) {
5580         /* $' */
5581         s = rx->subbeg + rx->offs[0].end;
5582         i = rx->sublen - rx->offs[0].end;
5583     } 
5584     else
5585     if ( 0 <= paren && paren <= (I32)rx->nparens &&
5586         (s1 = rx->offs[paren].start) != -1 &&
5587         (t1 = rx->offs[paren].end) != -1)
5588     {
5589         /* $& $1 ... */
5590         i = t1 - s1;
5591         s = rx->subbeg + s1;
5592     } else {
5593         sv_setsv(sv,&PL_sv_undef);
5594         return;
5595     }          
5596     assert(rx->sublen >= (s - rx->subbeg) + i );
5597     if (i >= 0) {
5598         const int oldtainted = PL_tainted;
5599         TAINT_NOT;
5600         sv_setpvn(sv, s, i);
5601         PL_tainted = oldtainted;
5602         if ( (rx->extflags & RXf_CANY_SEEN)
5603             ? (RXp_MATCH_UTF8(rx)
5604                         && (!i || is_utf8_string((U8*)s, i)))
5605             : (RXp_MATCH_UTF8(rx)) )
5606         {
5607             SvUTF8_on(sv);
5608         }
5609         else
5610             SvUTF8_off(sv);
5611         if (PL_tainting) {
5612             if (RXp_MATCH_TAINTED(rx)) {
5613                 if (SvTYPE(sv) >= SVt_PVMG) {
5614                     MAGIC* const mg = SvMAGIC(sv);
5615                     MAGIC* mgt;
5616                     PL_tainted = 1;
5617                     SvMAGIC_set(sv, mg->mg_moremagic);
5618                     SvTAINT(sv);
5619                     if ((mgt = SvMAGIC(sv))) {
5620                         mg->mg_moremagic = mgt;
5621                         SvMAGIC_set(sv, mg);
5622                     }
5623                 } else {
5624                     PL_tainted = 1;
5625                     SvTAINT(sv);
5626                 }
5627             } else 
5628                 SvTAINTED_off(sv);
5629         }
5630     } else {
5631         sv_setsv(sv,&PL_sv_undef);
5632         return;
5633     }
5634 }
5635
5636 void
5637 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
5638                                                          SV const * const value)
5639 {
5640     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
5641
5642     PERL_UNUSED_ARG(rx);
5643     PERL_UNUSED_ARG(paren);
5644     PERL_UNUSED_ARG(value);
5645
5646     if (!PL_localizing)
5647         Perl_croak_no_modify(aTHX);
5648 }
5649
5650 I32
5651 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
5652                               const I32 paren)
5653 {
5654     struct regexp *const rx = (struct regexp *)SvANY(r);
5655     I32 i;
5656     I32 s1, t1;
5657
5658     PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
5659
5660     /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
5661         switch (paren) {
5662       /* $` / ${^PREMATCH} */
5663       case RX_BUFF_IDX_PREMATCH:
5664         if (rx->offs[0].start != -1) {
5665                         i = rx->offs[0].start;
5666                         if (i > 0) {
5667                                 s1 = 0;
5668                                 t1 = i;
5669                                 goto getlen;
5670                         }
5671             }
5672         return 0;
5673       /* $' / ${^POSTMATCH} */
5674       case RX_BUFF_IDX_POSTMATCH:
5675             if (rx->offs[0].end != -1) {
5676                         i = rx->sublen - rx->offs[0].end;
5677                         if (i > 0) {
5678                                 s1 = rx->offs[0].end;
5679                                 t1 = rx->sublen;
5680                                 goto getlen;
5681                         }
5682             }
5683         return 0;
5684       /* $& / ${^MATCH}, $1, $2, ... */
5685       default:
5686             if (paren <= (I32)rx->nparens &&
5687             (s1 = rx->offs[paren].start) != -1 &&
5688             (t1 = rx->offs[paren].end) != -1)
5689             {
5690             i = t1 - s1;
5691             goto getlen;
5692         } else {
5693             if (ckWARN(WARN_UNINITIALIZED))
5694                 report_uninit((const SV *)sv);
5695             return 0;
5696         }
5697     }
5698   getlen:
5699     if (i > 0 && RXp_MATCH_UTF8(rx)) {
5700         const char * const s = rx->subbeg + s1;
5701         const U8 *ep;
5702         STRLEN el;
5703
5704         i = t1 - s1;
5705         if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
5706                         i = el;
5707     }
5708     return i;
5709 }
5710
5711 SV*
5712 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
5713 {
5714     PERL_ARGS_ASSERT_REG_QR_PACKAGE;
5715         PERL_UNUSED_ARG(rx);
5716         if (0)
5717             return NULL;
5718         else
5719             return newSVpvs("Regexp");
5720 }
5721
5722 /* Scans the name of a named buffer from the pattern.
5723  * If flags is REG_RSN_RETURN_NULL returns null.
5724  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
5725  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
5726  * to the parsed name as looked up in the RExC_paren_names hash.
5727  * If there is an error throws a vFAIL().. type exception.
5728  */
5729
5730 #define REG_RSN_RETURN_NULL    0
5731 #define REG_RSN_RETURN_NAME    1
5732 #define REG_RSN_RETURN_DATA    2
5733
5734 STATIC SV*
5735 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
5736 {
5737     char *name_start = RExC_parse;
5738
5739     PERL_ARGS_ASSERT_REG_SCAN_NAME;
5740
5741     if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
5742          /* skip IDFIRST by using do...while */
5743         if (UTF)
5744             do {
5745                 RExC_parse += UTF8SKIP(RExC_parse);
5746             } while (isALNUM_utf8((U8*)RExC_parse));
5747         else
5748             do {
5749                 RExC_parse++;
5750             } while (isALNUM(*RExC_parse));
5751     }
5752
5753     if ( flags ) {
5754         SV* sv_name
5755             = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
5756                              SVs_TEMP | (UTF ? SVf_UTF8 : 0));
5757         if ( flags == REG_RSN_RETURN_NAME)
5758             return sv_name;
5759         else if (flags==REG_RSN_RETURN_DATA) {
5760             HE *he_str = NULL;
5761             SV *sv_dat = NULL;
5762             if ( ! sv_name )      /* should not happen*/
5763                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
5764             if (RExC_paren_names)
5765                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
5766             if ( he_str )
5767                 sv_dat = HeVAL(he_str);
5768             if ( ! sv_dat )
5769                 vFAIL("Reference to nonexistent named group");
5770             return sv_dat;
5771         }
5772         else {
5773             Perl_croak(aTHX_ "panic: bad flag in reg_scan_name");
5774         }
5775         /* NOT REACHED */
5776     }
5777     return NULL;
5778 }
5779
5780 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
5781     int rem=(int)(RExC_end - RExC_parse);                       \
5782     int cut;                                                    \
5783     int num;                                                    \
5784     int iscut=0;                                                \
5785     if (rem>10) {                                               \
5786         rem=10;                                                 \
5787         iscut=1;                                                \
5788     }                                                           \
5789     cut=10-rem;                                                 \
5790     if (RExC_lastparse!=RExC_parse)                             \
5791         PerlIO_printf(Perl_debug_log," >%.*s%-*s",              \
5792             rem, RExC_parse,                                    \
5793             cut + 4,                                            \
5794             iscut ? "..." : "<"                                 \
5795         );                                                      \
5796     else                                                        \
5797         PerlIO_printf(Perl_debug_log,"%16s","");                \
5798                                                                 \
5799     if (SIZE_ONLY)                                              \
5800        num = RExC_size + 1;                                     \
5801     else                                                        \
5802        num=REG_NODE_NUM(RExC_emit);                             \
5803     if (RExC_lastnum!=num)                                      \
5804        PerlIO_printf(Perl_debug_log,"|%4d",num);                \
5805     else                                                        \
5806        PerlIO_printf(Perl_debug_log,"|%4s","");                 \
5807     PerlIO_printf(Perl_debug_log,"|%*s%-4s",                    \
5808         (int)((depth*2)), "",                                   \
5809         (funcname)                                              \
5810     );                                                          \
5811     RExC_lastnum=num;                                           \
5812     RExC_lastparse=RExC_parse;                                  \
5813 })
5814
5815
5816
5817 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
5818     DEBUG_PARSE_MSG((funcname));                            \
5819     PerlIO_printf(Perl_debug_log,"%4s","\n");               \
5820 })
5821 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({           \
5822     DEBUG_PARSE_MSG((funcname));                            \
5823     PerlIO_printf(Perl_debug_log,fmt "\n",args);               \
5824 })
5825
5826 /* This section of code defines the inversion list object and its methods.  The
5827  * interfaces are highly subject to change, so as much as possible is static to
5828  * this file.  An inversion list is here implemented as a malloc'd C array with
5829  * some added info.  More will be coming when functionality is added later.
5830  *
5831  * It is currently implemented as an HV to the outside world, but is actually
5832  * an SV pointing to an array of UVs that the SV thinks are bytes.  This allows
5833  * us to have an array of UV whose memory management is automatically handled
5834  * by the existing facilities for SV's.
5835  *
5836  * Some of the methods should always be private to the implementation, and some
5837  * should eventually be made public */
5838
5839 #define INVLIST_INITIAL_LEN 10
5840
5841 PERL_STATIC_INLINE UV*
5842 S_invlist_array(pTHX_ HV* const invlist)
5843 {
5844     /* Returns the pointer to the inversion list's array.  Every time the
5845      * length changes, this needs to be called in case malloc or realloc moved
5846      * it */
5847
5848     PERL_ARGS_ASSERT_INVLIST_ARRAY;
5849
5850     return (UV *) SvPVX(invlist);
5851 }
5852
5853 PERL_STATIC_INLINE UV
5854 S_invlist_len(pTHX_ HV* const invlist)
5855 {
5856     /* Returns the current number of elements in the inversion list's array */
5857
5858     PERL_ARGS_ASSERT_INVLIST_LEN;
5859
5860     return SvCUR(invlist) / sizeof(UV);
5861 }
5862
5863 PERL_STATIC_INLINE UV
5864 S_invlist_max(pTHX_ HV* const invlist)
5865 {
5866     /* Returns the maximum number of elements storable in the inversion list's
5867      * array, without having to realloc() */
5868
5869     PERL_ARGS_ASSERT_INVLIST_MAX;
5870
5871     return SvLEN(invlist) / sizeof(UV);
5872 }
5873
5874 PERL_STATIC_INLINE void
5875 S_invlist_set_len(pTHX_ HV* const invlist, const UV len)
5876 {
5877     /* Sets the current number of elements stored in the inversion list */
5878
5879     PERL_ARGS_ASSERT_INVLIST_SET_LEN;
5880
5881     SvCUR_set(invlist, len * sizeof(UV));
5882 }
5883
5884 PERL_STATIC_INLINE void
5885 S_invlist_set_max(pTHX_ HV* const invlist, const UV max)
5886 {
5887
5888     /* Sets the maximum number of elements storable in the inversion list
5889      * without having to realloc() */
5890
5891     PERL_ARGS_ASSERT_INVLIST_SET_MAX;
5892
5893     if (max < invlist_len(invlist)) {
5894         Perl_croak(aTHX_ "panic: Can't make max size '%"UVuf"' less than current length %"UVuf" in inversion list", invlist_max(invlist), invlist_len(invlist));
5895     }
5896
5897     SvLEN_set(invlist, max * sizeof(UV));
5898 }
5899
5900 #ifndef PERL_IN_XSUB_RE
5901 HV*
5902 Perl__new_invlist(pTHX_ IV initial_size)
5903 {
5904
5905     /* Return a pointer to a newly constructed inversion list, with enough
5906      * space to store 'initial_size' elements.  If that number is negative, a
5907      * system default is used instead */
5908
5909     if (initial_size < 0) {
5910         initial_size = INVLIST_INITIAL_LEN;
5911     }
5912
5913     /* Allocate the initial space */
5914     return (HV *) newSV(initial_size * sizeof(UV));
5915 }
5916 #endif
5917
5918 PERL_STATIC_INLINE void
5919 S_invlist_destroy(pTHX_ HV* const invlist)
5920 {
5921    /* Inversion list destructor */
5922
5923     PERL_ARGS_ASSERT_INVLIST_DESTROY;
5924
5925     SvREFCNT_dec(invlist);
5926 }
5927
5928 STATIC void
5929 S_invlist_extend(pTHX_ HV* const invlist, const UV new_max)
5930 {
5931     /* Grow the maximum size of an inversion list */
5932
5933     PERL_ARGS_ASSERT_INVLIST_EXTEND;
5934
5935     SvGROW((SV *)invlist, new_max * sizeof(UV));
5936 }
5937
5938 PERL_STATIC_INLINE void
5939 S_invlist_trim(pTHX_ HV* const invlist)
5940 {
5941     PERL_ARGS_ASSERT_INVLIST_TRIM;
5942
5943     /* Change the length of the inversion list to how many entries it currently
5944      * has */
5945
5946     SvPV_shrink_to_cur((SV *) invlist);
5947 }
5948
5949 /* An element is in an inversion list iff its index is even numbered: 0, 2, 4,
5950  * etc */
5951
5952 #define ELEMENT_IN_INVLIST_SET(i) (! ((i) & 1))
5953
5954 #ifndef PERL_IN_XSUB_RE
5955 void
5956 Perl__append_range_to_invlist(pTHX_ HV* const invlist, const UV start, const UV end)
5957 {
5958    /* Subject to change or removal.  Append the range from 'start' to 'end' at
5959     * the end of the inversion list.  The range must be above any existing
5960     * ones. */
5961
5962     UV* array = invlist_array(invlist);
5963     UV max = invlist_max(invlist);
5964     UV len = invlist_len(invlist);
5965
5966     PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
5967
5968     if (len > 0) {
5969
5970         /* Here, the existing list is non-empty. The current max entry in the
5971          * list is generally the first value not in the set, except when the
5972          * set extends to the end of permissible values, in which case it is
5973          * the first entry in that final set, and so this call is an attempt to
5974          * append out-of-order */
5975
5976         UV final_element = len - 1;
5977         if (array[final_element] > start
5978             || ELEMENT_IN_INVLIST_SET(final_element))
5979         {
5980             Perl_croak(aTHX_ "panic: attempting to append to an inversion list, but wasn't at the end of the list");
5981         }
5982
5983         /* Here, it is a legal append.  If the new range begins with the first
5984          * value not in the set, it is extending the set, so the new first
5985          * value not in the set is one greater than the newly extended range.
5986          * */
5987         if (array[final_element] == start) {
5988             if (end != UV_MAX) {
5989                 array[final_element] = end + 1;
5990             }
5991             else {
5992                 /* But if the end is the maximum representable on the machine,
5993                  * just let the range that this would extend have no end */
5994                 invlist_set_len(invlist, len - 1);
5995             }
5996             return;
5997         }
5998     }
5999
6000     /* Here the new range doesn't extend any existing set.  Add it */
6001
6002     len += 2;   /* Includes an element each for the start and end of range */
6003
6004     /* If overflows the existing space, extend, which may cause the array to be
6005      * moved */
6006     if (max < len) {
6007         invlist_extend(invlist, len);
6008         array = invlist_array(invlist);
6009     }
6010
6011     invlist_set_len(invlist, len);
6012
6013     /* The next item on the list starts the range, the one after that is
6014      * one past the new range.  */
6015     array[len - 2] = start;
6016     if (end != UV_MAX) {
6017         array[len - 1] = end + 1;
6018     }
6019     else {
6020         /* But if the end is the maximum representable on the machine, just let
6021          * the range have no end */
6022         invlist_set_len(invlist, len - 1);
6023     }
6024 }
6025 #endif
6026
6027 STATIC HV*
6028 S_invlist_union(pTHX_ HV* const a, HV* const b)
6029 {
6030     /* Return a new inversion list which is the union of two inversion lists.
6031      * The basis for this comes from "Unicode Demystified" Chapter 13 by
6032      * Richard Gillam, published by Addison-Wesley, and explained at some
6033      * length there.  The preface says to incorporate its examples into your
6034      * code at your own risk.
6035      *
6036      * The algorithm is like a merge sort.
6037      *
6038      * XXX A potential performance improvement is to keep track as we go along
6039      * if only one of the inputs contributes to the result, meaning the other
6040      * is a subset of that one.  In that case, we can skip the final copy and
6041      * return the larger of the input lists */
6042
6043     UV* array_a = invlist_array(a);   /* a's array */
6044     UV* array_b = invlist_array(b);
6045     UV len_a = invlist_len(a);  /* length of a's array */
6046     UV len_b = invlist_len(b);
6047
6048     HV* u;                      /* the resulting union */
6049     UV* array_u;
6050     UV len_u;
6051
6052     UV i_a = 0;             /* current index into a's array */
6053     UV i_b = 0;
6054     UV i_u = 0;
6055
6056     /* running count, as explained in the algorithm source book; items are
6057      * stopped accumulating and are output when the count changes to/from 0.
6058      * The count is incremented when we start a range that's in the set, and
6059      * decremented when we start a range that's not in the set.  So its range
6060      * is 0 to 2.  Only when the count is zero is something not in the set.
6061      */
6062     UV count = 0;
6063
6064     PERL_ARGS_ASSERT_INVLIST_UNION;
6065
6066     /* Size the union for the worst case: that the sets are completely
6067      * disjoint */
6068     u = _new_invlist(len_a + len_b);
6069     array_u = invlist_array(u);
6070
6071     /* Go through each list item by item, stopping when exhausted one of
6072      * them */
6073     while (i_a < len_a && i_b < len_b) {
6074         UV cp;      /* The element to potentially add to the union's array */
6075         bool cp_in_set;   /* is it in the the input list's set or not */
6076
6077         /* We need to take one or the other of the two inputs for the union.
6078          * Since we are merging two sorted lists, we take the smaller of the
6079          * next items.  In case of a tie, we take the one that is in its set
6080          * first.  If we took one not in the set first, it would decrement the
6081          * count, possibly to 0 which would cause it to be output as ending the
6082          * range, and the next time through we would take the same number, and
6083          * output it again as beginning the next range.  By doing it the
6084          * opposite way, there is no possibility that the count will be
6085          * momentarily decremented to 0, and thus the two adjoining ranges will
6086          * be seamlessly merged.  (In a tie and both are in the set or both not
6087          * in the set, it doesn't matter which we take first.) */
6088         if (array_a[i_a] < array_b[i_b]
6089             || (array_a[i_a] == array_b[i_b] && ELEMENT_IN_INVLIST_SET(i_a)))
6090         {
6091             cp_in_set = ELEMENT_IN_INVLIST_SET(i_a);
6092             cp= array_a[i_a++];
6093         }
6094         else {
6095             cp_in_set = ELEMENT_IN_INVLIST_SET(i_b);
6096             cp= array_b[i_b++];
6097         }
6098
6099         /* Here, have chosen which of the two inputs to look at.  Only output
6100          * if the running count changes to/from 0, which marks the
6101          * beginning/end of a range in that's in the set */
6102         if (cp_in_set) {
6103             if (count == 0) {
6104                 array_u[i_u++] = cp;
6105             }
6106             count++;
6107         }
6108         else {
6109             count--;
6110             if (count == 0) {
6111                 array_u[i_u++] = cp;
6112             }
6113         }
6114     }
6115
6116     /* Here, we are finished going through at least one of the lists, which
6117      * means there is something remaining in at most one.  We check if the list
6118      * that hasn't been exhausted is positioned such that we are in the middle
6119      * of a range in its set or not.  (We are in the set if the next item in
6120      * the array marks the beginning of something not in the set)   If in the
6121      * set, we decrement 'count'; if 0, there is potentially more to output.
6122      * There are four cases:
6123      *  1) Both weren't in their sets, count is 0, and remains 0.  What's left
6124      *     in the union is entirely from the non-exhausted set.
6125      *  2) Both were in their sets, count is 2.  Nothing further should
6126      *     be output, as everything that remains will be in the exhausted
6127      *     list's set, hence in the union; decrementing to 1 but not 0 insures
6128      *     that
6129      *  3) the exhausted was in its set, non-exhausted isn't, count is 1.
6130      *     Nothing further should be output because the union includes
6131      *     everything from the exhausted set.  Not decrementing insures that.
6132      *  4) the exhausted wasn't in its set, non-exhausted is, count is 1;
6133      *     decrementing to 0 insures that we look at the remainder of the
6134      *     non-exhausted set */
6135     if ((i_a != len_a && ! ELEMENT_IN_INVLIST_SET(i_a))
6136         || (i_b != len_b && ! ELEMENT_IN_INVLIST_SET(i_b)))
6137     {
6138         count--;
6139     }
6140
6141     /* The final length is what we've output so far, plus what else is about to
6142      * be output.  (If 'count' is non-zero, then the input list we exhausted
6143      * has everything remaining up to the machine's limit in its set, and hence
6144      * in the union, so there will be no further output. */
6145     len_u = i_u;
6146     if (count == 0) {
6147         /* At most one of the subexpressions will be non-zero */
6148         len_u += (len_a - i_a) + (len_b - i_b);
6149     }
6150
6151     /* Set result to final length, which can change the pointer to array_u, so
6152      * re-find it */
6153     if (len_u != invlist_len(u)) {
6154         invlist_set_len(u, len_u);
6155         invlist_trim(u);
6156         array_u = invlist_array(u);
6157     }
6158
6159     /* When 'count' is 0, the list that was exhausted (if one was shorter than
6160      * the other) ended with everything above it not in its set.  That means
6161      * that the remaining part of the union is precisely the same as the
6162      * non-exhausted list, so can just copy it unchanged.  (If both list were
6163      * exhausted at the same time, then the operations below will be both 0.)
6164      */
6165     if (count == 0) {
6166         IV copy_count; /* At most one will have a non-zero copy count */
6167         if ((copy_count = len_a - i_a) > 0) {
6168             Copy(array_a + i_a, array_u + i_u, copy_count, UV);
6169         }
6170         else if ((copy_count = len_b - i_b) > 0) {
6171             Copy(array_b + i_b, array_u + i_u, copy_count, UV);
6172         }
6173     }
6174
6175     return u;
6176 }
6177
6178 STATIC HV*
6179 S_invlist_intersection(pTHX_ HV* const a, HV* const b)
6180 {
6181     /* Return the intersection of two inversion lists.  The basis for this
6182      * comes from "Unicode Demystified" Chapter 13 by Richard Gillam, published
6183      * by Addison-Wesley, and explained at some length there.  The preface says
6184      * to incorporate its examples into your code at your own risk.
6185      *
6186      * The algorithm is like a merge sort, and is essentially the same as the
6187      * union above
6188      */
6189
6190     UV* array_a = invlist_array(a);   /* a's array */
6191     UV* array_b = invlist_array(b);
6192     UV len_a = invlist_len(a);  /* length of a's array */
6193     UV len_b = invlist_len(b);
6194
6195     HV* r;                   /* the resulting intersection */
6196     UV* array_r;
6197     UV len_r;
6198
6199     UV i_a = 0;             /* current index into a's array */
6200     UV i_b = 0;
6201     UV i_r = 0;
6202
6203     /* running count, as explained in the algorithm source book; items are
6204      * stopped accumulating and are output when the count changes to/from 2.
6205      * The count is incremented when we start a range that's in the set, and
6206      * decremented when we start a range that's not in the set.  So its range
6207      * is 0 to 2.  Only when the count is 2 is something in the intersection.
6208      */
6209     UV count = 0;
6210
6211     PERL_ARGS_ASSERT_INVLIST_INTERSECTION;
6212
6213     /* Size the intersection for the worst case: that the intersection ends up
6214      * fragmenting everything to be completely disjoint */
6215     r= _new_invlist(len_a + len_b);
6216     array_r = invlist_array(r);
6217
6218     /* Go through each list item by item, stopping when exhausted one of
6219      * them */
6220     while (i_a < len_a && i_b < len_b) {
6221         UV cp;      /* The element to potentially add to the intersection's
6222                        array */
6223         bool cp_in_set; /* Is it in the input list's set or not */
6224
6225         /* We need to take one or the other of the two inputs for the union.
6226          * Since we are merging two sorted lists, we take the smaller of the
6227          * next items.  In case of a tie, we take the one that is not in its
6228          * set first (a difference from the union algorithm).  If we took one
6229          * in the set first, it would increment the count, possibly to 2 which
6230          * would cause it to be output as starting a range in the intersection,
6231          * and the next time through we would take that same number, and output
6232          * it again as ending the set.  By doing it the opposite of this, we
6233          * there is no possibility that the count will be momentarily
6234          * incremented to 2.  (In a tie and both are in the set or both not in
6235          * the set, it doesn't matter which we take first.) */
6236         if (array_a[i_a] < array_b[i_b]
6237             || (array_a[i_a] == array_b[i_b] && ! ELEMENT_IN_INVLIST_SET(i_a)))
6238         {
6239             cp_in_set = ELEMENT_IN_INVLIST_SET(i_a);
6240             cp= array_a[i_a++];
6241         }
6242         else {
6243             cp_in_set = ELEMENT_IN_INVLIST_SET(i_b);
6244             cp= array_b[i_b++];
6245         }
6246
6247         /* Here, have chosen which of the two inputs to look at.  Only output
6248          * if the running count changes to/from 2, which marks the
6249          * beginning/end of a range that's in the intersection */
6250         if (cp_in_set) {
6251             count++;
6252             if (count == 2) {
6253                 array_r[i_r++] = cp;
6254             }
6255         }
6256         else {
6257             if (count == 2) {
6258                 array_r[i_r++] = cp;
6259             }
6260             count--;
6261         }
6262     }
6263
6264     /* Here, we are finished going through at least one of the sets, which
6265      * means there is something remaining in at most one.  See the comments in
6266      * the union code */
6267     if ((i_a != len_a && ! ELEMENT_IN_INVLIST_SET(i_a))
6268         || (i_b != len_b && ! ELEMENT_IN_INVLIST_SET(i_b)))
6269     {
6270         count--;
6271     }
6272
6273     /* The final length is what we've output so far plus what else is in the
6274      * intersection.  Only one of the subexpressions below will be non-zero */
6275     len_r = i_r;
6276     if (count == 2) {
6277         len_r += (len_a - i_a) + (len_b - i_b);
6278     }
6279
6280     /* Set result to final length, which can change the pointer to array_r, so
6281      * re-find it */
6282     if (len_r != invlist_len(r)) {
6283         invlist_set_len(r, len_r);
6284         invlist_trim(r);
6285         array_r = invlist_array(r);
6286     }
6287
6288     /* Finish outputting any remaining */
6289     if (count == 2) { /* Only one of will have a non-zero copy count */
6290         IV copy_count;
6291         if ((copy_count = len_a - i_a) > 0) {
6292             Copy(array_a + i_a, array_r + i_r, copy_count, UV);
6293         }
6294         else if ((copy_count = len_b - i_b) > 0) {
6295             Copy(array_b + i_b, array_r + i_r, copy_count, UV);
6296         }
6297     }
6298
6299     return r;
6300 }
6301
6302 STATIC HV*
6303 S_add_range_to_invlist(pTHX_ HV* invlist, const UV start, const UV end)
6304 {
6305     /* Add the range from 'start' to 'end' inclusive to the inversion list's
6306      * set.  A pointer to the inversion list is returned.  This may actually be
6307      * a new list, in which case the passed in one has been destroyed.  The
6308      * passed in inversion list can be NULL, in which case a new one is created
6309      * with just the one range in it */
6310
6311     HV* range_invlist;
6312     HV* added_invlist;
6313     UV len;
6314
6315     if (invlist == NULL) {
6316         invlist = _new_invlist(2);
6317         len = 0;
6318     }
6319     else {
6320         len = invlist_len(invlist);
6321     }
6322
6323     /* If comes after the final entry, can just append it to the end */
6324     if (len == 0
6325         || start >= invlist_array(invlist)
6326                                     [invlist_len(invlist) - 1])
6327     {
6328         _append_range_to_invlist(invlist, start, end);
6329         return invlist;
6330     }
6331
6332     /* Here, can't just append things, create and return a new inversion list
6333      * which is the union of this range and the existing inversion list */
6334     range_invlist = _new_invlist(2);
6335     _append_range_to_invlist(range_invlist, start, end);
6336
6337     added_invlist = invlist_union(invlist, range_invlist);
6338
6339     /* The passed in list can be freed, as well as our temporary */
6340     invlist_destroy(range_invlist);
6341     if (invlist != added_invlist) {
6342         invlist_destroy(invlist);
6343     }
6344
6345     return added_invlist;
6346 }
6347
6348 PERL_STATIC_INLINE HV*
6349 S_add_cp_to_invlist(pTHX_ HV* invlist, const UV cp) {
6350     return add_range_to_invlist(invlist, cp, cp);
6351 }
6352
6353 /* End of inversion list object */
6354
6355 /*
6356  - reg - regular expression, i.e. main body or parenthesized thing
6357  *
6358  * Caller must absorb opening parenthesis.
6359  *
6360  * Combining parenthesis handling with the base level of regular expression
6361  * is a trifle forced, but the need to tie the tails of the branches to what
6362  * follows makes it hard to avoid.
6363  */
6364 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
6365 #ifdef DEBUGGING
6366 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
6367 #else
6368 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
6369 #endif
6370
6371 STATIC regnode *
6372 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
6373     /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
6374 {
6375     dVAR;
6376     register regnode *ret;              /* Will be the head of the group. */
6377     register regnode *br;
6378     register regnode *lastbr;
6379     register regnode *ender = NULL;
6380     register I32 parno = 0;
6381     I32 flags;
6382     U32 oregflags = RExC_flags;
6383     bool have_branch = 0;
6384     bool is_open = 0;
6385     I32 freeze_paren = 0;
6386     I32 after_freeze = 0;
6387
6388     /* for (?g), (?gc), and (?o) warnings; warning
6389        about (?c) will warn about (?g) -- japhy    */
6390
6391 #define WASTED_O  0x01
6392 #define WASTED_G  0x02
6393 #define WASTED_C  0x04
6394 #define WASTED_GC (0x02|0x04)
6395     I32 wastedflags = 0x00;
6396
6397     char * parse_start = RExC_parse; /* MJD */
6398     char * const oregcomp_parse = RExC_parse;
6399
6400     GET_RE_DEBUG_FLAGS_DECL;
6401
6402     PERL_ARGS_ASSERT_REG;
6403     DEBUG_PARSE("reg ");
6404
6405     *flagp = 0;                         /* Tentatively. */
6406
6407
6408     /* Make an OPEN node, if parenthesized. */
6409     if (paren) {
6410         if ( *RExC_parse == '*') { /* (*VERB:ARG) */
6411             char *start_verb = RExC_parse;
6412             STRLEN verb_len = 0;
6413             char *start_arg = NULL;
6414             unsigned char op = 0;
6415             int argok = 1;
6416             int internal_argval = 0; /* internal_argval is only useful if !argok */
6417             while ( *RExC_parse && *RExC_parse != ')' ) {
6418                 if ( *RExC_parse == ':' ) {
6419                     start_arg = RExC_parse + 1;
6420                     break;
6421                 }
6422                 RExC_parse++;
6423             }
6424             ++start_verb;
6425             verb_len = RExC_parse - start_verb;
6426             if ( start_arg ) {
6427                 RExC_parse++;
6428                 while ( *RExC_parse && *RExC_parse != ')' ) 
6429                     RExC_parse++;
6430                 if ( *RExC_parse != ')' ) 
6431                     vFAIL("Unterminated verb pattern argument");
6432                 if ( RExC_parse == start_arg )
6433                     start_arg = NULL;
6434             } else {
6435                 if ( *RExC_parse != ')' )
6436                     vFAIL("Unterminated verb pattern");
6437             }
6438             
6439             switch ( *start_verb ) {
6440             case 'A':  /* (*ACCEPT) */
6441                 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
6442                     op = ACCEPT;
6443                     internal_argval = RExC_nestroot;
6444                 }
6445                 break;
6446             case 'C':  /* (*COMMIT) */
6447                 if ( memEQs(start_verb,verb_len,"COMMIT") )
6448                     op = COMMIT;
6449                 break;
6450             case 'F':  /* (*FAIL) */
6451                 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
6452                     op = OPFAIL;
6453                     argok = 0;
6454                 }
6455                 break;
6456             case ':':  /* (*:NAME) */
6457             case 'M':  /* (*MARK:NAME) */
6458                 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
6459                     op = MARKPOINT;
6460                     argok = -1;
6461                 }
6462                 break;
6463             case 'P':  /* (*PRUNE) */
6464                 if ( memEQs(start_verb,verb_len,"PRUNE") )
6465                     op = PRUNE;
6466                 break;
6467             case 'S':   /* (*SKIP) */  
6468                 if ( memEQs(start_verb,verb_len,"SKIP") ) 
6469                     op = SKIP;
6470                 break;
6471             case 'T':  /* (*THEN) */
6472                 /* [19:06] <TimToady> :: is then */
6473                 if ( memEQs(start_verb,verb_len,"THEN") ) {
6474                     op = CUTGROUP;
6475                     RExC_seen |= REG_SEEN_CUTGROUP;
6476                 }
6477                 break;
6478             }
6479             if ( ! op ) {
6480                 RExC_parse++;
6481                 vFAIL3("Unknown verb pattern '%.*s'",
6482                     verb_len, start_verb);
6483             }
6484             if ( argok ) {
6485                 if ( start_arg && internal_argval ) {
6486                     vFAIL3("Verb pattern '%.*s' may not have an argument",
6487                         verb_len, start_verb); 
6488                 } else if ( argok < 0 && !start_arg ) {
6489                     vFAIL3("Verb pattern '%.*s' has a mandatory argument",
6490                         verb_len, start_verb);    
6491                 } else {
6492                     ret = reganode(pRExC_state, op, internal_argval);
6493                     if ( ! internal_argval && ! SIZE_ONLY ) {
6494                         if (start_arg) {
6495                             SV *sv = newSVpvn( start_arg, RExC_parse - start_arg);
6496                             ARG(ret) = add_data( pRExC_state, 1, "S" );
6497                             RExC_rxi->data->data[ARG(ret)]=(void*)sv;
6498                             ret->flags = 0;
6499                         } else {
6500                             ret->flags = 1; 
6501                         }
6502                     }               
6503                 }
6504                 if (!internal_argval)
6505                     RExC_seen |= REG_SEEN_VERBARG;
6506             } else if ( start_arg ) {
6507                 vFAIL3("Verb pattern '%.*s' may not have an argument",
6508                         verb_len, start_verb);    
6509             } else {
6510                 ret = reg_node(pRExC_state, op);
6511             }
6512             nextchar(pRExC_state);
6513             return ret;
6514         } else 
6515         if (*RExC_parse == '?') { /* (?...) */
6516             bool is_logical = 0;
6517             const char * const seqstart = RExC_parse;
6518             bool has_use_defaults = FALSE;
6519
6520             RExC_parse++;
6521             paren = *RExC_parse++;
6522             ret = NULL;                 /* For look-ahead/behind. */
6523             switch (paren) {
6524
6525             case 'P':   /* (?P...) variants for those used to PCRE/Python */
6526                 paren = *RExC_parse++;
6527                 if ( paren == '<')         /* (?P<...>) named capture */
6528                     goto named_capture;
6529                 else if (paren == '>') {   /* (?P>name) named recursion */
6530                     goto named_recursion;
6531                 }
6532                 else if (paren == '=') {   /* (?P=...)  named backref */
6533                     /* this pretty much dupes the code for \k<NAME> in regatom(), if
6534                        you change this make sure you change that */
6535                     char* name_start = RExC_parse;
6536                     U32 num = 0;
6537                     SV *sv_dat = reg_scan_name(pRExC_state,
6538                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6539                     if (RExC_parse == name_start || *RExC_parse != ')')
6540                         vFAIL2("Sequence %.3s... not terminated",parse_start);
6541
6542                     if (!SIZE_ONLY) {
6543                         num = add_data( pRExC_state, 1, "S" );
6544                         RExC_rxi->data->data[num]=(void*)sv_dat;
6545                         SvREFCNT_inc_simple_void(sv_dat);
6546                     }
6547                     RExC_sawback = 1;
6548                     ret = reganode(pRExC_state,
6549                                    ((! FOLD)
6550                                      ? NREF
6551                                      : (MORE_ASCII_RESTRICTED)
6552                                        ? NREFFA
6553                                        : (AT_LEAST_UNI_SEMANTICS)
6554                                          ? NREFFU
6555                                          : (LOC)
6556                                            ? NREFFL
6557                                            : NREFF),
6558                                     num);
6559                     *flagp |= HASWIDTH;
6560
6561                     Set_Node_Offset(ret, parse_start+1);
6562                     Set_Node_Cur_Length(ret); /* MJD */
6563
6564                     nextchar(pRExC_state);
6565                     return ret;
6566                 }
6567                 RExC_parse++;
6568                 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
6569                 /*NOTREACHED*/
6570             case '<':           /* (?<...) */
6571                 if (*RExC_parse == '!')
6572                     paren = ',';
6573                 else if (*RExC_parse != '=') 
6574               named_capture:
6575                 {               /* (?<...>) */
6576                     char *name_start;
6577                     SV *svname;
6578                     paren= '>';
6579             case '\'':          /* (?'...') */
6580                     name_start= RExC_parse;
6581                     svname = reg_scan_name(pRExC_state,
6582                         SIZE_ONLY ?  /* reverse test from the others */
6583                         REG_RSN_RETURN_NAME : 
6584                         REG_RSN_RETURN_NULL);
6585                     if (RExC_parse == name_start) {
6586                         RExC_parse++;
6587                         vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
6588                         /*NOTREACHED*/
6589                     }
6590                     if (*RExC_parse != paren)
6591                         vFAIL2("Sequence (?%c... not terminated",
6592                             paren=='>' ? '<' : paren);
6593                     if (SIZE_ONLY) {
6594                         HE *he_str;
6595                         SV *sv_dat = NULL;
6596                         if (!svname) /* shouldn't happen */
6597                             Perl_croak(aTHX_
6598                                 "panic: reg_scan_name returned NULL");
6599                         if (!RExC_paren_names) {
6600                             RExC_paren_names= newHV();
6601                             sv_2mortal(MUTABLE_SV(RExC_paren_names));
6602 #ifdef DEBUGGING
6603                             RExC_paren_name_list= newAV();
6604                             sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
6605 #endif
6606                         }
6607                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
6608                         if ( he_str )
6609                             sv_dat = HeVAL(he_str);
6610                         if ( ! sv_dat ) {
6611                             /* croak baby croak */
6612                             Perl_croak(aTHX_
6613                                 "panic: paren_name hash element allocation failed");
6614                         } else if ( SvPOK(sv_dat) ) {
6615                             /* (?|...) can mean we have dupes so scan to check
6616                                its already been stored. Maybe a flag indicating
6617                                we are inside such a construct would be useful,
6618                                but the arrays are likely to be quite small, so
6619                                for now we punt -- dmq */
6620                             IV count = SvIV(sv_dat);
6621                             I32 *pv = (I32*)SvPVX(sv_dat);
6622                             IV i;
6623                             for ( i = 0 ; i < count ; i++ ) {
6624                                 if ( pv[i] == RExC_npar ) {
6625                                     count = 0;
6626                                     break;
6627                                 }
6628                             }
6629                             if ( count ) {
6630                                 pv = (I32*)SvGROW(sv_dat, SvCUR(sv_dat) + sizeof(I32)+1);
6631                                 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
6632                                 pv[count] = RExC_npar;
6633                                 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
6634                             }
6635                         } else {
6636                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
6637                             sv_setpvn(sv_dat, (char *)&(RExC_npar), sizeof(I32));
6638                             SvIOK_on(sv_dat);
6639                             SvIV_set(sv_dat, 1);
6640                         }
6641 #ifdef DEBUGGING
6642                         if (!av_store(RExC_paren_name_list, RExC_npar, SvREFCNT_inc(svname)))
6643                             SvREFCNT_dec(svname);
6644 #endif
6645
6646                         /*sv_dump(sv_dat);*/
6647                     }
6648                     nextchar(pRExC_state);
6649                     paren = 1;
6650                     goto capturing_parens;
6651                 }
6652                 RExC_seen |= REG_SEEN_LOOKBEHIND;
6653                 RExC_in_lookbehind++;
6654                 RExC_parse++;
6655             case '=':           /* (?=...) */
6656                 RExC_seen_zerolen++;
6657                 break;
6658             case '!':           /* (?!...) */
6659                 RExC_seen_zerolen++;
6660                 if (*RExC_parse == ')') {
6661                     ret=reg_node(pRExC_state, OPFAIL);
6662                     nextchar(pRExC_state);
6663                     return ret;
6664                 }
6665                 break;
6666             case '|':           /* (?|...) */
6667                 /* branch reset, behave like a (?:...) except that
6668                    buffers in alternations share the same numbers */
6669                 paren = ':'; 
6670                 after_freeze = freeze_paren = RExC_npar;
6671                 break;
6672             case ':':           /* (?:...) */
6673             case '>':           /* (?>...) */
6674                 break;
6675             case '$':           /* (?$...) */
6676             case '@':           /* (?@...) */
6677                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
6678                 break;
6679             case '#':           /* (?#...) */
6680                 while (*RExC_parse && *RExC_parse != ')')
6681                     RExC_parse++;
6682                 if (*RExC_parse != ')')
6683                     FAIL("Sequence (?#... not terminated");
6684                 nextchar(pRExC_state);
6685                 *flagp = TRYAGAIN;
6686                 return NULL;
6687             case '0' :           /* (?0) */
6688             case 'R' :           /* (?R) */
6689                 if (*RExC_parse != ')')
6690                     FAIL("Sequence (?R) not terminated");
6691                 ret = reg_node(pRExC_state, GOSTART);
6692                 *flagp |= POSTPONED;
6693                 nextchar(pRExC_state);
6694                 return ret;
6695                 /*notreached*/
6696             { /* named and numeric backreferences */
6697                 I32 num;
6698             case '&':            /* (?&NAME) */
6699                 parse_start = RExC_parse - 1;
6700               named_recursion:
6701                 {
6702                     SV *sv_dat = reg_scan_name(pRExC_state,
6703                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6704                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
6705                 }
6706                 goto gen_recurse_regop;
6707                 /* NOT REACHED */
6708             case '+':
6709                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
6710                     RExC_parse++;
6711                     vFAIL("Illegal pattern");
6712                 }
6713                 goto parse_recursion;
6714                 /* NOT REACHED*/
6715             case '-': /* (?-1) */
6716                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
6717                     RExC_parse--; /* rewind to let it be handled later */
6718                     goto parse_flags;
6719                 } 
6720                 /*FALLTHROUGH */
6721             case '1': case '2': case '3': case '4': /* (?1) */
6722             case '5': case '6': case '7': case '8': case '9':
6723                 RExC_parse--;
6724               parse_recursion:
6725                 num = atoi(RExC_parse);
6726                 parse_start = RExC_parse - 1; /* MJD */
6727                 if (*RExC_parse == '-')
6728                     RExC_parse++;
6729                 while (isDIGIT(*RExC_parse))
6730                         RExC_parse++;
6731                 if (*RExC_parse!=')') 
6732                     vFAIL("Expecting close bracket");
6733                         
6734               gen_recurse_regop:
6735                 if ( paren == '-' ) {
6736                     /*
6737                     Diagram of capture buffer numbering.
6738                     Top line is the normal capture buffer numbers
6739                     Bottom line is the negative indexing as from
6740                     the X (the (?-2))
6741
6742                     +   1 2    3 4 5 X          6 7
6743                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
6744                     -   5 4    3 2 1 X          x x
6745
6746                     */
6747                     num = RExC_npar + num;
6748                     if (num < 1)  {
6749                         RExC_parse++;
6750                         vFAIL("Reference to nonexistent group");
6751                     }
6752                 } else if ( paren == '+' ) {
6753                     num = RExC_npar + num - 1;
6754                 }
6755
6756                 ret = reganode(pRExC_state, GOSUB, num);
6757                 if (!SIZE_ONLY) {
6758                     if (num > (I32)RExC_rx->nparens) {
6759                         RExC_parse++;
6760                         vFAIL("Reference to nonexistent group");
6761                     }
6762                     ARG2L_SET( ret, RExC_recurse_count++);
6763                     RExC_emit++;
6764                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
6765                         "Recurse #%"UVuf" to %"IVdf"\n", (UV)ARG(ret), (IV)ARG2L(ret)));
6766                 } else {
6767                     RExC_size++;
6768                 }
6769                 RExC_seen |= REG_SEEN_RECURSE;
6770                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
6771                 Set_Node_Offset(ret, parse_start); /* MJD */
6772
6773                 *flagp |= POSTPONED;
6774                 nextchar(pRExC_state);
6775                 return ret;
6776             } /* named and numeric backreferences */
6777             /* NOT REACHED */
6778
6779             case '?':           /* (??...) */
6780                 is_logical = 1;
6781                 if (*RExC_parse != '{') {
6782                     RExC_parse++;
6783                     vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
6784                     /*NOTREACHED*/
6785                 }
6786                 *flagp |= POSTPONED;
6787                 paren = *RExC_parse++;
6788                 /* FALL THROUGH */
6789             case '{':           /* (?{...}) */
6790             {
6791                 I32 count = 1;
6792                 U32 n = 0;
6793                 char c;
6794                 char *s = RExC_parse;
6795
6796                 RExC_seen_zerolen++;
6797                 RExC_seen |= REG_SEEN_EVAL;
6798                 while (count && (c = *RExC_parse)) {
6799                     if (c == '\\') {
6800                         if (RExC_parse[1])
6801                             RExC_parse++;
6802                     }
6803                     else if (c == '{')
6804                         count++;
6805                     else if (c == '}')
6806                         count--;
6807                     RExC_parse++;
6808                 }
6809                 if (*RExC_parse != ')') {
6810                     RExC_parse = s;             
6811                     vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
6812                 }
6813                 if (!SIZE_ONLY) {
6814                     PAD *pad;
6815                     OP_4tree *sop, *rop;
6816                     SV * const sv = newSVpvn(s, RExC_parse - 1 - s);
6817
6818                     ENTER;
6819                     Perl_save_re_context(aTHX);
6820                     rop = Perl_sv_compile_2op_is_broken(aTHX_ sv, &sop, "re", &pad);
6821                     sop->op_private |= OPpREFCOUNTED;
6822                     /* re_dup will OpREFCNT_inc */
6823                     OpREFCNT_set(sop, 1);
6824                     LEAVE;
6825
6826                     n = add_data(pRExC_state, 3, "nop");
6827                     RExC_rxi->data->data[n] = (void*)rop;
6828                     RExC_rxi->data->data[n+1] = (void*)sop;
6829                     RExC_rxi->data->data[n+2] = (void*)pad;
6830                     SvREFCNT_dec(sv);
6831                 }
6832                 else {                                          /* First pass */
6833                     if (PL_reginterp_cnt < ++RExC_seen_evals
6834                         && IN_PERL_RUNTIME)
6835                         /* No compiled RE interpolated, has runtime
6836                            components ===> unsafe.  */
6837                         FAIL("Eval-group not allowed at runtime, use re 'eval'");
6838                     if (PL_tainting && PL_tainted)
6839                         FAIL("Eval-group in insecure regular expression");
6840 #if PERL_VERSION > 8
6841                     if (IN_PERL_COMPILETIME)
6842                         PL_cv_has_eval = 1;
6843 #endif
6844                 }
6845
6846                 nextchar(pRExC_state);
6847                 if (is_logical) {
6848                     ret = reg_node(pRExC_state, LOGICAL);
6849                     if (!SIZE_ONLY)
6850                         ret->flags = 2;
6851                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, EVAL, n));
6852                     /* deal with the length of this later - MJD */
6853                     return ret;
6854                 }
6855                 ret = reganode(pRExC_state, EVAL, n);
6856                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
6857                 Set_Node_Offset(ret, parse_start);
6858                 return ret;
6859             }
6860             case '(':           /* (?(?{...})...) and (?(?=...)...) */
6861             {
6862                 int is_define= 0;
6863                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
6864                     if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
6865                         || RExC_parse[1] == '<'
6866                         || RExC_parse[1] == '{') { /* Lookahead or eval. */
6867                         I32 flag;
6868                         
6869                         ret = reg_node(pRExC_state, LOGICAL);
6870                         if (!SIZE_ONLY)
6871                             ret->flags = 1;
6872                         REGTAIL(pRExC_state, ret, reg(pRExC_state, 1, &flag,depth+1));
6873                         goto insert_if;
6874                     }
6875                 }
6876                 else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
6877                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
6878                 {
6879                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
6880                     char *name_start= RExC_parse++;
6881                     U32 num = 0;
6882                     SV *sv_dat=reg_scan_name(pRExC_state,
6883                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6884                     if (RExC_parse == name_start || *RExC_parse != ch)
6885                         vFAIL2("Sequence (?(%c... not terminated",
6886                             (ch == '>' ? '<' : ch));
6887                     RExC_parse++;
6888                     if (!SIZE_ONLY) {
6889                         num = add_data( pRExC_state, 1, "S" );
6890                         RExC_rxi->data->data[num]=(void*)sv_dat;
6891                         SvREFCNT_inc_simple_void(sv_dat);
6892                     }
6893                     ret = reganode(pRExC_state,NGROUPP,num);
6894                     goto insert_if_check_paren;
6895                 }
6896                 else if (RExC_parse[0] == 'D' &&
6897                          RExC_parse[1] == 'E' &&
6898                          RExC_parse[2] == 'F' &&
6899                          RExC_parse[3] == 'I' &&
6900                          RExC_parse[4] == 'N' &&
6901                          RExC_parse[5] == 'E')
6902                 {
6903                     ret = reganode(pRExC_state,DEFINEP,0);
6904                     RExC_parse +=6 ;
6905                     is_define = 1;
6906                     goto insert_if_check_paren;
6907                 }
6908                 else if (RExC_parse[0] == 'R') {
6909                     RExC_parse++;
6910                     parno = 0;
6911                     if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
6912                         parno = atoi(RExC_parse++);
6913                         while (isDIGIT(*RExC_parse))
6914                             RExC_parse++;
6915                     } else if (RExC_parse[0] == '&') {
6916                         SV *sv_dat;
6917                         RExC_parse++;
6918                         sv_dat = reg_scan_name(pRExC_state,
6919                             SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6920                         parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
6921                     }
6922                     ret = reganode(pRExC_state,INSUBP,parno); 
6923                     goto insert_if_check_paren;
6924                 }
6925                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
6926                     /* (?(1)...) */
6927                     char c;
6928                     parno = atoi(RExC_parse++);
6929
6930                     while (isDIGIT(*RExC_parse))
6931                         RExC_parse++;
6932                     ret = reganode(pRExC_state, GROUPP, parno);
6933
6934                  insert_if_check_paren:
6935                     if ((c = *nextchar(pRExC_state)) != ')')
6936                         vFAIL("Switch condition not recognized");
6937                   insert_if:
6938                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
6939                     br = regbranch(pRExC_state, &flags, 1,depth+1);
6940                     if (br == NULL)
6941                         br = reganode(pRExC_state, LONGJMP, 0);
6942                     else
6943                         REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
6944                     c = *nextchar(pRExC_state);
6945                     if (flags&HASWIDTH)
6946                         *flagp |= HASWIDTH;
6947                     if (c == '|') {
6948                         if (is_define) 
6949                             vFAIL("(?(DEFINE)....) does not allow branches");
6950                         lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
6951                         regbranch(pRExC_state, &flags, 1,depth+1);
6952                         REGTAIL(pRExC_state, ret, lastbr);
6953                         if (flags&HASWIDTH)
6954                             *flagp |= HASWIDTH;
6955                         c = *nextchar(pRExC_state);
6956                     }
6957                     else
6958                         lastbr = NULL;
6959                     if (c != ')')
6960                         vFAIL("Switch (?(condition)... contains too many branches");
6961                     ender = reg_node(pRExC_state, TAIL);
6962                     REGTAIL(pRExC_state, br, ender);
6963                     if (lastbr) {
6964                         REGTAIL(pRExC_state, lastbr, ender);
6965                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
6966                     }
6967                     else
6968                         REGTAIL(pRExC_state, ret, ender);
6969                     RExC_size++; /* XXX WHY do we need this?!!
6970                                     For large programs it seems to be required
6971                                     but I can't figure out why. -- dmq*/
6972                     return ret;
6973                 }
6974                 else {
6975                     vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
6976                 }
6977             }
6978             case 0:
6979                 RExC_parse--; /* for vFAIL to print correctly */
6980                 vFAIL("Sequence (? incomplete");
6981                 break;
6982             case DEFAULT_PAT_MOD:   /* Use default flags with the exceptions
6983                                        that follow */
6984                 has_use_defaults = TRUE;
6985                 STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
6986                 set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
6987                                                 ? REGEX_UNICODE_CHARSET
6988                                                 : REGEX_DEPENDS_CHARSET);
6989                 goto parse_flags;
6990             default:
6991                 --RExC_parse;
6992                 parse_flags:      /* (?i) */  
6993             {
6994                 U32 posflags = 0, negflags = 0;
6995                 U32 *flagsp = &posflags;
6996                 char has_charset_modifier = '\0';
6997                 regex_charset cs = (RExC_utf8 || RExC_uni_semantics)
6998                                     ? REGEX_UNICODE_CHARSET
6999                                     : REGEX_DEPENDS_CHARSET;
7000
7001                 while (*RExC_parse) {
7002                     /* && strchr("iogcmsx", *RExC_parse) */
7003                     /* (?g), (?gc) and (?o) are useless here
7004                        and must be globally applied -- japhy */
7005                     switch (*RExC_parse) {
7006                     CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp);
7007                     case LOCALE_PAT_MOD:
7008                         if (has_charset_modifier) {
7009                             goto excess_modifier;
7010                         }
7011                         else if (flagsp == &negflags) {
7012                             goto neg_modifier;
7013                         }
7014                         cs = REGEX_LOCALE_CHARSET;
7015                         has_charset_modifier = LOCALE_PAT_MOD;
7016                         RExC_contains_locale = 1;
7017                         break;
7018                     case UNICODE_PAT_MOD:
7019                         if (has_charset_modifier) {
7020                             goto excess_modifier;
7021                         }
7022                         else if (flagsp == &negflags) {
7023                             goto neg_modifier;
7024                         }
7025                         cs = REGEX_UNICODE_CHARSET;
7026                         has_charset_modifier = UNICODE_PAT_MOD;
7027                         break;
7028                     case ASCII_RESTRICT_PAT_MOD:
7029                         if (flagsp == &negflags) {
7030                             goto neg_modifier;
7031                         }
7032                         if (has_charset_modifier) {
7033                             if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
7034                                 goto excess_modifier;
7035                             }
7036                             /* Doubled modifier implies more restricted */
7037                             cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
7038                         }
7039                         else {
7040                             cs = REGEX_ASCII_RESTRICTED_CHARSET;
7041                         }
7042                         has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
7043                         break;
7044                     case DEPENDS_PAT_MOD:
7045                         if (has_use_defaults) {
7046                             goto fail_modifiers;
7047                         }
7048                         else if (flagsp == &negflags) {
7049                             goto neg_modifier;
7050                         }
7051                         else if (has_charset_modifier) {
7052                             goto excess_modifier;
7053                         }
7054
7055                         /* The dual charset means unicode semantics if the
7056                          * pattern (or target, not known until runtime) are
7057                          * utf8, or something in the pattern indicates unicode
7058                          * semantics */
7059                         cs = (RExC_utf8 || RExC_uni_semantics)
7060                              ? REGEX_UNICODE_CHARSET
7061                              : REGEX_DEPENDS_CHARSET;
7062                         has_charset_modifier = DEPENDS_PAT_MOD;
7063                         break;
7064                     excess_modifier:
7065                         RExC_parse++;
7066                         if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
7067                             vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
7068                         }
7069                         else if (has_charset_modifier == *(RExC_parse - 1)) {
7070                             vFAIL2("Regexp modifier \"%c\" may not appear twice", *(RExC_parse - 1));
7071                         }
7072                         else {
7073                             vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
7074                         }
7075                         /*NOTREACHED*/
7076                     neg_modifier:
7077                         RExC_parse++;
7078                         vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"", *(RExC_parse - 1));
7079                         /*NOTREACHED*/
7080                     case ONCE_PAT_MOD: /* 'o' */
7081                     case GLOBAL_PAT_MOD: /* 'g' */
7082                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
7083                             const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
7084                             if (! (wastedflags & wflagbit) ) {
7085                                 wastedflags |= wflagbit;
7086                                 vWARN5(
7087                                     RExC_parse + 1,
7088                                     "Useless (%s%c) - %suse /%c modifier",
7089                                     flagsp == &negflags ? "?-" : "?",
7090                                     *RExC_parse,
7091                                     flagsp == &negflags ? "don't " : "",
7092                                     *RExC_parse
7093                                 );
7094                             }
7095                         }
7096                         break;
7097                         
7098                     case CONTINUE_PAT_MOD: /* 'c' */
7099                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
7100                             if (! (wastedflags & WASTED_C) ) {
7101                                 wastedflags |= WASTED_GC;
7102                                 vWARN3(
7103                                     RExC_parse + 1,
7104                                     "Useless (%sc) - %suse /gc modifier",
7105                                     flagsp == &negflags ? "?-" : "?",
7106                                     flagsp == &negflags ? "don't " : ""
7107                                 );
7108                             }
7109                         }
7110                         break;
7111                     case KEEPCOPY_PAT_MOD: /* 'p' */
7112                         if (flagsp == &negflags) {
7113                             if (SIZE_ONLY)
7114                                 ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
7115                         } else {
7116                             *flagsp |= RXf_PMf_KEEPCOPY;
7117                         }
7118                         break;
7119                     case '-':
7120                         /* A flag is a default iff it is following a minus, so
7121                          * if there is a minus, it means will be trying to
7122                          * re-specify a default which is an error */
7123                         if (has_use_defaults || flagsp == &negflags) {
7124             fail_modifiers:
7125                             RExC_parse++;
7126                             vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
7127                             /*NOTREACHED*/
7128                         }
7129                         flagsp = &negflags;
7130                         wastedflags = 0;  /* reset so (?g-c) warns twice */
7131                         break;
7132                     case ':':
7133                         paren = ':';
7134                         /*FALLTHROUGH*/
7135                     case ')':
7136                         RExC_flags |= posflags;
7137                         RExC_flags &= ~negflags;
7138                         set_regex_charset(&RExC_flags, cs);
7139                         if (paren != ':') {
7140                             oregflags |= posflags;
7141                             oregflags &= ~negflags;
7142                             set_regex_charset(&oregflags, cs);
7143                         }
7144                         nextchar(pRExC_state);
7145                         if (paren != ':') {
7146                             *flagp = TRYAGAIN;
7147                             return NULL;
7148                         } else {
7149                             ret = NULL;
7150                             goto parse_rest;
7151                         }
7152                         /*NOTREACHED*/
7153                     default:
7154                         RExC_parse++;
7155                         vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
7156                         /*NOTREACHED*/
7157                     }                           
7158                     ++RExC_parse;
7159                 }
7160             }} /* one for the default block, one for the switch */
7161         }
7162         else {                  /* (...) */
7163           capturing_parens:
7164             parno = RExC_npar;
7165             RExC_npar++;
7166             
7167             ret = reganode(pRExC_state, OPEN, parno);
7168             if (!SIZE_ONLY ){
7169                 if (!RExC_nestroot) 
7170                     RExC_nestroot = parno;
7171                 if (RExC_seen & REG_SEEN_RECURSE
7172                     && !RExC_open_parens[parno-1])
7173                 {
7174                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
7175                         "Setting open paren #%"IVdf" to %d\n", 
7176                         (IV)parno, REG_NODE_NUM(ret)));
7177                     RExC_open_parens[parno-1]= ret;
7178                 }
7179             }
7180             Set_Node_Length(ret, 1); /* MJD */
7181             Set_Node_Offset(ret, RExC_parse); /* MJD */
7182             is_open = 1;
7183         }
7184     }
7185     else                        /* ! paren */
7186         ret = NULL;
7187    
7188    parse_rest:
7189     /* Pick up the branches, linking them together. */
7190     parse_start = RExC_parse;   /* MJD */
7191     br = regbranch(pRExC_state, &flags, 1,depth+1);
7192
7193     /*     branch_len = (paren != 0); */
7194
7195     if (br == NULL)
7196         return(NULL);
7197     if (*RExC_parse == '|') {
7198         if (!SIZE_ONLY && RExC_extralen) {
7199             reginsert(pRExC_state, BRANCHJ, br, depth+1);
7200         }
7201         else {                  /* MJD */
7202             reginsert(pRExC_state, BRANCH, br, depth+1);
7203             Set_Node_Length(br, paren != 0);
7204             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
7205         }
7206         have_branch = 1;
7207         if (SIZE_ONLY)
7208             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
7209     }
7210     else if (paren == ':') {
7211         *flagp |= flags&SIMPLE;
7212     }
7213     if (is_open) {                              /* Starts with OPEN. */
7214         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
7215     }
7216     else if (paren != '?')              /* Not Conditional */
7217         ret = br;
7218     *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
7219     lastbr = br;
7220     while (*RExC_parse == '|') {
7221         if (!SIZE_ONLY && RExC_extralen) {
7222             ender = reganode(pRExC_state, LONGJMP,0);
7223             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
7224         }
7225         if (SIZE_ONLY)
7226             RExC_extralen += 2;         /* Account for LONGJMP. */
7227         nextchar(pRExC_state);
7228         if (freeze_paren) {
7229             if (RExC_npar > after_freeze)
7230                 after_freeze = RExC_npar;
7231             RExC_npar = freeze_paren;       
7232         }
7233         br = regbranch(pRExC_state, &flags, 0, depth+1);
7234
7235         if (br == NULL)
7236             return(NULL);
7237         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
7238         lastbr = br;
7239         *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
7240     }
7241
7242     if (have_branch || paren != ':') {
7243         /* Make a closing node, and hook it on the end. */
7244         switch (paren) {
7245         case ':':
7246             ender = reg_node(pRExC_state, TAIL);
7247             break;
7248         case 1:
7249             ender = reganode(pRExC_state, CLOSE, parno);
7250             if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) {
7251                 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
7252                         "Setting close paren #%"IVdf" to %d\n", 
7253                         (IV)parno, REG_NODE_NUM(ender)));
7254                 RExC_close_parens[parno-1]= ender;
7255                 if (RExC_nestroot == parno) 
7256                     RExC_nestroot = 0;
7257             }       
7258             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
7259             Set_Node_Length(ender,1); /* MJD */
7260             break;
7261         case '<':
7262         case ',':
7263         case '=':
7264         case '!':
7265             *flagp &= ~HASWIDTH;
7266             /* FALL THROUGH */
7267         case '>':
7268             ender = reg_node(pRExC_state, SUCCEED);
7269             break;
7270         case 0:
7271             ender = reg_node(pRExC_state, END);
7272             if (!SIZE_ONLY) {
7273                 assert(!RExC_opend); /* there can only be one! */
7274                 RExC_opend = ender;
7275             }
7276             break;
7277         }
7278         REGTAIL(pRExC_state, lastbr, ender);
7279
7280         if (have_branch && !SIZE_ONLY) {
7281             if (depth==1)
7282                 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
7283
7284             /* Hook the tails of the branches to the closing node. */
7285             for (br = ret; br; br = regnext(br)) {
7286                 const U8 op = PL_regkind[OP(br)];
7287                 if (op == BRANCH) {
7288                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
7289                 }
7290                 else if (op == BRANCHJ) {
7291                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
7292                 }
7293             }
7294         }
7295     }
7296
7297     {
7298         const char *p;
7299         static const char parens[] = "=!<,>";
7300
7301         if (paren && (p = strchr(parens, paren))) {
7302             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
7303             int flag = (p - parens) > 1;
7304
7305             if (paren == '>')
7306                 node = SUSPEND, flag = 0;
7307             reginsert(pRExC_state, node,ret, depth+1);
7308             Set_Node_Cur_Length(ret);
7309             Set_Node_Offset(ret, parse_start + 1);
7310             ret->flags = flag;
7311             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
7312         }
7313     }
7314
7315     /* Check for proper termination. */
7316     if (paren) {
7317         RExC_flags = oregflags;
7318         if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
7319             RExC_parse = oregcomp_parse;
7320             vFAIL("Unmatched (");
7321         }
7322     }
7323     else if (!paren && RExC_parse < RExC_end) {
7324         if (*RExC_parse == ')') {
7325             RExC_parse++;
7326             vFAIL("Unmatched )");
7327         }
7328         else
7329             FAIL("Junk on end of regexp");      /* "Can't happen". */
7330         /* NOTREACHED */
7331     }
7332
7333     if (RExC_in_lookbehind) {
7334         RExC_in_lookbehind--;
7335     }
7336     if (after_freeze > RExC_npar)
7337         RExC_npar = after_freeze;
7338     return(ret);
7339 }
7340
7341 /*
7342  - regbranch - one alternative of an | operator
7343  *
7344  * Implements the concatenation operator.
7345  */
7346 STATIC regnode *
7347 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
7348 {
7349     dVAR;
7350     register regnode *ret;
7351     register regnode *chain = NULL;
7352     register regnode *latest;
7353     I32 flags = 0, c = 0;
7354     GET_RE_DEBUG_FLAGS_DECL;
7355
7356     PERL_ARGS_ASSERT_REGBRANCH;
7357
7358     DEBUG_PARSE("brnc");
7359
7360     if (first)
7361         ret = NULL;
7362     else {
7363         if (!SIZE_ONLY && RExC_extralen)
7364             ret = reganode(pRExC_state, BRANCHJ,0);
7365         else {
7366             ret = reg_node(pRExC_state, BRANCH);
7367             Set_Node_Length(ret, 1);
7368         }
7369     }
7370         
7371     if (!first && SIZE_ONLY)
7372         RExC_extralen += 1;                     /* BRANCHJ */
7373
7374     *flagp = WORST;                     /* Tentatively. */
7375
7376     RExC_parse--;
7377     nextchar(pRExC_state);
7378     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
7379         flags &= ~TRYAGAIN;
7380         latest = regpiece(pRExC_state, &flags,depth+1);
7381         if (latest == NULL) {
7382             if (flags & TRYAGAIN)
7383                 continue;
7384             return(NULL);
7385         }
7386         else if (ret == NULL)
7387             ret = latest;
7388         *flagp |= flags&(HASWIDTH|POSTPONED);
7389         if (chain == NULL)      /* First piece. */
7390             *flagp |= flags&SPSTART;
7391         else {
7392             RExC_naughty++;
7393             REGTAIL(pRExC_state, chain, latest);
7394         }
7395         chain = latest;
7396         c++;
7397     }
7398     if (chain == NULL) {        /* Loop ran zero times. */
7399         chain = reg_node(pRExC_state, NOTHING);
7400         if (ret == NULL)
7401             ret = chain;
7402     }
7403     if (c == 1) {
7404         *flagp |= flags&SIMPLE;
7405     }
7406
7407     return ret;
7408 }
7409
7410 /*
7411  - regpiece - something followed by possible [*+?]
7412  *
7413  * Note that the branching code sequences used for ? and the general cases
7414  * of * and + are somewhat optimized:  they use the same NOTHING node as
7415  * both the endmarker for their branch list and the body of the last branch.
7416  * It might seem that this node could be dispensed with entirely, but the
7417  * endmarker role is not redundant.
7418  */
7419 STATIC regnode *
7420 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
7421 {
7422     dVAR;
7423     register regnode *ret;
7424     register char op;
7425     register char *next;
7426     I32 flags;
7427     const char * const origparse = RExC_parse;
7428     I32 min;
7429     I32 max = REG_INFTY;
7430     char *parse_start;
7431     const char *maxpos = NULL;
7432     GET_RE_DEBUG_FLAGS_DECL;
7433
7434     PERL_ARGS_ASSERT_REGPIECE;
7435
7436     DEBUG_PARSE("piec");
7437
7438     ret = regatom(pRExC_state, &flags,depth+1);
7439     if (ret == NULL) {
7440         if (flags & TRYAGAIN)
7441             *flagp |= TRYAGAIN;
7442         return(NULL);
7443     }
7444
7445     op = *RExC_parse;
7446
7447     if (op == '{' && regcurly(RExC_parse)) {
7448         maxpos = NULL;
7449         parse_start = RExC_parse; /* MJD */
7450         next = RExC_parse + 1;
7451         while (isDIGIT(*next) || *next == ',') {
7452             if (*next == ',') {
7453                 if (maxpos)
7454                     break;
7455                 else
7456                     maxpos = next;
7457             }
7458             next++;
7459         }
7460         if (*next == '}') {             /* got one */
7461             if (!maxpos)
7462                 maxpos = next;
7463             RExC_parse++;
7464             min = atoi(RExC_parse);
7465             if (*maxpos == ',')
7466                 maxpos++;
7467             else
7468                 maxpos = RExC_parse;
7469             max = atoi(maxpos);
7470             if (!max && *maxpos != '0')
7471                 max = REG_INFTY;                /* meaning "infinity" */
7472             else if (max >= REG_INFTY)
7473                 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
7474             RExC_parse = next;
7475             nextchar(pRExC_state);
7476
7477         do_curly:
7478             if ((flags&SIMPLE)) {
7479                 RExC_naughty += 2 + RExC_naughty / 2;
7480                 reginsert(pRExC_state, CURLY, ret, depth+1);
7481                 Set_Node_Offset(ret, parse_start+1); /* MJD */
7482                 Set_Node_Cur_Length(ret);
7483             }
7484             else {
7485                 regnode * const w = reg_node(pRExC_state, WHILEM);
7486
7487                 w->flags = 0;
7488                 REGTAIL(pRExC_state, ret, w);
7489                 if (!SIZE_ONLY && RExC_extralen) {
7490                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
7491                     reginsert(pRExC_state, NOTHING,ret, depth+1);
7492                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
7493                 }
7494                 reginsert(pRExC_state, CURLYX,ret, depth+1);
7495                                 /* MJD hk */
7496                 Set_Node_Offset(ret, parse_start+1);
7497                 Set_Node_Length(ret,
7498                                 op == '{' ? (RExC_parse - parse_start) : 1);
7499
7500                 if (!SIZE_ONLY && RExC_extralen)
7501                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
7502                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
7503                 if (SIZE_ONLY)
7504                     RExC_whilem_seen++, RExC_extralen += 3;
7505                 RExC_naughty += 4 + RExC_naughty;       /* compound interest */
7506             }
7507             ret->flags = 0;
7508
7509             if (min > 0)
7510                 *flagp = WORST;
7511             if (max > 0)
7512                 *flagp |= HASWIDTH;
7513             if (max < min)
7514                 vFAIL("Can't do {n,m} with n > m");
7515             if (!SIZE_ONLY) {
7516                 ARG1_SET(ret, (U16)min);
7517                 ARG2_SET(ret, (U16)max);
7518             }
7519
7520             goto nest_check;
7521         }
7522     }
7523
7524     if (!ISMULT1(op)) {
7525         *flagp = flags;
7526         return(ret);
7527     }
7528
7529 #if 0                           /* Now runtime fix should be reliable. */
7530
7531     /* if this is reinstated, don't forget to put this back into perldiag:
7532
7533             =item Regexp *+ operand could be empty at {#} in regex m/%s/
7534
7535            (F) The part of the regexp subject to either the * or + quantifier
7536            could match an empty string. The {#} shows in the regular
7537            expression about where the problem was discovered.
7538
7539     */
7540
7541     if (!(flags&HASWIDTH) && op != '?')
7542       vFAIL("Regexp *+ operand could be empty");
7543 #endif
7544
7545     parse_start = RExC_parse;
7546     nextchar(pRExC_state);
7547
7548     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
7549
7550     if (op == '*' && (flags&SIMPLE)) {
7551         reginsert(pRExC_state, STAR, ret, depth+1);
7552         ret->flags = 0;
7553         RExC_naughty += 4;
7554     }
7555     else if (op == '*') {
7556         min = 0;
7557         goto do_curly;
7558     }
7559     else if (op == '+' && (flags&SIMPLE)) {
7560         reginsert(pRExC_state, PLUS, ret, depth+1);
7561         ret->flags = 0;
7562         RExC_naughty += 3;
7563     }
7564     else if (op == '+') {
7565         min = 1;
7566         goto do_curly;
7567     }
7568     else if (op == '?') {
7569         min = 0; max = 1;
7570         goto do_curly;
7571     }
7572   nest_check:
7573     if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
7574         ckWARN3reg(RExC_parse,
7575                    "%.*s matches null string many times",
7576                    (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0),
7577                    origparse);
7578     }
7579
7580     if (RExC_parse < RExC_end && *RExC_parse == '?') {
7581         nextchar(pRExC_state);
7582         reginsert(pRExC_state, MINMOD, ret, depth+1);
7583         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
7584     }
7585 #ifndef REG_ALLOW_MINMOD_SUSPEND
7586     else
7587 #endif
7588     if (RExC_parse < RExC_end && *RExC_parse == '+') {
7589         regnode *ender;
7590         nextchar(pRExC_state);
7591         ender = reg_node(pRExC_state, SUCCEED);
7592         REGTAIL(pRExC_state, ret, ender);
7593         reginsert(pRExC_state, SUSPEND, ret, depth+1);
7594         ret->flags = 0;
7595         ender = reg_node(pRExC_state, TAIL);
7596         REGTAIL(pRExC_state, ret, ender);
7597         /*ret= ender;*/
7598     }
7599
7600     if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) {
7601         RExC_parse++;
7602         vFAIL("Nested quantifiers");
7603     }
7604
7605     return(ret);
7606 }
7607
7608
7609 /* reg_namedseq(pRExC_state,UVp, UV depth)
7610    
7611    This is expected to be called by a parser routine that has 
7612    recognized '\N' and needs to handle the rest. RExC_parse is
7613    expected to point at the first char following the N at the time
7614    of the call.
7615
7616    The \N may be inside (indicated by valuep not being NULL) or outside a
7617    character class.
7618
7619    \N may begin either a named sequence, or if outside a character class, mean
7620    to match a non-newline.  For non single-quoted regexes, the tokenizer has
7621    attempted to decide which, and in the case of a named sequence converted it
7622    into one of the forms: \N{} (if the sequence is null), or \N{U+c1.c2...},
7623    where c1... are the characters in the sequence.  For single-quoted regexes,
7624    the tokenizer passes the \N sequence through unchanged; this code will not
7625    attempt to determine this nor expand those.  The net effect is that if the
7626    beginning of the passed-in pattern isn't '{U+' or there is no '}', it
7627    signals that this \N occurrence means to match a non-newline.
7628    
7629    Only the \N{U+...} form should occur in a character class, for the same
7630    reason that '.' inside a character class means to just match a period: it
7631    just doesn't make sense.
7632    
7633    If valuep is non-null then it is assumed that we are parsing inside 
7634    of a charclass definition and the first codepoint in the resolved
7635    string is returned via *valuep and the routine will return NULL. 
7636    In this mode if a multichar string is returned from the charnames 
7637    handler, a warning will be issued, and only the first char in the 
7638    sequence will be examined. If the string returned is zero length
7639    then the value of *valuep is undefined and NON-NULL will 
7640    be returned to indicate failure. (This will NOT be a valid pointer 
7641    to a regnode.)
7642    
7643    If valuep is null then it is assumed that we are parsing normal text and a
7644    new EXACT node is inserted into the program containing the resolved string,
7645    and a pointer to the new node is returned.  But if the string is zero length
7646    a NOTHING node is emitted instead.
7647
7648    On success RExC_parse is set to the char following the endbrace.
7649    Parsing failures will generate a fatal error via vFAIL(...)
7650  */
7651 STATIC regnode *
7652 S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep, I32 *flagp, U32 depth)
7653 {
7654     char * endbrace;    /* '}' following the name */
7655     regnode *ret = NULL;
7656     char* p;
7657
7658     GET_RE_DEBUG_FLAGS_DECL;
7659  
7660     PERL_ARGS_ASSERT_REG_NAMEDSEQ;
7661
7662     GET_RE_DEBUG_FLAGS;
7663
7664     /* The [^\n] meaning of \N ignores spaces and comments under the /x
7665      * modifier.  The other meaning does not */
7666     p = (RExC_flags & RXf_PMf_EXTENDED)
7667         ? regwhite( pRExC_state, RExC_parse )
7668         : RExC_parse;
7669    
7670     /* Disambiguate between \N meaning a named character versus \N meaning
7671      * [^\n].  The former is assumed when it can't be the latter. */
7672     if (*p != '{' || regcurly(p)) {
7673         RExC_parse = p;
7674         if (valuep) {
7675             /* no bare \N in a charclass */
7676             vFAIL("\\N in a character class must be a named character: \\N{...}");
7677         }
7678         nextchar(pRExC_state);
7679         ret = reg_node(pRExC_state, REG_ANY);
7680         *flagp |= HASWIDTH|SIMPLE;
7681         RExC_naughty++;
7682         RExC_parse--;
7683         Set_Node_Length(ret, 1); /* MJD */
7684         return ret;
7685     }
7686
7687     /* Here, we have decided it should be a named sequence */
7688
7689     /* The test above made sure that the next real character is a '{', but
7690      * under the /x modifier, it could be separated by space (or a comment and
7691      * \n) and this is not allowed (for consistency with \x{...} and the
7692      * tokenizer handling of \N{NAME}). */
7693     if (*RExC_parse != '{') {
7694         vFAIL("Missing braces on \\N{}");
7695     }
7696
7697     RExC_parse++;       /* Skip past the '{' */
7698
7699     if (! (endbrace = strchr(RExC_parse, '}')) /* no trailing brace */
7700         || ! (endbrace == RExC_parse            /* nothing between the {} */
7701               || (endbrace - RExC_parse >= 2    /* U+ (bad hex is checked below */
7702                   && strnEQ(RExC_parse, "U+", 2)))) /* for a better error msg) */
7703     {
7704         if (endbrace) RExC_parse = endbrace;    /* position msg's '<--HERE' */
7705         vFAIL("\\N{NAME} must be resolved by the lexer");
7706     }
7707
7708     if (endbrace == RExC_parse) {   /* empty: \N{} */
7709         if (! valuep) {
7710             RExC_parse = endbrace + 1;  
7711             return reg_node(pRExC_state,NOTHING);
7712         }
7713
7714         if (SIZE_ONLY) {
7715             ckWARNreg(RExC_parse,
7716                     "Ignoring zero length \\N{} in character class"
7717             );
7718             RExC_parse = endbrace + 1;  
7719         }
7720         *valuep = 0;
7721         return (regnode *) &RExC_parse; /* Invalid regnode pointer */
7722     }
7723
7724     REQUIRE_UTF8;       /* named sequences imply Unicode semantics */
7725     RExC_parse += 2;    /* Skip past the 'U+' */
7726
7727     if (valuep) {   /* In a bracketed char class */
7728         /* We only pay attention to the first char of 
7729         multichar strings being returned. I kinda wonder
7730         if this makes sense as it does change the behaviour
7731         from earlier versions, OTOH that behaviour was broken
7732         as well. XXX Solution is to recharacterize as
7733         [rest-of-class]|multi1|multi2... */
7734
7735         STRLEN length_of_hex;
7736         I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
7737             | PERL_SCAN_DISALLOW_PREFIX
7738             | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
7739     
7740         char * endchar = RExC_parse + strcspn(RExC_parse, ".}");
7741         if (endchar < endbrace) {
7742             ckWARNreg(endchar, "Using just the first character returned by \\N{} in character class");
7743         }
7744
7745         length_of_hex = (STRLEN)(endchar - RExC_parse);
7746         *valuep = grok_hex(RExC_parse, &length_of_hex, &flags, NULL);
7747
7748         /* The tokenizer should have guaranteed validity, but it's possible to
7749          * bypass it by using single quoting, so check */
7750         if (length_of_hex == 0
7751             || length_of_hex != (STRLEN)(endchar - RExC_parse) )
7752         {
7753             RExC_parse += length_of_hex;        /* Includes all the valid */
7754             RExC_parse += (RExC_orig_utf8)      /* point to after 1st invalid */
7755                             ? UTF8SKIP(RExC_parse)
7756                             : 1;
7757             /* Guard against malformed utf8 */
7758             if (RExC_parse >= endchar) RExC_parse = endchar;
7759             vFAIL("Invalid hexadecimal number in \\N{U+...}");
7760         }    
7761
7762         RExC_parse = endbrace + 1;
7763         if (endchar == endbrace) return NULL;
7764
7765         ret = (regnode *) &RExC_parse;  /* Invalid regnode pointer */
7766     }
7767     else {      /* Not a char class */
7768
7769         /* What is done here is to convert this to a sub-pattern of the form
7770          * (?:\x{char1}\x{char2}...)
7771          * and then call reg recursively.  That way, it retains its atomicness,
7772          * while not having to worry about special handling that some code
7773          * points may have.  toke.c has converted the original Unicode values
7774          * to native, so that we can just pass on the hex values unchanged.  We
7775          * do have to set a flag to keep recoding from happening in the
7776          * recursion */
7777
7778         SV * substitute_parse = newSVpvn_flags("?:", 2, SVf_UTF8|SVs_TEMP);
7779         STRLEN len;
7780         char *endchar;      /* Points to '.' or '}' ending cur char in the input
7781                                stream */
7782         char *orig_end = RExC_end;
7783
7784         while (RExC_parse < endbrace) {
7785
7786             /* Code points are separated by dots.  If none, there is only one
7787              * code point, and is terminated by the brace */
7788             endchar = RExC_parse + strcspn(RExC_parse, ".}");
7789
7790             /* Convert to notation the rest of the code understands */
7791             sv_catpv(substitute_parse, "\\x{");
7792             sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
7793             sv_catpv(substitute_parse, "}");
7794
7795             /* Point to the beginning of the next character in the sequence. */
7796             RExC_parse = endchar + 1;
7797         }
7798         sv_catpv(substitute_parse, ")");
7799
7800         RExC_parse = SvPV(substitute_parse, len);
7801
7802         /* Don't allow empty number */
7803         if (len < 8) {
7804             vFAIL("Invalid hexadecimal number in \\N{U+...}");
7805         }
7806         RExC_end = RExC_parse + len;
7807
7808         /* The values are Unicode, and therefore not subject to recoding */
7809         RExC_override_recoding = 1;
7810
7811         ret = reg(pRExC_state, 1, flagp, depth+1);
7812
7813         RExC_parse = endbrace;
7814         RExC_end = orig_end;
7815         RExC_override_recoding = 0;
7816
7817         nextchar(pRExC_state);
7818     }
7819
7820     return ret;
7821 }
7822
7823
7824 /*
7825  * reg_recode
7826  *
7827  * It returns the code point in utf8 for the value in *encp.
7828  *    value: a code value in the source encoding
7829  *    encp:  a pointer to an Encode object
7830  *
7831  * If the result from Encode is not a single character,
7832  * it returns U+FFFD (Replacement character) and sets *encp to NULL.
7833  */
7834 STATIC UV
7835 S_reg_recode(pTHX_ const char value, SV **encp)
7836 {
7837     STRLEN numlen = 1;
7838     SV * const sv = newSVpvn_flags(&value, numlen, SVs_TEMP);
7839     const char * const s = *encp ? sv_recode_to_utf8(sv, *encp) : SvPVX(sv);
7840     const STRLEN newlen = SvCUR(sv);
7841     UV uv = UNICODE_REPLACEMENT;
7842
7843     PERL_ARGS_ASSERT_REG_RECODE;
7844
7845     if (newlen)
7846         uv = SvUTF8(sv)
7847              ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
7848              : *(U8*)s;
7849
7850     if (!newlen || numlen != newlen) {
7851         uv = UNICODE_REPLACEMENT;
7852         *encp = NULL;
7853     }
7854     return uv;
7855 }
7856
7857
7858 /*
7859  - regatom - the lowest level
7860
7861    Try to identify anything special at the start of the pattern. If there
7862    is, then handle it as required. This may involve generating a single regop,
7863    such as for an assertion; or it may involve recursing, such as to
7864    handle a () structure.
7865
7866    If the string doesn't start with something special then we gobble up
7867    as much literal text as we can.
7868
7869    Once we have been able to handle whatever type of thing started the
7870    sequence, we return.
7871
7872    Note: we have to be careful with escapes, as they can be both literal
7873    and special, and in the case of \10 and friends can either, depending
7874    on context. Specifically there are two separate switches for handling
7875    escape sequences, with the one for handling literal escapes requiring
7876    a dummy entry for all of the special escapes that are actually handled
7877    by the other.
7878 */
7879
7880 STATIC regnode *
7881 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
7882 {
7883     dVAR;
7884     register regnode *ret = NULL;
7885     I32 flags;
7886     char *parse_start = RExC_parse;
7887     U8 op;
7888     GET_RE_DEBUG_FLAGS_DECL;
7889     DEBUG_PARSE("atom");
7890     *flagp = WORST;             /* Tentatively. */
7891
7892     PERL_ARGS_ASSERT_REGATOM;
7893
7894 tryagain:
7895     switch ((U8)*RExC_parse) {
7896     case '^':
7897         RExC_seen_zerolen++;
7898         nextchar(pRExC_state);
7899         if (RExC_flags & RXf_PMf_MULTILINE)
7900             ret = reg_node(pRExC_state, MBOL);
7901         else if (RExC_flags & RXf_PMf_SINGLELINE)
7902             ret = reg_node(pRExC_state, SBOL);
7903         else
7904             ret = reg_node(pRExC_state, BOL);
7905         Set_Node_Length(ret, 1); /* MJD */
7906         break;
7907     case '$':
7908         nextchar(pRExC_state);
7909         if (*RExC_parse)
7910             RExC_seen_zerolen++;
7911         if (RExC_flags & RXf_PMf_MULTILINE)
7912             ret = reg_node(pRExC_state, MEOL);
7913         else if (RExC_flags & RXf_PMf_SINGLELINE)
7914             ret = reg_node(pRExC_state, SEOL);
7915         else
7916             ret = reg_node(pRExC_state, EOL);
7917         Set_Node_Length(ret, 1); /* MJD */
7918         break;
7919     case '.':
7920         nextchar(pRExC_state);
7921         if (RExC_flags & RXf_PMf_SINGLELINE)
7922             ret = reg_node(pRExC_state, SANY);
7923         else
7924             ret = reg_node(pRExC_state, REG_ANY);
7925         *flagp |= HASWIDTH|SIMPLE;
7926         RExC_naughty++;
7927         Set_Node_Length(ret, 1); /* MJD */
7928         break;
7929     case '[':
7930     {
7931         char * const oregcomp_parse = ++RExC_parse;
7932         ret = regclass(pRExC_state,depth+1);
7933         if (*RExC_parse != ']') {
7934             RExC_parse = oregcomp_parse;
7935             vFAIL("Unmatched [");
7936         }
7937         nextchar(pRExC_state);
7938         *flagp |= HASWIDTH|SIMPLE;
7939         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
7940         break;
7941     }
7942     case '(':
7943         nextchar(pRExC_state);
7944         ret = reg(pRExC_state, 1, &flags,depth+1);
7945         if (ret == NULL) {
7946                 if (flags & TRYAGAIN) {
7947                     if (RExC_parse == RExC_end) {
7948                          /* Make parent create an empty node if needed. */
7949                         *flagp |= TRYAGAIN;
7950                         return(NULL);
7951                     }
7952                     goto tryagain;
7953                 }
7954                 return(NULL);
7955         }
7956         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
7957         break;
7958     case '|':
7959     case ')':
7960         if (flags & TRYAGAIN) {
7961             *flagp |= TRYAGAIN;
7962             return NULL;
7963         }
7964         vFAIL("Internal urp");
7965                                 /* Supposed to be caught earlier. */
7966         break;
7967     case '{':
7968         if (!regcurly(RExC_parse)) {
7969             RExC_parse++;
7970             goto defchar;
7971         }
7972         /* FALL THROUGH */
7973     case '?':
7974     case '+':
7975     case '*':
7976         RExC_parse++;
7977         vFAIL("Quantifier follows nothing");
7978         break;
7979     case '\\':
7980         /* Special Escapes
7981
7982            This switch handles escape sequences that resolve to some kind
7983            of special regop and not to literal text. Escape sequnces that
7984            resolve to literal text are handled below in the switch marked
7985            "Literal Escapes".
7986
7987            Every entry in this switch *must* have a corresponding entry
7988            in the literal escape switch. However, the opposite is not
7989            required, as the default for this switch is to jump to the
7990            literal text handling code.
7991         */
7992         switch ((U8)*++RExC_parse) {
7993         /* Special Escapes */
7994         case 'A':
7995             RExC_seen_zerolen++;
7996             ret = reg_node(pRExC_state, SBOL);
7997             *flagp |= SIMPLE;
7998             goto finish_meta_pat;
7999         case 'G':
8000             ret = reg_node(pRExC_state, GPOS);
8001             RExC_seen |= REG_SEEN_GPOS;
8002             *flagp |= SIMPLE;
8003             goto finish_meta_pat;
8004         case 'K':
8005             RExC_seen_zerolen++;
8006             ret = reg_node(pRExC_state, KEEPS);
8007             *flagp |= SIMPLE;
8008             /* XXX:dmq : disabling in-place substitution seems to
8009              * be necessary here to avoid cases of memory corruption, as
8010              * with: C<$_="x" x 80; s/x\K/y/> -- rgs
8011              */
8012             RExC_seen |= REG_SEEN_LOOKBEHIND;
8013             goto finish_meta_pat;
8014         case 'Z':
8015             ret = reg_node(pRExC_state, SEOL);
8016             *flagp |= SIMPLE;
8017             RExC_seen_zerolen++;                /* Do not optimize RE away */
8018             goto finish_meta_pat;
8019         case 'z':
8020             ret = reg_node(pRExC_state, EOS);
8021             *flagp |= SIMPLE;
8022             RExC_seen_zerolen++;                /* Do not optimize RE away */
8023             goto finish_meta_pat;
8024         case 'C':
8025             ret = reg_node(pRExC_state, CANY);
8026             RExC_seen |= REG_SEEN_CANY;
8027             *flagp |= HASWIDTH|SIMPLE;
8028             goto finish_meta_pat;
8029         case 'X':
8030             ret = reg_node(pRExC_state, CLUMP);
8031             *flagp |= HASWIDTH;
8032             goto finish_meta_pat;
8033         case 'w':
8034             switch (get_regex_charset(RExC_flags)) {
8035                 case REGEX_LOCALE_CHARSET:
8036                     op = ALNUML;
8037                     break;
8038                 case REGEX_UNICODE_CHARSET:
8039                     op = ALNUMU;
8040                     break;
8041                 case REGEX_ASCII_RESTRICTED_CHARSET:
8042                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8043                     op = ALNUMA;
8044                     break;
8045                 case REGEX_DEPENDS_CHARSET:
8046                     op = ALNUM;
8047                     break;
8048                 default:
8049                     goto bad_charset;
8050             }
8051             ret = reg_node(pRExC_state, op);
8052             *flagp |= HASWIDTH|SIMPLE;
8053             goto finish_meta_pat;
8054         case 'W':
8055             switch (get_regex_charset(RExC_flags)) {
8056                 case REGEX_LOCALE_CHARSET:
8057                     op = NALNUML;
8058                     break;
8059                 case REGEX_UNICODE_CHARSET:
8060                     op = NALNUMU;
8061                     break;
8062                 case REGEX_ASCII_RESTRICTED_CHARSET:
8063                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8064                     op = NALNUMA;
8065                     break;
8066                 case REGEX_DEPENDS_CHARSET:
8067                     op = NALNUM;
8068                     break;
8069                 default:
8070                     goto bad_charset;
8071             }
8072             ret = reg_node(pRExC_state, op);
8073             *flagp |= HASWIDTH|SIMPLE;
8074             goto finish_meta_pat;
8075         case 'b':
8076             RExC_seen_zerolen++;
8077             RExC_seen |= REG_SEEN_LOOKBEHIND;
8078             switch (get_regex_charset(RExC_flags)) {
8079                 case REGEX_LOCALE_CHARSET:
8080                     op = BOUNDL;
8081                     break;
8082                 case REGEX_UNICODE_CHARSET:
8083                     op = BOUNDU;
8084                     break;
8085                 case REGEX_ASCII_RESTRICTED_CHARSET:
8086                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8087                     op = BOUNDA;
8088                     break;
8089                 case REGEX_DEPENDS_CHARSET:
8090                     op = BOUND;
8091                     break;
8092                 default:
8093                     goto bad_charset;
8094             }
8095             ret = reg_node(pRExC_state, op);
8096             FLAGS(ret) = get_regex_charset(RExC_flags);
8097             *flagp |= SIMPLE;
8098             if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
8099                 ckWARNregdep(RExC_parse, "\"\\b{\" is deprecated; use \"\\b\\{\" instead");
8100             }
8101             goto finish_meta_pat;
8102         case 'B':
8103             RExC_seen_zerolen++;
8104             RExC_seen |= REG_SEEN_LOOKBEHIND;
8105             switch (get_regex_charset(RExC_flags)) {
8106                 case REGEX_LOCALE_CHARSET:
8107                     op = NBOUNDL;
8108                     break;
8109                 case REGEX_UNICODE_CHARSET:
8110                     op = NBOUNDU;
8111                     break;
8112                 case REGEX_ASCII_RESTRICTED_CHARSET:
8113                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8114                     op = NBOUNDA;
8115                     break;
8116                 case REGEX_DEPENDS_CHARSET:
8117                     op = NBOUND;
8118                     break;
8119                 default:
8120                     goto bad_charset;
8121             }
8122             ret = reg_node(pRExC_state, op);
8123             FLAGS(ret) = get_regex_charset(RExC_flags);
8124             *flagp |= SIMPLE;
8125             if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
8126                 ckWARNregdep(RExC_parse, "\"\\B{\" is deprecated; use \"\\B\\{\" instead");
8127             }
8128             goto finish_meta_pat;
8129         case 's':
8130             switch (get_regex_charset(RExC_flags)) {
8131                 case REGEX_LOCALE_CHARSET:
8132                     op = SPACEL;
8133                     break;
8134                 case REGEX_UNICODE_CHARSET:
8135                     op = SPACEU;
8136                     break;
8137                 case REGEX_ASCII_RESTRICTED_CHARSET:
8138                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8139                     op = SPACEA;
8140                     break;
8141                 case REGEX_DEPENDS_CHARSET:
8142                     op = SPACE;
8143                     break;
8144                 default:
8145                     goto bad_charset;
8146             }
8147             ret = reg_node(pRExC_state, op);
8148             *flagp |= HASWIDTH|SIMPLE;
8149             goto finish_meta_pat;
8150         case 'S':
8151             switch (get_regex_charset(RExC_flags)) {
8152                 case REGEX_LOCALE_CHARSET:
8153                     op = NSPACEL;
8154                     break;
8155                 case REGEX_UNICODE_CHARSET:
8156                     op = NSPACEU;
8157                     break;
8158                 case REGEX_ASCII_RESTRICTED_CHARSET:
8159                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8160                     op = NSPACEA;
8161                     break;
8162                 case REGEX_DEPENDS_CHARSET:
8163                     op = NSPACE;
8164                     break;
8165                 default:
8166                     goto bad_charset;
8167             }
8168             ret = reg_node(pRExC_state, op);
8169             *flagp |= HASWIDTH|SIMPLE;
8170             goto finish_meta_pat;
8171         case 'd':
8172             switch (get_regex_charset(RExC_flags)) {
8173                 case REGEX_LOCALE_CHARSET:
8174                     op = DIGITL;
8175                     break;
8176                 case REGEX_ASCII_RESTRICTED_CHARSET:
8177                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8178                     op = DIGITA;
8179                     break;
8180                 case REGEX_DEPENDS_CHARSET: /* No difference between these */
8181                 case REGEX_UNICODE_CHARSET:
8182                     op = DIGIT;
8183                     break;
8184                 default:
8185                     goto bad_charset;
8186             }
8187             ret = reg_node(pRExC_state, op);
8188             *flagp |= HASWIDTH|SIMPLE;
8189             goto finish_meta_pat;
8190         case 'D':
8191             switch (get_regex_charset(RExC_flags)) {
8192                 case REGEX_LOCALE_CHARSET:
8193                     op = NDIGITL;
8194                     break;
8195                 case REGEX_ASCII_RESTRICTED_CHARSET:
8196                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
8197                     op = NDIGITA;
8198                     break;
8199                 case REGEX_DEPENDS_CHARSET: /* No difference between these */
8200                 case REGEX_UNICODE_CHARSET:
8201                     op = NDIGIT;
8202                     break;
8203                 default:
8204                     goto bad_charset;
8205             }
8206             ret = reg_node(pRExC_state, op);
8207             *flagp |= HASWIDTH|SIMPLE;
8208             goto finish_meta_pat;
8209         case 'R':
8210             ret = reg_node(pRExC_state, LNBREAK);
8211             *flagp |= HASWIDTH|SIMPLE;
8212             goto finish_meta_pat;
8213         case 'h':
8214             ret = reg_node(pRExC_state, HORIZWS);
8215             *flagp |= HASWIDTH|SIMPLE;
8216             goto finish_meta_pat;
8217         case 'H':
8218             ret = reg_node(pRExC_state, NHORIZWS);
8219             *flagp |= HASWIDTH|SIMPLE;
8220             goto finish_meta_pat;
8221         case 'v':
8222             ret = reg_node(pRExC_state, VERTWS);
8223             *flagp |= HASWIDTH|SIMPLE;
8224             goto finish_meta_pat;
8225         case 'V':
8226             ret = reg_node(pRExC_state, NVERTWS);
8227             *flagp |= HASWIDTH|SIMPLE;
8228          finish_meta_pat:           
8229             nextchar(pRExC_state);
8230             Set_Node_Length(ret, 2); /* MJD */
8231             break;          
8232         case 'p':
8233         case 'P':
8234             {   
8235                 char* const oldregxend = RExC_end;
8236 #ifdef DEBUGGING
8237                 char* parse_start = RExC_parse - 2;
8238 #endif
8239
8240                 if (RExC_parse[1] == '{') {
8241                   /* a lovely hack--pretend we saw [\pX] instead */
8242                     RExC_end = strchr(RExC_parse, '}');
8243                     if (!RExC_end) {
8244                         const U8 c = (U8)*RExC_parse;
8245                         RExC_parse += 2;
8246                         RExC_end = oldregxend;
8247                         vFAIL2("Missing right brace on \\%c{}", c);
8248                     }
8249                     RExC_end++;
8250                 }
8251                 else {
8252                     RExC_end = RExC_parse + 2;
8253                     if (RExC_end > oldregxend)
8254                         RExC_end = oldregxend;
8255                 }
8256                 RExC_parse--;
8257
8258                 ret = regclass(pRExC_state,depth+1);
8259
8260                 RExC_end = oldregxend;
8261                 RExC_parse--;
8262
8263                 Set_Node_Offset(ret, parse_start + 2);
8264                 Set_Node_Cur_Length(ret);
8265                 nextchar(pRExC_state);
8266                 *flagp |= HASWIDTH|SIMPLE;
8267             }
8268             break;
8269         case 'N': 
8270             /* Handle \N and \N{NAME} here and not below because it can be
8271             multicharacter. join_exact() will join them up later on. 
8272             Also this makes sure that things like /\N{BLAH}+/ and 
8273             \N{BLAH} being multi char Just Happen. dmq*/
8274             ++RExC_parse;
8275             ret= reg_namedseq(pRExC_state, NULL, flagp, depth);
8276             break;
8277         case 'k':    /* Handle \k<NAME> and \k'NAME' */
8278         parse_named_seq:
8279         {   
8280             char ch= RExC_parse[1];         
8281             if (ch != '<' && ch != '\'' && ch != '{') {
8282                 RExC_parse++;
8283                 vFAIL2("Sequence %.2s... not terminated",parse_start);
8284             } else {
8285                 /* this pretty much dupes the code for (?P=...) in reg(), if
8286                    you change this make sure you change that */
8287                 char* name_start = (RExC_parse += 2);
8288                 U32 num = 0;
8289                 SV *sv_dat = reg_scan_name(pRExC_state,
8290                     SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8291                 ch= (ch == '<') ? '>' : (ch == '{') ? '}' : '\'';
8292                 if (RExC_parse == name_start || *RExC_parse != ch)
8293                     vFAIL2("Sequence %.3s... not terminated",parse_start);
8294
8295                 if (!SIZE_ONLY) {
8296                     num = add_data( pRExC_state, 1, "S" );
8297                     RExC_rxi->data->data[num]=(void*)sv_dat;
8298                     SvREFCNT_inc_simple_void(sv_dat);
8299                 }
8300
8301                 RExC_sawback = 1;
8302                 ret = reganode(pRExC_state,
8303                                ((! FOLD)
8304                                  ? NREF
8305                                  : (MORE_ASCII_RESTRICTED)
8306                                    ? NREFFA
8307                                    : (AT_LEAST_UNI_SEMANTICS)
8308                                      ? NREFFU
8309                                      : (LOC)
8310                                        ? NREFFL
8311                                        : NREFF),
8312                                 num);
8313                 *flagp |= HASWIDTH;
8314
8315                 /* override incorrect value set in reganode MJD */
8316                 Set_Node_Offset(ret, parse_start+1);
8317                 Set_Node_Cur_Length(ret); /* MJD */
8318                 nextchar(pRExC_state);
8319
8320             }
8321             break;
8322         }
8323         case 'g': 
8324         case '1': case '2': case '3': case '4':
8325         case '5': case '6': case '7': case '8': case '9':
8326             {
8327                 I32 num;
8328                 bool isg = *RExC_parse == 'g';
8329                 bool isrel = 0; 
8330                 bool hasbrace = 0;
8331                 if (isg) {
8332                     RExC_parse++;
8333                     if (*RExC_parse == '{') {
8334                         RExC_parse++;
8335                         hasbrace = 1;
8336                     }
8337                     if (*RExC_parse == '-') {
8338                         RExC_parse++;
8339                         isrel = 1;
8340                     }
8341                     if (hasbrace && !isDIGIT(*RExC_parse)) {
8342                         if (isrel) RExC_parse--;
8343                         RExC_parse -= 2;                            
8344                         goto parse_named_seq;
8345                 }   }
8346                 num = atoi(RExC_parse);
8347                 if (isg && num == 0)
8348                     vFAIL("Reference to invalid group 0");
8349                 if (isrel) {
8350                     num = RExC_npar - num;
8351                     if (num < 1)
8352                         vFAIL("Reference to nonexistent or unclosed group");
8353                 }
8354                 if (!isg && num > 9 && num >= RExC_npar)
8355                     goto defchar;
8356                 else {
8357                     char * const parse_start = RExC_parse - 1; /* MJD */
8358                     while (isDIGIT(*RExC_parse))
8359                         RExC_parse++;
8360                     if (parse_start == RExC_parse - 1) 
8361                         vFAIL("Unterminated \\g... pattern");
8362                     if (hasbrace) {
8363                         if (*RExC_parse != '}') 
8364                             vFAIL("Unterminated \\g{...} pattern");
8365                         RExC_parse++;
8366                     }    
8367                     if (!SIZE_ONLY) {
8368                         if (num > (I32)RExC_rx->nparens)
8369                             vFAIL("Reference to nonexistent group");
8370                     }
8371                     RExC_sawback = 1;
8372                     ret = reganode(pRExC_state,
8373                                    ((! FOLD)
8374                                      ? REF
8375                                      : (MORE_ASCII_RESTRICTED)
8376                                        ? REFFA
8377                                        : (AT_LEAST_UNI_SEMANTICS)
8378                                          ? REFFU
8379                                          : (LOC)
8380                                            ? REFFL
8381                                            : REFF),
8382                                     num);
8383                     *flagp |= HASWIDTH;
8384
8385                     /* override incorrect value set in reganode MJD */
8386                     Set_Node_Offset(ret, parse_start+1);
8387                     Set_Node_Cur_Length(ret); /* MJD */
8388                     RExC_parse--;
8389                     nextchar(pRExC_state);
8390                 }
8391             }
8392             break;
8393         case '\0':
8394             if (RExC_parse >= RExC_end)
8395                 FAIL("Trailing \\");
8396             /* FALL THROUGH */
8397         default:
8398             /* Do not generate "unrecognized" warnings here, we fall
8399                back into the quick-grab loop below */
8400             parse_start--;
8401             goto defchar;
8402         }
8403         break;
8404
8405     case '#':
8406         if (RExC_flags & RXf_PMf_EXTENDED) {
8407             if ( reg_skipcomment( pRExC_state ) )
8408                 goto tryagain;
8409         }
8410         /* FALL THROUGH */
8411
8412     default:
8413
8414             parse_start = RExC_parse - 1;
8415
8416             RExC_parse++;
8417
8418         defchar: {
8419             typedef enum {
8420                 generic_char = 0,
8421                 char_s,
8422                 upsilon_1,
8423                 upsilon_2,
8424                 iota_1,
8425                 iota_2,
8426             } char_state;
8427             char_state latest_char_state = generic_char;
8428             register STRLEN len;
8429             register UV ender;
8430             register char *p;
8431             char *s;
8432             STRLEN foldlen;
8433             U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
8434             regnode * orig_emit;
8435
8436             ender = 0;
8437             orig_emit = RExC_emit; /* Save the original output node position in
8438                                       case we need to output a different node
8439                                       type */
8440             ret = reg_node(pRExC_state,
8441                            (U8) ((! FOLD) ? EXACT
8442                                           : (LOC)
8443                                              ? EXACTFL
8444                                              : (MORE_ASCII_RESTRICTED)
8445                                                ? EXACTFA
8446                                                : (AT_LEAST_UNI_SEMANTICS)
8447                                                  ? EXACTFU
8448                                                  : EXACTF)
8449                     );
8450             s = STRING(ret);
8451             for (len = 0, p = RExC_parse - 1;
8452               len < 127 && p < RExC_end;
8453               len++)
8454             {
8455                 char * const oldp = p;
8456
8457                 if (RExC_flags & RXf_PMf_EXTENDED)
8458                     p = regwhite( pRExC_state, p );
8459                 switch ((U8)*p) {
8460                 case '^':
8461                 case '$':
8462                 case '.':
8463                 case '[':
8464                 case '(':
8465                 case ')':
8466                 case '|':
8467                     goto loopdone;
8468                 case '\\':
8469                     /* Literal Escapes Switch
8470
8471                        This switch is meant to handle escape sequences that
8472                        resolve to a literal character.
8473
8474                        Every escape sequence that represents something
8475                        else, like an assertion or a char class, is handled
8476                        in the switch marked 'Special Escapes' above in this
8477                        routine, but also has an entry here as anything that
8478                        isn't explicitly mentioned here will be treated as
8479                        an unescaped equivalent literal.
8480                     */
8481
8482                     switch ((U8)*++p) {
8483                     /* These are all the special escapes. */
8484                     case 'A':             /* Start assertion */
8485                     case 'b': case 'B':   /* Word-boundary assertion*/
8486                     case 'C':             /* Single char !DANGEROUS! */
8487                     case 'd': case 'D':   /* digit class */
8488                     case 'g': case 'G':   /* generic-backref, pos assertion */
8489                     case 'h': case 'H':   /* HORIZWS */
8490                     case 'k': case 'K':   /* named backref, keep marker */
8491                     case 'N':             /* named char sequence */
8492                     case 'p': case 'P':   /* Unicode property */
8493                               case 'R':   /* LNBREAK */
8494                     case 's': case 'S':   /* space class */
8495                     case 'v': case 'V':   /* VERTWS */
8496                     case 'w': case 'W':   /* word class */
8497                     case 'X':             /* eXtended Unicode "combining character sequence" */
8498                     case 'z': case 'Z':   /* End of line/string assertion */
8499                         --p;
8500                         goto loopdone;
8501
8502                     /* Anything after here is an escape that resolves to a
8503                        literal. (Except digits, which may or may not)
8504                      */
8505                     case 'n':
8506                         ender = '\n';
8507                         p++;
8508                         break;
8509                     case 'r':
8510                         ender = '\r';
8511                         p++;
8512                         break;
8513                     case 't':
8514                         ender = '\t';
8515                         p++;
8516                         break;
8517                     case 'f':
8518                         ender = '\f';
8519                         p++;
8520                         break;
8521                     case 'e':
8522                           ender = ASCII_TO_NATIVE('\033');
8523                         p++;
8524                         break;
8525                     case 'a':
8526                           ender = ASCII_TO_NATIVE('\007');
8527                         p++;
8528                         break;
8529                     case 'o':
8530                         {
8531                             STRLEN brace_len = len;
8532                             UV result;
8533                             const char* error_msg;
8534
8535                             bool valid = grok_bslash_o(p,
8536                                                        &result,
8537                                                        &brace_len,
8538                                                        &error_msg,
8539                                                        1);
8540                             p += brace_len;
8541                             if (! valid) {
8542                                 RExC_parse = p; /* going to die anyway; point
8543                                                    to exact spot of failure */
8544                                 vFAIL(error_msg);
8545                             }
8546                             else
8547                             {
8548                                 ender = result;
8549                             }
8550                             if (PL_encoding && ender < 0x100) {
8551                                 goto recode_encoding;
8552                             }
8553                             if (ender > 0xff) {
8554                                 REQUIRE_UTF8;
8555                             }
8556                             break;
8557                         }
8558                     case 'x':
8559                         if (*++p == '{') {
8560                             char* const e = strchr(p, '}');
8561         
8562                             if (!e) {
8563                                 RExC_parse = p + 1;
8564                                 vFAIL("Missing right brace on \\x{}");
8565                             }
8566                             else {
8567                                 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
8568                                     | PERL_SCAN_DISALLOW_PREFIX;
8569                                 STRLEN numlen = e - p - 1;
8570                                 ender = grok_hex(p + 1, &numlen, &flags, NULL);
8571                                 if (ender > 0xff)
8572                                     REQUIRE_UTF8;
8573                                 p = e + 1;
8574                             }
8575                         }
8576                         else {
8577                             I32 flags = PERL_SCAN_DISALLOW_PREFIX;
8578                             STRLEN numlen = 2;
8579                             ender = grok_hex(p, &numlen, &flags, NULL);
8580                             p += numlen;
8581                         }
8582                         if (PL_encoding && ender < 0x100)
8583                             goto recode_encoding;
8584                         break;
8585                     case 'c':
8586                         p++;
8587                         ender = grok_bslash_c(*p++, UTF, SIZE_ONLY);
8588                         break;
8589                     case '0': case '1': case '2': case '3':case '4':
8590                     case '5': case '6': case '7': case '8':case '9':
8591                         if (*p == '0' ||
8592                             (isDIGIT(p[1]) && atoi(p) >= RExC_npar))
8593                         {
8594                             I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
8595                             STRLEN numlen = 3;
8596                             ender = grok_oct(p, &numlen, &flags, NULL);
8597                             if (ender > 0xff) {
8598                                 REQUIRE_UTF8;
8599                             }
8600                             p += numlen;
8601                         }
8602                         else {
8603                             --p;
8604                             goto loopdone;
8605                         }
8606                         if (PL_encoding && ender < 0x100)
8607                             goto recode_encoding;
8608                         break;
8609                     recode_encoding:
8610                         if (! RExC_override_recoding) {
8611                             SV* enc = PL_encoding;
8612                             ender = reg_recode((const char)(U8)ender, &enc);
8613                             if (!enc && SIZE_ONLY)
8614                                 ckWARNreg(p, "Invalid escape in the specified encoding");
8615                             REQUIRE_UTF8;
8616                         }
8617                         break;
8618                     case '\0':
8619                         if (p >= RExC_end)
8620                             FAIL("Trailing \\");
8621                         /* FALL THROUGH */
8622                     default:
8623                         if (!SIZE_ONLY&& isALPHA(*p)) {
8624                             /* Include any { following the alpha to emphasize
8625                              * that it could be part of an escape at some point
8626                              * in the future */
8627                             int len = (*(p + 1) == '{') ? 2 : 1;
8628                             ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p);
8629                         }
8630                         goto normal_default;
8631                     }
8632                     break;
8633                 default:
8634                   normal_default:
8635                     if (UTF8_IS_START(*p) && UTF) {
8636                         STRLEN numlen;
8637                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
8638                                                &numlen, UTF8_ALLOW_DEFAULT);
8639                         p += numlen;
8640                     }
8641                     else
8642                         ender = (U8) *p++;
8643                     break;
8644                 } /* End of switch on the literal */
8645
8646                 /* Certain characters are problematic because their folded
8647                  * length is so different from their original length that it
8648                  * isn't handleable by the optimizer.  They are therefore not
8649                  * placed in an EXACTish node; and are here handled specially.
8650                  * (Even if the optimizer handled LATIN_SMALL_LETTER_SHARP_S,
8651                  * putting it in a special node keeps regexec from having to
8652                  * deal with a non-utf8 multi-char fold */
8653                 if (FOLD
8654                     && (ender > 255 || (! MORE_ASCII_RESTRICTED && ! LOC)))
8655                 {
8656                     /* We look for either side of the fold.  For example \xDF
8657                      * folds to 'ss'.  We look for both the single character
8658                      * \xDF and the sequence 'ss'.  When we find something that
8659                      * could be one of those, we stop and flush whatever we
8660                      * have output so far into the EXACTish node that was being
8661                      * built.  Then restore the input pointer to what it was.
8662                      * regatom will return that EXACT node, and will be called
8663                      * again, positioned so the first character is the one in
8664                      * question, which we return in a different node type.
8665                      * The multi-char folds are a sequence, so the occurrence
8666                      * of the first character in that sequence doesn't
8667                      * necessarily mean that what follows is the rest of the
8668                      * sequence.  We keep track of that with a state machine,
8669                      * with the state being set to the latest character
8670                      * processed before the current one.  Most characters will
8671                      * set the state to 0, but if one occurs that is part of a
8672                      * potential tricky fold sequence, the state is set to that
8673                      * character, and the next loop iteration sees if the state
8674                      * should progress towards the final folded-from character,
8675                      * or if it was a false alarm.  If it turns out to be a
8676                      * false alarm, the character(s) will be output in a new
8677                      * EXACTish node, and join_exact() will later combine them.
8678                      * In the case of the 'ss' sequence, which is more common
8679                      * and more easily checked, some look-ahead is done to
8680                      * save time by ruling-out some false alarms */
8681                     switch (ender) {
8682                         default:
8683                             latest_char_state = generic_char;
8684                             break;
8685                         case 's':
8686                         case 'S':
8687                         case 0x17F: /* LATIN SMALL LETTER LONG S */
8688                              if (AT_LEAST_UNI_SEMANTICS) {
8689                                 if (latest_char_state == char_s) {  /* 'ss' */
8690                                     ender = LATIN_SMALL_LETTER_SHARP_S;
8691                                     goto do_tricky;
8692                                 }
8693                                 else if (p < RExC_end) {
8694
8695                                     /* Look-ahead at the next character.  If it
8696                                      * is also an s, we handle as a sharp s
8697                                      * tricky regnode.  */
8698                                     if (*p == 's' || *p == 'S') {
8699
8700                                         /* But first flush anything in the
8701                                          * EXACTish buffer */
8702                                         if (len != 0) {
8703                                             p = oldp;
8704                                             goto loopdone;
8705                                         }
8706                                         p++;    /* Account for swallowing this
8707                                                    's' up */
8708                                         ender = LATIN_SMALL_LETTER_SHARP_S;
8709                                         goto do_tricky;
8710                                     }
8711                                         /* Here, the next character is not a
8712                                          * literal 's', but still could
8713                                          * evaluate to one if part of a \o{},
8714                                          * \x or \OCTAL-DIGIT.  The minimum
8715                                          * length required for that is 4, eg
8716                                          * \x53 or \123 */
8717                                     else if (*p == '\\'
8718                                              && p < RExC_end - 4
8719                                              && (isDIGIT(*(p + 1))
8720                                                  || *(p + 1) == 'x'
8721                                                  || *(p + 1) == 'o' ))
8722                                     {
8723
8724                                         /* Here, it could be an 's', too much
8725                                          * bother to figure it out here.  Flush
8726                                          * the buffer if any; when come back
8727                                          * here, set the state so know that the
8728                                          * previous char was an 's' */
8729                                         if (len != 0) {
8730                                             latest_char_state = generic_char;
8731                                             p = oldp;
8732                                             goto loopdone;
8733                                         }
8734                                         latest_char_state = char_s;
8735                                         break;
8736                                     }
8737                                 }
8738                             }
8739
8740                             /* Here, can't be an 'ss' sequence, or at least not
8741                              * one that could fold to/from the sharp ss */
8742                             latest_char_state = generic_char;
8743                             break;
8744                         case 0x03C5:    /* First char in upsilon series */
8745                             if (p < RExC_end - 4) { /* Need >= 4 bytes left */
8746                                 latest_char_state = upsilon_1;
8747                                 if (len != 0) {
8748                                     p = oldp;
8749                                     goto loopdone;
8750                                 }
8751                             }
8752                             else {
8753                                 latest_char_state = generic_char;
8754                             }
8755                             break;
8756                         case 0x03B9:    /* First char in iota series */
8757                             if (p < RExC_end - 4) {
8758                                 latest_char_state = iota_1;
8759                                 if (len != 0) {
8760                                     p = oldp;
8761                                     goto loopdone;
8762                                 }
8763                             }
8764                             else {
8765                                 latest_char_state = generic_char;
8766                             }
8767                             break;
8768                         case 0x0308:
8769                             if (latest_char_state == upsilon_1) {
8770                                 latest_char_state = upsilon_2;
8771                             }
8772                             else if (latest_char_state == iota_1) {
8773                                 latest_char_state = iota_2;
8774                             }
8775                             else {
8776                                 latest_char_state = generic_char;
8777                             }
8778                             break;
8779                         case 0x301:
8780                             if (latest_char_state == upsilon_2) {
8781                                 ender = GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS;
8782                                 goto do_tricky;
8783                             }
8784                             else if (latest_char_state == iota_2) {
8785                                 ender = GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS;
8786                                 goto do_tricky;
8787                             }
8788                             latest_char_state = generic_char;
8789                             break;
8790
8791                         /* These are the tricky fold characters.  Flush any
8792                          * buffer first. */
8793                         case GREEK_SMALL_LETTER_UPSILON_WITH_DIALYTIKA_AND_TONOS:
8794                         case GREEK_SMALL_LETTER_IOTA_WITH_DIALYTIKA_AND_TONOS:
8795                         case LATIN_SMALL_LETTER_SHARP_S:
8796                         case LATIN_CAPITAL_LETTER_SHARP_S:
8797                         case 0x1FD3:
8798                         case 0x1FE3:
8799                             if (len != 0) {
8800                                 p = oldp;
8801                                 goto loopdone;
8802                             }
8803                             /* FALL THROUGH */
8804                         do_tricky: {
8805                             char* const oldregxend = RExC_end;
8806                             U8 tmpbuf[UTF8_MAXBYTES+1];
8807
8808                             /* Here, we know we need to generate a special
8809                              * regnode, and 'ender' contains the tricky
8810                              * character.  What's done is to pretend it's in a
8811                              * [bracketed] class, and let the code that deals
8812                              * with those handle it, as that code has all the
8813                              * intelligence necessary.  First save the current
8814                              * parse state, get rid of the already allocated
8815                              * but empty EXACT node that the ANYOFV node will
8816                              * replace, and point the parse to a buffer which
8817                              * we fill with the character we want the regclass
8818                              * code to think is being parsed */
8819                             RExC_emit = orig_emit;
8820                             RExC_parse = (char *) tmpbuf;
8821                             if (UTF) {
8822                                 U8 *d = uvchr_to_utf8(tmpbuf, ender);
8823                                 *d = '\0';
8824                                 RExC_end = (char *) d;
8825                             }
8826                             else {  /* ender above 255 already excluded */
8827                                 tmpbuf[0] = (U8) ender;
8828                                 tmpbuf[1] = '\0';
8829                                 RExC_end = RExC_parse + 1;
8830                             }
8831
8832                             ret = regclass(pRExC_state,depth+1);
8833
8834                             /* Here, have parsed the buffer.  Reset the parse to
8835                              * the actual input, and return */
8836                             RExC_end = oldregxend;
8837                             RExC_parse = p - 1;
8838
8839                             Set_Node_Offset(ret, RExC_parse);
8840                             Set_Node_Cur_Length(ret);
8841                             nextchar(pRExC_state);
8842                             *flagp |= HASWIDTH|SIMPLE;
8843                             return ret;
8844                         }
8845                     }
8846                 }
8847
8848                 if ( RExC_flags & RXf_PMf_EXTENDED)
8849                     p = regwhite( pRExC_state, p );
8850                 if (UTF && FOLD) {
8851                     /* Prime the casefolded buffer.  Locale rules, which apply
8852                      * only to code points < 256, aren't known until execution,
8853                      * so for them, just output the original character using
8854                      * utf8 */
8855                     if (LOC && ender < 256) {
8856                         if (UNI_IS_INVARIANT(ender)) {
8857                             *tmpbuf = (U8) ender;
8858                             foldlen = 1;
8859                         } else {
8860                             *tmpbuf = UTF8_TWO_BYTE_HI(ender);
8861                             *(tmpbuf + 1) = UTF8_TWO_BYTE_LO(ender);
8862                             foldlen = 2;
8863                         }
8864                     }
8865                     else if (isASCII(ender)) {  /* Note: Here can't also be LOC
8866                                                  */
8867                         ender = toLOWER(ender);
8868                         *tmpbuf = (U8) ender;
8869                         foldlen = 1;
8870                     }
8871                     else if (! MORE_ASCII_RESTRICTED && ! LOC) {
8872
8873                         /* Locale and /aa require more selectivity about the
8874                          * fold, so are handled below.  Otherwise, here, just
8875                          * use the fold */
8876                         ender = toFOLD_uni(ender, tmpbuf, &foldlen);
8877                     }
8878                     else {
8879                         /* Under locale rules or /aa we are not to mix,
8880                          * respectively, ords < 256 or ASCII with non-.  So
8881                          * reject folds that mix them, using only the
8882                          * non-folded code point.  So do the fold to a
8883                          * temporary, and inspect each character in it. */
8884                         U8 trialbuf[UTF8_MAXBYTES_CASE+1];
8885                         U8* s = trialbuf;
8886                         UV tmpender = toFOLD_uni(ender, trialbuf, &foldlen);
8887                         U8* e = s + foldlen;
8888                         bool fold_ok = TRUE;
8889
8890                         while (s < e) {
8891                             if (isASCII(*s)
8892                                 || (LOC && (UTF8_IS_INVARIANT(*s)
8893                                            || UTF8_IS_DOWNGRADEABLE_START(*s))))
8894                             {
8895                                 fold_ok = FALSE;
8896                                 break;
8897                             }
8898                             s += UTF8SKIP(s);
8899                         }
8900                         if (fold_ok) {
8901                             Copy(trialbuf, tmpbuf, foldlen, U8);
8902                             ender = tmpender;
8903                         }
8904                         else {
8905                             uvuni_to_utf8(tmpbuf, ender);
8906                             foldlen = UNISKIP(ender);
8907                         }
8908                     }
8909                 }
8910                 if (p < RExC_end && ISMULT2(p)) { /* Back off on ?+*. */
8911                     if (len)
8912                         p = oldp;
8913                     else if (UTF) {
8914                          if (FOLD) {
8915                               /* Emit all the Unicode characters. */
8916                               STRLEN numlen;
8917                               for (foldbuf = tmpbuf;
8918                                    foldlen;
8919                                    foldlen -= numlen) {
8920                                    ender = utf8_to_uvchr(foldbuf, &numlen);
8921                                    if (numlen > 0) {
8922                                         const STRLEN unilen = reguni(pRExC_state, ender, s);
8923                                         s       += unilen;
8924                                         len     += unilen;
8925                                         /* In EBCDIC the numlen
8926                                          * and unilen can differ. */
8927                                         foldbuf += numlen;
8928                                         if (numlen >= foldlen)
8929                                              break;
8930                                    }
8931                                    else
8932                                         break; /* "Can't happen." */
8933                               }
8934                          }
8935                          else {
8936                               const STRLEN unilen = reguni(pRExC_state, ender, s);
8937                               if (unilen > 0) {
8938                                    s   += unilen;
8939                                    len += unilen;
8940                               }
8941                          }
8942                     }
8943                     else {
8944                         len++;
8945                         REGC((char)ender, s++);
8946                     }
8947                     break;
8948                 }
8949                 if (UTF) {
8950                      if (FOLD) {
8951                           /* Emit all the Unicode characters. */
8952                           STRLEN numlen;
8953                           for (foldbuf = tmpbuf;
8954                                foldlen;
8955                                foldlen -= numlen) {
8956                                ender = utf8_to_uvchr(foldbuf, &numlen);
8957                                if (numlen > 0) {
8958                                     const STRLEN unilen = reguni(pRExC_state, ender, s);
8959                                     len     += unilen;
8960                                     s       += unilen;
8961                                     /* In EBCDIC the numlen
8962                                      * and unilen can differ. */
8963                                     foldbuf += numlen;
8964                                     if (numlen >= foldlen)
8965                                          break;
8966                                }
8967                                else
8968                                     break;
8969                           }
8970                      }
8971                      else {
8972                           const STRLEN unilen = reguni(pRExC_state, ender, s);
8973                           if (unilen > 0) {
8974                                s   += unilen;
8975                                len += unilen;
8976                           }
8977                      }
8978                      len--;
8979                 }
8980                 else {
8981                     REGC((char)ender, s++);
8982                 }
8983             }
8984         loopdone:   /* Jumped to when encounters something that shouldn't be in
8985                        the node */
8986             RExC_parse = p - 1;
8987             Set_Node_Cur_Length(ret); /* MJD */
8988             nextchar(pRExC_state);
8989             {
8990                 /* len is STRLEN which is unsigned, need to copy to signed */
8991                 IV iv = len;
8992                 if (iv < 0)
8993                     vFAIL("Internal disaster");
8994             }
8995             if (len > 0)
8996                 *flagp |= HASWIDTH;
8997             if (len == 1 && UNI_IS_INVARIANT(ender))
8998                 *flagp |= SIMPLE;
8999                 
9000             if (SIZE_ONLY)
9001                 RExC_size += STR_SZ(len);
9002             else {
9003                 STR_LEN(ret) = len;
9004                 RExC_emit += STR_SZ(len);
9005             }
9006         }
9007         break;
9008     }
9009
9010     return(ret);
9011
9012 /* Jumped to when an unrecognized character set is encountered */
9013 bad_charset:
9014     Perl_croak(aTHX_ "panic: Unknown regex character set encoding: %u", get_regex_charset(RExC_flags));
9015     return(NULL);
9016 }
9017
9018 STATIC char *
9019 S_regwhite( RExC_state_t *pRExC_state, char *p )
9020 {
9021     const char *e = RExC_end;
9022
9023     PERL_ARGS_ASSERT_REGWHITE;
9024
9025     while (p < e) {
9026         if (isSPACE(*p))
9027             ++p;
9028         else if (*p == '#') {
9029             bool ended = 0;
9030             do {
9031                 if (*p++ == '\n') {
9032                     ended = 1;
9033                     break;
9034                 }
9035             } while (p < e);
9036             if (!ended)
9037                 RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
9038         }
9039         else
9040             break;
9041     }
9042     return p;
9043 }
9044
9045 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
9046    Character classes ([:foo:]) can also be negated ([:^foo:]).
9047    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
9048    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
9049    but trigger failures because they are currently unimplemented. */
9050
9051 #define POSIXCC_DONE(c)   ((c) == ':')
9052 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
9053 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
9054
9055 STATIC I32
9056 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
9057 {
9058     dVAR;
9059     I32 namedclass = OOB_NAMEDCLASS;
9060
9061     PERL_ARGS_ASSERT_REGPPOSIXCC;
9062
9063     if (value == '[' && RExC_parse + 1 < RExC_end &&
9064         /* I smell either [: or [= or [. -- POSIX has been here, right? */
9065         POSIXCC(UCHARAT(RExC_parse))) {
9066         const char c = UCHARAT(RExC_parse);
9067         char* const s = RExC_parse++;
9068         
9069         while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
9070             RExC_parse++;
9071         if (RExC_parse == RExC_end)
9072             /* Grandfather lone [:, [=, [. */
9073             RExC_parse = s;
9074         else {
9075             const char* const t = RExC_parse++; /* skip over the c */
9076             assert(*t == c);
9077
9078             if (UCHARAT(RExC_parse) == ']') {
9079                 const char *posixcc = s + 1;
9080                 RExC_parse++; /* skip over the ending ] */
9081
9082                 if (*s == ':') {
9083                     const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
9084                     const I32 skip = t - posixcc;
9085
9086                     /* Initially switch on the length of the name.  */
9087                     switch (skip) {
9088                     case 4:
9089                         if (memEQ(posixcc, "word", 4)) /* this is not POSIX, this is the Perl \w */
9090                             namedclass = complement ? ANYOF_NALNUM : ANYOF_ALNUM;
9091                         break;
9092                     case 5:
9093                         /* Names all of length 5.  */
9094                         /* alnum alpha ascii blank cntrl digit graph lower
9095                            print punct space upper  */
9096                         /* Offset 4 gives the best switch position.  */
9097                         switch (posixcc[4]) {
9098                         case 'a':
9099                             if (memEQ(posixcc, "alph", 4)) /* alpha */
9100                                 namedclass = complement ? ANYOF_NALPHA : ANYOF_ALPHA;
9101                             break;
9102                         case 'e':
9103                             if (memEQ(posixcc, "spac", 4)) /* space */
9104                                 namedclass = complement ? ANYOF_NPSXSPC : ANYOF_PSXSPC;
9105                             break;
9106                         case 'h':
9107                             if (memEQ(posixcc, "grap", 4)) /* graph */
9108                                 namedclass = complement ? ANYOF_NGRAPH : ANYOF_GRAPH;
9109                             break;
9110                         case 'i':
9111                             if (memEQ(posixcc, "asci", 4)) /* ascii */
9112                                 namedclass = complement ? ANYOF_NASCII : ANYOF_ASCII;
9113                             break;
9114                         case 'k':
9115                             if (memEQ(posixcc, "blan", 4)) /* blank */
9116                                 namedclass = complement ? ANYOF_NBLANK : ANYOF_BLANK;
9117                             break;
9118                         case 'l':
9119                             if (memEQ(posixcc, "cntr", 4)) /* cntrl */
9120                                 namedclass = complement ? ANYOF_NCNTRL : ANYOF_CNTRL;
9121                             break;
9122                         case 'm':
9123                             if (memEQ(posixcc, "alnu", 4)) /* alnum */
9124                                 namedclass = complement ? ANYOF_NALNUMC : ANYOF_ALNUMC;
9125                             break;
9126                         case 'r':
9127                             if (memEQ(posixcc, "lowe", 4)) /* lower */
9128                                 namedclass = complement ? ANYOF_NLOWER : ANYOF_LOWER;
9129                             else if (memEQ(posixcc, "uppe", 4)) /* upper */
9130                                 namedclass = complement ? ANYOF_NUPPER : ANYOF_UPPER;
9131                             break;
9132                         case 't':
9133                             if (memEQ(posixcc, "digi", 4)) /* digit */
9134                                 namedclass = complement ? ANYOF_NDIGIT : ANYOF_DIGIT;
9135                             else if (memEQ(posixcc, "prin", 4)) /* print */
9136                                 namedclass = complement ? ANYOF_NPRINT : ANYOF_PRINT;
9137                             else if (memEQ(posixcc, "punc", 4)) /* punct */
9138                                 namedclass = complement ? ANYOF_NPUNCT : ANYOF_PUNCT;
9139                             break;
9140                         }
9141                         break;
9142                     case 6:
9143                         if (memEQ(posixcc, "xdigit", 6))
9144                             namedclass = complement ? ANYOF_NXDIGIT : ANYOF_XDIGIT;
9145                         break;
9146                     }
9147
9148                     if (namedclass == OOB_NAMEDCLASS)
9149                         Simple_vFAIL3("POSIX class [:%.*s:] unknown",
9150                                       t - s - 1, s + 1);
9151                     assert (posixcc[skip] == ':');
9152                     assert (posixcc[skip+1] == ']');
9153                 } else if (!SIZE_ONLY) {
9154                     /* [[=foo=]] and [[.foo.]] are still future. */
9155
9156                     /* adjust RExC_parse so the warning shows after
9157                        the class closes */
9158                     while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
9159                         RExC_parse++;
9160                     Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
9161                 }
9162             } else {
9163                 /* Maternal grandfather:
9164                  * "[:" ending in ":" but not in ":]" */
9165                 RExC_parse = s;
9166             }
9167         }
9168     }
9169
9170     return namedclass;
9171 }
9172
9173 STATIC void
9174 S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
9175 {
9176     dVAR;
9177
9178     PERL_ARGS_ASSERT_CHECKPOSIXCC;
9179
9180     if (POSIXCC(UCHARAT(RExC_parse))) {
9181         const char *s = RExC_parse;
9182         const char  c = *s++;
9183
9184         while (isALNUM(*s))
9185             s++;
9186         if (*s && c == *s && s[1] == ']') {
9187             ckWARN3reg(s+2,
9188                        "POSIX syntax [%c %c] belongs inside character classes",
9189                        c, c);
9190
9191             /* [[=foo=]] and [[.foo.]] are still future. */
9192             if (POSIXCC_NOTYET(c)) {
9193                 /* adjust RExC_parse so the error shows after
9194                    the class closes */
9195                 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
9196                     NOOP;
9197                 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
9198             }
9199         }
9200     }
9201 }
9202
9203 /* No locale test, and always Unicode semantics */
9204 #define _C_C_T_NOLOC_(NAME,TEST,WORD)                                          \
9205 ANYOF_##NAME:                                                                  \
9206         for (value = 0; value < 256; value++)                                  \
9207             if (TEST)                                                          \
9208             stored += set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);  \
9209     yesno = '+';                                                               \
9210     what = WORD;                                                               \
9211     break;                                                                     \
9212 case ANYOF_N##NAME:                                                            \
9213         for (value = 0; value < 256; value++)                                  \
9214             if (!TEST)                                                         \
9215             stored += set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);  \
9216     yesno = '!';                                                               \
9217     what = WORD;                                                               \
9218     break
9219
9220 /* Like the above, but there are differences if we are in uni-8-bit or not, so
9221  * there are two tests passed in, to use depending on that. There aren't any
9222  * cases where the label is different from the name, so no need for that
9223  * parameter */
9224 #define _C_C_T_(NAME, TEST_8, TEST_7, WORD)                                    \
9225 ANYOF_##NAME:                                                                  \
9226     if (LOC) ANYOF_CLASS_SET(ret, ANYOF_##NAME);                               \
9227     else if (UNI_SEMANTICS) {                                                  \
9228         for (value = 0; value < 256; value++) {                                \
9229             if (TEST_8(value)) stored +=                                       \
9230                       set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);  \
9231         }                                                                      \
9232     }                                                                          \
9233     else {                                                                     \
9234         for (value = 0; value < 128; value++) {                                \
9235             if (TEST_7(UNI_TO_NATIVE(value))) stored +=                        \
9236                 set_regclass_bit(pRExC_state, ret,                     \
9237                                    (U8) UNI_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate);                 \
9238         }                                                                      \
9239     }                                                                          \
9240     yesno = '+';                                                               \
9241     what = WORD;                                                               \
9242     break;                                                                     \
9243 case ANYOF_N##NAME:                                                            \
9244     if (LOC) ANYOF_CLASS_SET(ret, ANYOF_N##NAME);                              \
9245     else if (UNI_SEMANTICS) {                                                  \
9246         for (value = 0; value < 256; value++) {                                \
9247             if (! TEST_8(value)) stored +=                                     \
9248                     set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);    \
9249         }                                                                      \
9250     }                                                                          \
9251     else {                                                                     \
9252         for (value = 0; value < 128; value++) {                                \
9253             if (! TEST_7(UNI_TO_NATIVE(value))) stored += set_regclass_bit(  \
9254                         pRExC_state, ret, (U8) UNI_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate);    \
9255         }                                                                      \
9256         if (AT_LEAST_ASCII_RESTRICTED) {                                       \
9257             for (value = 128; value < 256; value++) {                          \
9258              stored += set_regclass_bit(                                     \
9259                            pRExC_state, ret, (U8) UNI_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate); \
9260             }                                                                  \
9261             ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;                             \
9262         }                                                                      \
9263         else {                                                                 \
9264             /* For a non-ut8 target string with DEPENDS semantics, all above   \
9265              * ASCII Latin1 code points match the complement of any of the     \
9266              * classes.  But in utf8, they have their Unicode semantics, so    \
9267              * can't just set them in the bitmap, or else regexec.c will think \
9268              * they matched when they shouldn't. */                            \
9269             ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_LATIN1_ALL;                     \
9270         }                                                                      \
9271     }                                                                          \
9272     yesno = '!';                                                               \
9273     what = WORD;                                                               \
9274     break
9275
9276 STATIC U8
9277 S_set_regclass_bit_fold(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, HV** invlist_ptr, AV** alternate_ptr)
9278 {
9279
9280     /* Handle the setting of folds in the bitmap for non-locale ANYOF nodes.
9281      * Locale folding is done at run-time, so this function should not be
9282      * called for nodes that are for locales.
9283      *
9284      * This function sets the bit corresponding to the fold of the input
9285      * 'value', if not already set.  The fold of 'f' is 'F', and the fold of
9286      * 'F' is 'f'.
9287      *
9288      * It also knows about the characters that are in the bitmap that have
9289      * folds that are matchable only outside it, and sets the appropriate lists
9290      * and flags.
9291      *
9292      * It returns the number of bits that actually changed from 0 to 1 */
9293
9294     U8 stored = 0;
9295     U8 fold;
9296
9297     PERL_ARGS_ASSERT_SET_REGCLASS_BIT_FOLD;
9298
9299     fold = (AT_LEAST_UNI_SEMANTICS) ? PL_fold_latin1[value]
9300                                     : PL_fold[value];
9301
9302     /* It assumes the bit for 'value' has already been set */
9303     if (fold != value && ! ANYOF_BITMAP_TEST(node, fold)) {
9304         ANYOF_BITMAP_SET(node, fold);
9305         stored++;
9306     }
9307     if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(value) && (! isASCII(value) || ! MORE_ASCII_RESTRICTED)) {
9308         /* Certain Latin1 characters have matches outside the bitmap.  To get
9309          * here, 'value' is one of those characters.   None of these matches is
9310          * valid for ASCII characters under /aa, which have been excluded by
9311          * the 'if' above.  The matches fall into three categories:
9312          * 1) They are singly folded-to or -from an above 255 character, as
9313          *    LATIN SMALL LETTER Y WITH DIAERESIS and LATIN CAPITAL LETTER Y
9314          *    WITH DIAERESIS;
9315          * 2) They are part of a multi-char fold with another character in the
9316          *    bitmap, only LATIN SMALL LETTER SHARP S => "ss" fits that bill;
9317          * 3) They are part of a multi-char fold with a character not in the
9318          *    bitmap, such as various ligatures.
9319          * We aren't dealing fully with multi-char folds, except we do deal
9320          * with the pattern containing a character that has a multi-char fold
9321          * (not so much the inverse).
9322          * For types 1) and 3), the matches only happen when the target string
9323          * is utf8; that's not true for 2), and we set a flag for it.
9324          *
9325          * The code below adds to the passed in inversion list the single fold
9326          * closures for 'value'.  The values are hard-coded here so that an
9327          * innocent-looking character class, like /[ks]/i won't have to go out
9328          * to disk to find the possible matches.  XXX It would be better to
9329          * generate these via regen, in case a new version of the Unicode
9330          * standard adds new mappings, though that is not really likely. */
9331         switch (value) {
9332             case 'k':
9333             case 'K':
9334                 /* KELVIN SIGN */
9335                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x212A);
9336                 break;
9337             case 's':
9338             case 'S':
9339                 /* LATIN SMALL LETTER LONG S */
9340                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x017F);
9341                 break;
9342             case MICRO_SIGN:
9343                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
9344                                                  GREEK_SMALL_LETTER_MU);
9345                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
9346                                                  GREEK_CAPITAL_LETTER_MU);
9347                 break;
9348             case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
9349             case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
9350                 /* ANGSTROM SIGN */
9351                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x212B);
9352                 if (DEPENDS_SEMANTICS) {    /* See DEPENDS comment below */
9353                     *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
9354                                                      PL_fold_latin1[value]);
9355                 }
9356                 break;
9357             case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
9358                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
9359                                         LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
9360                 break;
9361             case LATIN_SMALL_LETTER_SHARP_S:
9362                 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
9363                                         LATIN_CAPITAL_LETTER_SHARP_S);
9364
9365                 /* Under /a, /d, and /u, this can match the two chars "ss" */
9366                 if (! MORE_ASCII_RESTRICTED) {
9367                     add_alternate(alternate_ptr, (U8 *) "ss", 2);
9368
9369                     /* And under /u or /a, it can match even if the target is
9370                      * not utf8 */
9371                     if (AT_LEAST_UNI_SEMANTICS) {
9372                         ANYOF_FLAGS(node) |= ANYOF_NONBITMAP_NON_UTF8;
9373                     }
9374                 }
9375                 break;
9376             case 'F': case 'f':
9377             case 'I': case 'i':
9378             case 'L': case 'l':
9379             case 'T': case 't':
9380             case 'A': case 'a':
9381             case 'H': case 'h':
9382             case 'J': case 'j':
9383             case 'N': case 'n':
9384             case 'W': case 'w':
9385             case 'Y': case 'y':
9386                 /* These all are targets of multi-character folds from code
9387                  * points that require UTF8 to express, so they can't match
9388                  * unless the target string is in UTF-8, so no action here is
9389                  * necessary, as regexec.c properly handles the general case
9390                  * for UTF-8 matching */
9391                 break;
9392             default:
9393                 /* Use deprecated warning to increase the chances of this
9394                  * being output */
9395                 ckWARN2regdep(RExC_parse, "Perl folding rules are not up-to-date for 0x%x; please use the perlbug utility to report;", value);
9396                 break;
9397         }
9398     }
9399     else if (DEPENDS_SEMANTICS
9400             && ! isASCII(value)
9401             && PL_fold_latin1[value] != value)
9402     {
9403            /* Under DEPENDS rules, non-ASCII Latin1 characters match their
9404             * folds only when the target string is in UTF-8.  We add the fold
9405             * here to the list of things to match outside the bitmap, which
9406             * won't be looked at unless it is UTF8 (or else if something else
9407             * says to look even if not utf8, but those things better not happen
9408             * under DEPENDS semantics. */
9409         *invlist_ptr = add_cp_to_invlist(*invlist_ptr, PL_fold_latin1[value]);
9410     }
9411
9412     return stored;
9413 }
9414
9415
9416 PERL_STATIC_INLINE U8
9417 S_set_regclass_bit(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, HV** invlist_ptr, AV** alternate_ptr)
9418 {
9419     /* This inline function sets a bit in the bitmap if not already set, and if
9420      * appropriate, its fold, returning the number of bits that actually
9421      * changed from 0 to 1 */
9422
9423     U8 stored;
9424
9425     PERL_ARGS_ASSERT_SET_REGCLASS_BIT;
9426
9427     if (ANYOF_BITMAP_TEST(node, value)) {   /* Already set */
9428         return 0;
9429     }
9430
9431     ANYOF_BITMAP_SET(node, value);
9432     stored = 1;
9433
9434     if (FOLD && ! LOC) {        /* Locale folds aren't known until runtime */
9435         stored += set_regclass_bit_fold(pRExC_state, node, value, invlist_ptr, alternate_ptr);
9436     }
9437
9438     return stored;
9439 }
9440
9441 STATIC void
9442 S_add_alternate(pTHX_ AV** alternate_ptr, U8* string, STRLEN len)
9443 {
9444     /* Adds input 'string' with length 'len' to the ANYOF node's unicode
9445      * alternate list, pointed to by 'alternate_ptr'.  This is an array of
9446      * the multi-character folds of characters in the node */
9447     SV *sv;
9448
9449     PERL_ARGS_ASSERT_ADD_ALTERNATE;
9450
9451     if (! *alternate_ptr) {
9452         *alternate_ptr = newAV();
9453     }
9454     sv = newSVpvn_utf8((char*)string, len, TRUE);
9455     av_push(*alternate_ptr, sv);
9456     return;
9457 }
9458
9459 /*
9460    parse a class specification and produce either an ANYOF node that
9461    matches the pattern or perhaps will be optimized into an EXACTish node
9462    instead. The node contains a bit map for the first 256 characters, with the
9463    corresponding bit set if that character is in the list.  For characters
9464    above 255, a range list is used */
9465
9466 STATIC regnode *
9467 S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth)
9468 {
9469     dVAR;
9470     register UV nextvalue;
9471     register IV prevvalue = OOB_UNICODE;
9472     register IV range = 0;
9473     UV value = 0; /* XXX:dmq: needs to be referenceable (unfortunately) */
9474     register regnode *ret;
9475     STRLEN numlen;
9476     IV namedclass;
9477     char *rangebegin = NULL;
9478     bool need_class = 0;
9479     bool allow_full_fold = TRUE;   /* Assume wants multi-char folding */
9480     SV *listsv = NULL;
9481     STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
9482                                       than just initialized.  */
9483     UV n;
9484
9485     /* code points this node matches that can't be stored in the bitmap */
9486     HV* nonbitmap = NULL;
9487
9488     /* The items that are to match that aren't stored in the bitmap, but are a
9489      * result of things that are stored there.  This is the fold closure of
9490      * such a character, either because it has DEPENDS semantics and shouldn't
9491      * be matched unless the target string is utf8, or is a code point that is
9492      * too large for the bit map, as for example, the fold of the MICRO SIGN is
9493      * above 255.  This all is solely for performance reasons.  By having this
9494      * code know the outside-the-bitmap folds that the bitmapped characters are
9495      * involved with, we don't have to go out to disk to find the list of
9496      * matches, unless the character class includes code points that aren't
9497      * storable in the bit map.  That means that a character class with an 's'
9498      * in it, for example, doesn't need to go out to disk to find everything
9499      * that matches.  A 2nd list is used so that the 'nonbitmap' list is kept
9500      * empty unless there is something whose fold we don't know about, and will
9501      * have to go out to the disk to find. */
9502     HV* l1_fold_invlist = NULL;
9503
9504     /* List of multi-character folds that are matched by this node */
9505     AV* unicode_alternate  = NULL;
9506 #ifdef EBCDIC
9507     UV literal_endpoint = 0;
9508 #endif
9509     UV stored = 0;  /* how many chars stored in the bitmap */
9510
9511     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
9512         case we need to change the emitted regop to an EXACT. */
9513     const char * orig_parse = RExC_parse;
9514     GET_RE_DEBUG_FLAGS_DECL;
9515
9516     PERL_ARGS_ASSERT_REGCLASS;
9517 #ifndef DEBUGGING
9518     PERL_UNUSED_ARG(depth);
9519 #endif
9520
9521     DEBUG_PARSE("clas");
9522
9523     /* Assume we are going to generate an ANYOF node. */
9524     ret = reganode(pRExC_state, ANYOF, 0);
9525
9526
9527     if (!SIZE_ONLY) {
9528         ANYOF_FLAGS(ret) = 0;
9529     }
9530
9531     if (UCHARAT(RExC_parse) == '^') {   /* Complement of range. */
9532         RExC_naughty++;
9533         RExC_parse++;
9534         if (!SIZE_ONLY)
9535             ANYOF_FLAGS(ret) |= ANYOF_INVERT;
9536
9537         /* We have decided to not allow multi-char folds in inverted character
9538          * classes, due to the confusion that can happen, even with classes
9539          * that are designed for a non-Unicode world:  You have the peculiar
9540          * case that:
9541             "s s" =~ /^[^\xDF]+$/i => Y
9542             "ss"  =~ /^[^\xDF]+$/i => N
9543          *
9544          * See [perl #89750] */
9545         allow_full_fold = FALSE;
9546     }
9547
9548     if (SIZE_ONLY) {
9549         RExC_size += ANYOF_SKIP;
9550         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
9551     }
9552     else {
9553         RExC_emit += ANYOF_SKIP;
9554         if (LOC) {
9555             ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
9556         }
9557         ANYOF_BITMAP_ZERO(ret);
9558         listsv = newSVpvs("# comment\n");
9559         initial_listsv_len = SvCUR(listsv);
9560     }
9561
9562     nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
9563
9564     if (!SIZE_ONLY && POSIXCC(nextvalue))
9565         checkposixcc(pRExC_state);
9566
9567     /* allow 1st char to be ] (allowing it to be - is dealt with later) */
9568     if (UCHARAT(RExC_parse) == ']')
9569         goto charclassloop;
9570
9571 parseit:
9572     while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
9573
9574     charclassloop:
9575
9576         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
9577
9578         if (!range)
9579             rangebegin = RExC_parse;
9580         if (UTF) {
9581             value = utf8n_to_uvchr((U8*)RExC_parse,
9582                                    RExC_end - RExC_parse,
9583                                    &numlen, UTF8_ALLOW_DEFAULT);
9584             RExC_parse += numlen;
9585         }
9586         else
9587             value = UCHARAT(RExC_parse++);
9588
9589         nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
9590         if (value == '[' && POSIXCC(nextvalue))
9591             namedclass = regpposixcc(pRExC_state, value);
9592         else if (value == '\\') {
9593             if (UTF) {
9594                 value = utf8n_to_uvchr((U8*)RExC_parse,
9595                                    RExC_end - RExC_parse,
9596                                    &numlen, UTF8_ALLOW_DEFAULT);
9597                 RExC_parse += numlen;
9598             }
9599             else
9600                 value = UCHARAT(RExC_parse++);
9601             /* Some compilers cannot handle switching on 64-bit integer
9602              * values, therefore value cannot be an UV.  Yes, this will
9603              * be a problem later if we want switch on Unicode.
9604              * A similar issue a little bit later when switching on
9605              * namedclass. --jhi */
9606             switch ((I32)value) {
9607             case 'w':   namedclass = ANYOF_ALNUM;       break;
9608             case 'W':   namedclass = ANYOF_NALNUM;      break;
9609             case 's':   namedclass = ANYOF_SPACE;       break;
9610             case 'S':   namedclass = ANYOF_NSPACE;      break;
9611             case 'd':   namedclass = ANYOF_DIGIT;       break;
9612             case 'D':   namedclass = ANYOF_NDIGIT;      break;
9613             case 'v':   namedclass = ANYOF_VERTWS;      break;
9614             case 'V':   namedclass = ANYOF_NVERTWS;     break;
9615             case 'h':   namedclass = ANYOF_HORIZWS;     break;
9616             case 'H':   namedclass = ANYOF_NHORIZWS;    break;
9617             case 'N':  /* Handle \N{NAME} in class */
9618                 {
9619                     /* We only pay attention to the first char of 
9620                     multichar strings being returned. I kinda wonder
9621                     if this makes sense as it does change the behaviour
9622                     from earlier versions, OTOH that behaviour was broken
9623                     as well. */
9624                     UV v; /* value is register so we cant & it /grrr */
9625                     if (reg_namedseq(pRExC_state, &v, NULL, depth)) {
9626                         goto parseit;
9627                     }
9628                     value= v; 
9629                 }
9630                 break;
9631             case 'p':
9632             case 'P':
9633                 {
9634                 char *e;
9635                 if (RExC_parse >= RExC_end)
9636                     vFAIL2("Empty \\%c{}", (U8)value);
9637                 if (*RExC_parse == '{') {
9638                     const U8 c = (U8)value;
9639                     e = strchr(RExC_parse++, '}');
9640                     if (!e)
9641                         vFAIL2("Missing right brace on \\%c{}", c);
9642                     while (isSPACE(UCHARAT(RExC_parse)))
9643                         RExC_parse++;
9644                     if (e == RExC_parse)
9645                         vFAIL2("Empty \\%c{}", c);
9646                     n = e - RExC_parse;
9647                     while (isSPACE(UCHARAT(RExC_parse + n - 1)))
9648                         n--;
9649                 }
9650                 else {
9651                     e = RExC_parse;
9652                     n = 1;
9653                 }
9654                 if (!SIZE_ONLY) {
9655                     if (UCHARAT(RExC_parse) == '^') {
9656                          RExC_parse++;
9657                          n--;
9658                          value = value == 'p' ? 'P' : 'p'; /* toggle */
9659                          while (isSPACE(UCHARAT(RExC_parse))) {
9660                               RExC_parse++;
9661                               n--;
9662                          }
9663                     }
9664
9665                     /* Add the property name to the list.  If /i matching, give
9666                      * a different name which consists of the normal name
9667                      * sandwiched between two underscores and '_i'.  The design
9668                      * is discussed in the commit message for this. */
9669                     Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s%.*s%s\n",
9670                                         (value=='p' ? '+' : '!'),
9671                                         (FOLD) ? "__" : "",
9672                                         (int)n,
9673                                         RExC_parse,
9674                                         (FOLD) ? "_i" : ""
9675                                     );
9676                 }
9677                 RExC_parse = e + 1;
9678
9679                 /* The \p could match something in the Latin1 range, hence
9680                  * something that isn't utf8 */
9681                 ANYOF_FLAGS(ret) |= ANYOF_NONBITMAP_NON_UTF8;
9682                 namedclass = ANYOF_MAX;  /* no official name, but it's named */
9683
9684                 /* \p means they want Unicode semantics */
9685                 RExC_uni_semantics = 1;
9686                 }
9687                 break;
9688             case 'n':   value = '\n';                   break;
9689             case 'r':   value = '\r';                   break;
9690             case 't':   value = '\t';                   break;
9691             case 'f':   value = '\f';                   break;
9692             case 'b':   value = '\b';                   break;
9693             case 'e':   value = ASCII_TO_NATIVE('\033');break;
9694             case 'a':   value = ASCII_TO_NATIVE('\007');break;
9695             case 'o':
9696                 RExC_parse--;   /* function expects to be pointed at the 'o' */
9697                 {
9698                     const char* error_msg;
9699                     bool valid = grok_bslash_o(RExC_parse,
9700                                                &value,
9701                                                &numlen,
9702                                                &error_msg,
9703                                                SIZE_ONLY);
9704                     RExC_parse += numlen;
9705                     if (! valid) {
9706                         vFAIL(error_msg);
9707                     }
9708                 }
9709                 if (PL_encoding && value < 0x100) {
9710                     goto recode_encoding;
9711                 }
9712                 break;
9713             case 'x':
9714                 if (*RExC_parse == '{') {
9715                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
9716                         | PERL_SCAN_DISALLOW_PREFIX;
9717                     char * const e = strchr(RExC_parse++, '}');
9718                     if (!e)
9719                         vFAIL("Missing right brace on \\x{}");
9720
9721                     numlen = e - RExC_parse;
9722                     value = grok_hex(RExC_parse, &numlen, &flags, NULL);
9723                     RExC_parse = e + 1;
9724                 }
9725                 else {
9726                     I32 flags = PERL_SCAN_DISALLOW_PREFIX;
9727                     numlen = 2;
9728                     value = grok_hex(RExC_parse, &numlen, &flags, NULL);
9729                     RExC_parse += numlen;
9730                 }
9731                 if (PL_encoding && value < 0x100)
9732                     goto recode_encoding;
9733                 break;
9734             case 'c':
9735                 value = grok_bslash_c(*RExC_parse++, UTF, SIZE_ONLY);
9736                 break;
9737             case '0': case '1': case '2': case '3': case '4':
9738             case '5': case '6': case '7':
9739                 {
9740                     /* Take 1-3 octal digits */
9741                     I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
9742                     numlen = 3;
9743                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
9744                     RExC_parse += numlen;
9745                     if (PL_encoding && value < 0x100)
9746                         goto recode_encoding;
9747                     break;
9748                 }
9749             recode_encoding:
9750                 if (! RExC_override_recoding) {
9751                     SV* enc = PL_encoding;
9752                     value = reg_recode((const char)(U8)value, &enc);
9753                     if (!enc && SIZE_ONLY)
9754                         ckWARNreg(RExC_parse,
9755                                   "Invalid escape in the specified encoding");
9756                     break;
9757                 }
9758             default:
9759                 /* Allow \_ to not give an error */
9760                 if (!SIZE_ONLY && isALNUM(value) && value != '_') {
9761                     ckWARN2reg(RExC_parse,
9762                                "Unrecognized escape \\%c in character class passed through",
9763                                (int)value);
9764                 }
9765                 break;
9766             }
9767         } /* end of \blah */
9768 #ifdef EBCDIC
9769         else
9770             literal_endpoint++;
9771 #endif
9772
9773         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
9774
9775             /* What matches in a locale is not known until runtime, so need to
9776              * (one time per class) allocate extra space to pass to regexec.
9777              * The space will contain a bit for each named class that is to be
9778              * matched against.  This isn't needed for \p{} and pseudo-classes,
9779              * as they are not affected by locale, and hence are dealt with
9780              * separately */
9781             if (LOC && namedclass < ANYOF_MAX && ! need_class) {
9782                 need_class = 1;
9783                 if (SIZE_ONLY) {
9784                     RExC_size += ANYOF_CLASS_SKIP - ANYOF_SKIP;
9785                 }
9786                 else {
9787                     RExC_emit += ANYOF_CLASS_SKIP - ANYOF_SKIP;
9788                     ANYOF_CLASS_ZERO(ret);
9789                 }
9790                 ANYOF_FLAGS(ret) |= ANYOF_CLASS;
9791             }
9792
9793             /* a bad range like a-\d, a-[:digit:].  The '-' is taken as a
9794              * literal, as is the character that began the false range, i.e.
9795              * the 'a' in the examples */
9796             if (range) {
9797                 if (!SIZE_ONLY) {
9798                     const int w =
9799                         RExC_parse >= rangebegin ?
9800                         RExC_parse - rangebegin : 0;
9801                     ckWARN4reg(RExC_parse,
9802                                "False [] range \"%*.*s\"",
9803                                w, w, rangebegin);
9804
9805                     stored +=
9806                          set_regclass_bit(pRExC_state, ret, '-', &l1_fold_invlist, &unicode_alternate);
9807                     if (prevvalue < 256) {
9808                         stored +=
9809                          set_regclass_bit(pRExC_state, ret, (U8) prevvalue, &l1_fold_invlist, &unicode_alternate);
9810                     }
9811                     else {
9812                         nonbitmap = add_cp_to_invlist(nonbitmap, prevvalue);
9813                     }
9814                 }
9815
9816                 range = 0; /* this was not a true range */
9817             }
9818
9819
9820     
9821             if (!SIZE_ONLY) {
9822                 const char *what = NULL;
9823                 char yesno = 0;
9824
9825                 /* Possible truncation here but in some 64-bit environments
9826                  * the compiler gets heartburn about switch on 64-bit values.
9827                  * A similar issue a little earlier when switching on value.
9828                  * --jhi */
9829                 switch ((I32)namedclass) {
9830                 
9831                 case _C_C_T_(ALNUMC, isALNUMC_L1, isALNUMC, "XPosixAlnum");
9832                 case _C_C_T_(ALPHA, isALPHA_L1, isALPHA, "XPosixAlpha");
9833                 case _C_C_T_(BLANK, isBLANK_L1, isBLANK, "XPosixBlank");
9834                 case _C_C_T_(CNTRL, isCNTRL_L1, isCNTRL, "XPosixCntrl");
9835                 case _C_C_T_(GRAPH, isGRAPH_L1, isGRAPH, "XPosixGraph");
9836                 case _C_C_T_(LOWER, isLOWER_L1, isLOWER, "XPosixLower");
9837                 case _C_C_T_(PRINT, isPRINT_L1, isPRINT, "XPosixPrint");
9838                 case _C_C_T_(PSXSPC, isPSXSPC_L1, isPSXSPC, "XPosixSpace");
9839                 case _C_C_T_(PUNCT, isPUNCT_L1, isPUNCT, "XPosixPunct");
9840                 case _C_C_T_(UPPER, isUPPER_L1, isUPPER, "XPosixUpper");
9841                 /* \s, \w match all unicode if utf8. */
9842                 case _C_C_T_(SPACE, isSPACE_L1, isSPACE, "SpacePerl");
9843                 case _C_C_T_(ALNUM, isWORDCHAR_L1, isALNUM, "Word");
9844                 case _C_C_T_(XDIGIT, isXDIGIT_L1, isXDIGIT, "XPosixXDigit");
9845                 case _C_C_T_NOLOC_(VERTWS, is_VERTWS_latin1(&value), "VertSpace");
9846                 case _C_C_T_NOLOC_(HORIZWS, is_HORIZWS_latin1(&value), "HorizSpace");
9847                 case ANYOF_ASCII:
9848                     if (LOC)
9849                         ANYOF_CLASS_SET(ret, ANYOF_ASCII);
9850                     else {
9851                         for (value = 0; value < 128; value++)
9852                             stored +=
9853                               set_regclass_bit(pRExC_state, ret, (U8) ASCII_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate);
9854                     }
9855                     yesno = '+';
9856                     what = NULL;        /* Doesn't match outside ascii, so
9857                                            don't want to add +utf8:: */
9858                     break;
9859                 case ANYOF_NASCII:
9860                     if (LOC)
9861                         ANYOF_CLASS_SET(ret, ANYOF_NASCII);
9862                     else {
9863                         for (value = 128; value < 256; value++)
9864                             stored +=
9865                               set_regclass_bit(pRExC_state, ret, (U8) ASCII_TO_NATIVE(value), &l1_fold_invlist, &unicode_alternate);
9866                     }
9867                     ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
9868                     yesno = '!';
9869                     what = "ASCII";
9870                     break;              
9871                 case ANYOF_DIGIT:
9872                     if (LOC)
9873                         ANYOF_CLASS_SET(ret, ANYOF_DIGIT);
9874                     else {
9875                         /* consecutive digits assumed */
9876                         for (value = '0'; value <= '9'; value++)
9877                             stored +=
9878                               set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);
9879                     }
9880                     yesno = '+';
9881                     what = "Digit";
9882                     break;
9883                 case ANYOF_NDIGIT:
9884                     if (LOC)
9885                         ANYOF_CLASS_SET(ret, ANYOF_NDIGIT);
9886                     else {
9887                         /* consecutive digits assumed */
9888                         for (value = 0; value < '0'; value++)
9889                             stored +=
9890                               set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);
9891                         for (value = '9' + 1; value < 256; value++)
9892                             stored +=
9893                               set_regclass_bit(pRExC_state, ret, (U8) value, &l1_fold_invlist, &unicode_alternate);
9894                     }
9895                     yesno = '!';
9896                     what = "Digit";
9897                     if (AT_LEAST_ASCII_RESTRICTED ) {
9898                         ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
9899                     }
9900                     break;              
9901                 case ANYOF_MAX:
9902                     /* this is to handle \p and \P */
9903                     break;
9904                 default:
9905                     vFAIL("Invalid [::] class");
9906                     break;
9907                 }
9908                 if (what && ! (AT_LEAST_ASCII_RESTRICTED)) {
9909                     /* Strings such as "+utf8::isWord\n" */
9910                     Perl_sv_catpvf(aTHX_ listsv, "%cutf8::Is%s\n", yesno, what);
9911                 }
9912
9913                 continue;
9914             }
9915         } /* end of namedclass \blah */
9916
9917         if (range) {
9918             if (prevvalue > (IV)value) /* b-a */ {
9919                 const int w = RExC_parse - rangebegin;
9920                 Simple_vFAIL4("Invalid [] range \"%*.*s\"", w, w, rangebegin);
9921                 range = 0; /* not a valid range */
9922             }
9923         }
9924         else {
9925             prevvalue = value; /* save the beginning of the range */
9926             if (RExC_parse+1 < RExC_end
9927                 && *RExC_parse == '-'
9928                 && RExC_parse[1] != ']')
9929             {
9930                 RExC_parse++;
9931
9932                 /* a bad range like \w-, [:word:]- ? */
9933                 if (namedclass > OOB_NAMEDCLASS) {
9934                     if (ckWARN(WARN_REGEXP)) {
9935                         const int w =
9936                             RExC_parse >= rangebegin ?
9937                             RExC_parse - rangebegin : 0;
9938                         vWARN4(RExC_parse,
9939                                "False [] range \"%*.*s\"",
9940                                w, w, rangebegin);
9941                     }
9942                     if (!SIZE_ONLY)
9943                         stored +=
9944                             set_regclass_bit(pRExC_state, ret, '-', &l1_fold_invlist, &unicode_alternate);
9945                 } else
9946                     range = 1;  /* yeah, it's a range! */
9947                 continue;       /* but do it the next time */
9948             }
9949         }
9950
9951         /* non-Latin1 code point implies unicode semantics.  Must be set in
9952          * pass1 so is there for the whole of pass 2 */
9953         if (value > 255) {
9954             RExC_uni_semantics = 1;
9955         }
9956
9957         /* now is the next time */
9958         if (!SIZE_ONLY) {
9959             if (prevvalue < 256) {
9960                 const IV ceilvalue = value < 256 ? value : 255;
9961                 IV i;
9962 #ifdef EBCDIC
9963                 /* In EBCDIC [\x89-\x91] should include
9964                  * the \x8e but [i-j] should not. */
9965                 if (literal_endpoint == 2 &&
9966                     ((isLOWER(prevvalue) && isLOWER(ceilvalue)) ||
9967                      (isUPPER(prevvalue) && isUPPER(ceilvalue))))
9968                 {
9969                     if (isLOWER(prevvalue)) {
9970                         for (i = prevvalue; i <= ceilvalue; i++)
9971                             if (isLOWER(i) && !ANYOF_BITMAP_TEST(ret,i)) {
9972                                 stored +=
9973                                   set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
9974                             }
9975                     } else {
9976                         for (i = prevvalue; i <= ceilvalue; i++)
9977                             if (isUPPER(i) && !ANYOF_BITMAP_TEST(ret,i)) {
9978                                 stored +=
9979                                   set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
9980                             }
9981                     }
9982                 }
9983                 else
9984 #endif
9985                       for (i = prevvalue; i <= ceilvalue; i++) {
9986                         stored += set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
9987                       }
9988           }
9989           if (value > 255) {
9990             const UV prevnatvalue  = NATIVE_TO_UNI(prevvalue);
9991             const UV natvalue      = NATIVE_TO_UNI(value);
9992             nonbitmap = add_range_to_invlist(nonbitmap, prevnatvalue, natvalue);
9993         }
9994 #ifdef EBCDIC
9995             literal_endpoint = 0;
9996 #endif
9997         }
9998
9999         range = 0; /* this range (if it was one) is done now */
10000     }
10001
10002
10003
10004     if (SIZE_ONLY)
10005         return ret;
10006     /****** !SIZE_ONLY AFTER HERE *********/
10007
10008     /* If folding and there are code points above 255, we calculate all
10009      * characters that could fold to or from the ones already on the list */
10010     if (FOLD && nonbitmap) {
10011         UV i;
10012
10013         HV* fold_intersection;
10014         UV* fold_list;
10015
10016         /* This is a list of all the characters that participate in folds
10017             * (except marks, etc in multi-char folds */
10018         if (! PL_utf8_foldable) {
10019             SV* swash = swash_init("utf8", "Cased", &PL_sv_undef, 1, 0);
10020             PL_utf8_foldable = _swash_to_invlist(swash);
10021         }
10022
10023         /* This is a hash that for a particular fold gives all characters
10024             * that are involved in it */
10025         if (! PL_utf8_foldclosures) {
10026
10027             /* If we were unable to find any folds, then we likely won't be
10028              * able to find the closures.  So just create an empty list.
10029              * Folding will effectively be restricted to the non-Unicode rules
10030              * hard-coded into Perl.  (This case happens legitimately during
10031              * compilation of Perl itself before the Unicode tables are
10032              * generated) */
10033             if (invlist_len(PL_utf8_foldable) == 0) {
10034                 PL_utf8_foldclosures = _new_invlist(0);
10035             } else {
10036                 /* If the folds haven't been read in, call a fold function
10037                     * to force that */
10038                 if (! PL_utf8_tofold) {
10039                     U8 dummy[UTF8_MAXBYTES+1];
10040                     STRLEN dummy_len;
10041                     to_utf8_fold((U8*) "A", dummy, &dummy_len);
10042                 }
10043                 PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
10044             }
10045         }
10046
10047         /* Only the characters in this class that participate in folds need
10048             * be checked.  Get the intersection of this class and all the
10049             * possible characters that are foldable.  This can quickly narrow
10050             * down a large class */
10051         fold_intersection = invlist_intersection(PL_utf8_foldable, nonbitmap);
10052
10053         /* Now look at the foldable characters in this class individually */
10054         fold_list = invlist_array(fold_intersection);
10055         for (i = 0; i < invlist_len(fold_intersection); i++) {
10056             UV j;
10057
10058             /* The next entry is the beginning of the range that is in the
10059              * class */
10060             UV start = fold_list[i++];
10061
10062
10063             /* The next entry is the beginning of the next range, which
10064                 * isn't in the class, so the end of the current range is one
10065                 * less than that */
10066             UV end = fold_list[i] - 1;
10067
10068             /* Look at every character in the range */
10069             for (j = start; j <= end; j++) {
10070
10071                 /* Get its fold */
10072                 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
10073                 STRLEN foldlen;
10074                 const UV f =
10075                     _to_uni_fold_flags(j, foldbuf, &foldlen, allow_full_fold);
10076
10077                 if (foldlen > (STRLEN)UNISKIP(f)) {
10078
10079                     /* Any multicharacter foldings (disallowed in
10080                         * lookbehind patterns) require the following
10081                         * transform: [ABCDEF] -> (?:[ABCabcDEFd]|pq|rst) where
10082                         * E folds into "pq" and F folds into "rst", all other
10083                         * characters fold to single characters.  We save away
10084                         * these multicharacter foldings, to be later saved as
10085                         * part of the additional "s" data. */
10086                     if (! RExC_in_lookbehind) {
10087                         U8* loc = foldbuf;
10088                         U8* e = foldbuf + foldlen;
10089
10090                         /* If any of the folded characters of this are in
10091                             * the Latin1 range, tell the regex engine that
10092                             * this can match a non-utf8 target string.  The
10093                             * only multi-byte fold whose source is in the
10094                             * Latin1 range (U+00DF) applies only when the
10095                             * target string is utf8, or under unicode rules */
10096                         if (j > 255 || AT_LEAST_UNI_SEMANTICS) {
10097                             while (loc < e) {
10098
10099                                 /* Can't mix ascii with non- under /aa */
10100                                 if (MORE_ASCII_RESTRICTED
10101                                     && (isASCII(*loc) != isASCII(j)))
10102                                 {
10103                                     goto end_multi_fold;
10104                                 }
10105                                 if (UTF8_IS_INVARIANT(*loc)
10106                                     || UTF8_IS_DOWNGRADEABLE_START(*loc))
10107                                 {
10108                                     /* Can't mix above and below 256 under
10109                                         * LOC */
10110                                     if (LOC) {
10111                                         goto end_multi_fold;
10112                                     }
10113                                     ANYOF_FLAGS(ret)
10114                                             |= ANYOF_NONBITMAP_NON_UTF8;
10115                                     break;
10116                                 }
10117                                 loc += UTF8SKIP(loc);
10118                             }
10119                         }
10120
10121                         add_alternate(&unicode_alternate, foldbuf, foldlen);
10122                     end_multi_fold: ;
10123                     }
10124
10125                     /* This is special-cased, as it is the only letter which
10126                      * has both a multi-fold and single-fold in Latin1.  All
10127                      * the other chars that have single and multi-folds are
10128                      * always in utf8, and the utf8 folding algorithm catches
10129                      * them */
10130                     if (! LOC && j == LATIN_CAPITAL_LETTER_SHARP_S) {
10131                         stored += set_regclass_bit(pRExC_state,
10132                                         ret,
10133                                         LATIN_SMALL_LETTER_SHARP_S,
10134                                         &l1_fold_invlist, &unicode_alternate);
10135                     }
10136                 }
10137                 else {
10138                     /* Single character fold.  Add everything in its fold
10139                         * closure to the list that this node should match */
10140                     SV** listp;
10141
10142                     /* The fold closures data structure is a hash with the
10143                         * keys being every character that is folded to, like
10144                         * 'k', and the values each an array of everything that
10145                         * folds to its key.  e.g. [ 'k', 'K', KELVIN_SIGN ] */
10146                     if ((listp = hv_fetch(PL_utf8_foldclosures,
10147                                     (char *) foldbuf, foldlen, FALSE)))
10148                     {
10149                         AV* list = (AV*) *listp;
10150                         IV k;
10151                         for (k = 0; k <= av_len(list); k++) {
10152                             SV** c_p = av_fetch(list, k, FALSE);
10153                             UV c;
10154                             if (c_p == NULL) {
10155                                 Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
10156                             }
10157                             c = SvUV(*c_p);
10158
10159                             /* /aa doesn't allow folds between ASCII and
10160                                 * non-; /l doesn't allow them between above
10161                                 * and below 256 */
10162                             if ((MORE_ASCII_RESTRICTED
10163                                  && (isASCII(c) != isASCII(j)))
10164                                     || (LOC && ((c < 256) != (j < 256))))
10165                             {
10166                                 continue;
10167                             }
10168
10169                             if (c < 256 && AT_LEAST_UNI_SEMANTICS) {
10170                                 stored += set_regclass_bit(pRExC_state,
10171                                         ret,
10172                                         (U8) c,
10173                                         &l1_fold_invlist, &unicode_alternate);
10174                             }
10175                                 /* It may be that the code point is already
10176                                     * in this range or already in the bitmap,
10177                                     * in which case we need do nothing */
10178                             else if ((c < start || c > end)
10179                                         && (c > 255
10180                                             || ! ANYOF_BITMAP_TEST(ret, c)))
10181                             {
10182                                 nonbitmap = add_cp_to_invlist(nonbitmap, c);
10183                             }
10184                         }
10185                     }
10186                 }
10187             }
10188         }
10189         invlist_destroy(fold_intersection);
10190     }
10191
10192     /* Combine the two lists into one. */
10193     if (l1_fold_invlist) {
10194         if (nonbitmap) {
10195             HV* temp = invlist_union(nonbitmap, l1_fold_invlist);
10196             invlist_destroy(nonbitmap);
10197             nonbitmap = temp;
10198             invlist_destroy(l1_fold_invlist);
10199         }
10200         else {
10201             nonbitmap = l1_fold_invlist;
10202         }
10203     }
10204
10205     /* Here, we have calculated what code points should be in the character
10206      * class.   Now we can see about various optimizations.  Fold calculation
10207      * needs to take place before inversion.  Otherwise /[^k]/i would invert to
10208      * include K, which under /i would match k. */
10209
10210     /* Optimize inverted simple patterns (e.g. [^a-z]).  Note that we haven't
10211      * set the FOLD flag yet, so this this does optimize those.  It doesn't
10212      * optimize locale.  Doing so perhaps could be done as long as there is
10213      * nothing like \w in it; some thought also would have to be given to the
10214      * interaction with above 0x100 chars */
10215     if (! LOC
10216         && (ANYOF_FLAGS(ret) & ANYOF_FLAGS_ALL) == ANYOF_INVERT
10217         && ! unicode_alternate
10218         && ! nonbitmap
10219         && SvCUR(listsv) == initial_listsv_len)
10220     {
10221         for (value = 0; value < ANYOF_BITMAP_SIZE; ++value)
10222             ANYOF_BITMAP(ret)[value] ^= 0xFF;
10223         stored = 256 - stored;
10224
10225         /* The inversion means that everything above 255 is matched; and at the
10226          * same time we clear the invert flag */
10227         ANYOF_FLAGS(ret) = ANYOF_UNICODE_ALL;
10228     }
10229
10230     /* Folding in the bitmap is taken care of above, but not for locale (for
10231      * which we have to wait to see what folding is in effect at runtime), and
10232      * for things not in the bitmap.  Set run-time fold flag for these */
10233     if (FOLD && (LOC || nonbitmap || unicode_alternate)) {
10234         ANYOF_FLAGS(ret) |= ANYOF_LOC_NONBITMAP_FOLD;
10235     }
10236
10237     /* A single character class can be "optimized" into an EXACTish node.
10238      * Note that since we don't currently count how many characters there are
10239      * outside the bitmap, we are XXX missing optimization possibilities for
10240      * them.  This optimization can't happen unless this is a truly single
10241      * character class, which means that it can't be an inversion into a
10242      * many-character class, and there must be no possibility of there being
10243      * things outside the bitmap.  'stored' (only) for locales doesn't include
10244      * \w, etc, so have to make a special test that they aren't present
10245      *
10246      * Similarly A 2-character class of the very special form like [bB] can be
10247      * optimized into an EXACTFish node, but only for non-locales, and for
10248      * characters which only have the two folds; so things like 'fF' and 'Ii'
10249      * wouldn't work because they are part of the fold of 'LATIN SMALL LIGATURE
10250      * FI'. */
10251     if (! nonbitmap
10252         && ! unicode_alternate
10253         && SvCUR(listsv) == initial_listsv_len
10254         && ! (ANYOF_FLAGS(ret) & (ANYOF_INVERT|ANYOF_UNICODE_ALL))
10255         && (((stored == 1 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
10256                               || (! ANYOF_CLASS_TEST_ANY_SET(ret)))))
10257             || (stored == 2 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
10258                                  && (! _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(value))
10259                                  /* If the latest code point has a fold whose
10260                                   * bit is set, it must be the only other one */
10261                                 && ((prevvalue = PL_fold_latin1[value]) != (IV)value)
10262                                  && ANYOF_BITMAP_TEST(ret, prevvalue)))))
10263     {
10264         /* Note that the information needed to decide to do this optimization
10265          * is not currently available until the 2nd pass, and that the actually
10266          * used EXACTish node takes less space than the calculated ANYOF node,
10267          * and hence the amount of space calculated in the first pass is larger
10268          * than actually used, so this optimization doesn't gain us any space.
10269          * But an EXACT node is faster than an ANYOF node, and can be combined
10270          * with any adjacent EXACT nodes later by the optimizer for further
10271          * gains.  The speed of executing an EXACTF is similar to an ANYOF
10272          * node, so the optimization advantage comes from the ability to join
10273          * it to adjacent EXACT nodes */
10274
10275         const char * cur_parse= RExC_parse;
10276         U8 op;
10277         RExC_emit = (regnode *)orig_emit;
10278         RExC_parse = (char *)orig_parse;
10279
10280         if (stored == 1) {
10281
10282             /* A locale node with one point can be folded; all the other cases
10283              * with folding will have two points, since we calculate them above
10284              */
10285             if (ANYOF_FLAGS(ret) & ANYOF_LOC_NONBITMAP_FOLD) {
10286                  op = EXACTFL;
10287             }
10288             else {
10289                 op = EXACT;
10290             }
10291         }   /* else 2 chars in the bit map: the folds of each other */
10292         else if (AT_LEAST_UNI_SEMANTICS || !isASCII(value)) {
10293
10294             /* To join adjacent nodes, they must be the exact EXACTish type.
10295              * Try to use the most likely type, by using EXACTFU if the regex
10296              * calls for them, or is required because the character is
10297              * non-ASCII */
10298             op = EXACTFU;
10299         }
10300         else {    /* Otherwise, more likely to be EXACTF type */
10301             op = EXACTF;
10302         }
10303
10304         ret = reg_node(pRExC_state, op);
10305         RExC_parse = (char *)cur_parse;
10306         if (UTF && ! NATIVE_IS_INVARIANT(value)) {
10307             *STRING(ret)= UTF8_EIGHT_BIT_HI((U8) value);
10308             *(STRING(ret) + 1)= UTF8_EIGHT_BIT_LO((U8) value);
10309             STR_LEN(ret)= 2;
10310             RExC_emit += STR_SZ(2);
10311         }
10312         else {
10313             *STRING(ret)= (char)value;
10314             STR_LEN(ret)= 1;
10315             RExC_emit += STR_SZ(1);
10316         }
10317         SvREFCNT_dec(listsv);
10318         return ret;
10319     }
10320
10321     if (nonbitmap) {
10322         UV* nonbitmap_array = invlist_array(nonbitmap);
10323         UV nonbitmap_len = invlist_len(nonbitmap);
10324         UV i;
10325
10326         /*  Here have the full list of items to match that aren't in the
10327          *  bitmap.  Convert to the structure that the rest of the code is
10328          *  expecting.   XXX That rest of the code should convert to this
10329          *  structure */
10330         for (i = 0; i < nonbitmap_len; i++) {
10331
10332             /* The next entry is the beginning of the range that is in the
10333              * class */
10334             UV start = nonbitmap_array[i++];
10335             UV end;
10336
10337             /* The next entry is the beginning of the next range, which isn't
10338              * in the class, so the end of the current range is one less than
10339              * that.  But if there is no next range, it means that the range
10340              * begun by 'start' extends to infinity, which for this platform
10341              * ends at UV_MAX */
10342             if (i == nonbitmap_len) {
10343                 end = UV_MAX;
10344             }
10345             else {
10346                 end = nonbitmap_array[i] - 1;
10347             }
10348
10349             if (start == end) {
10350                 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", start);
10351             }
10352             else {
10353                 /* The \t sets the whole range */
10354                 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
10355                         /* XXX EBCDIC */
10356                                    start, end);
10357             }
10358         }
10359         invlist_destroy(nonbitmap);
10360     }
10361
10362     if (SvCUR(listsv) == initial_listsv_len && ! unicode_alternate) {
10363         ARG_SET(ret, ANYOF_NONBITMAP_EMPTY);
10364         SvREFCNT_dec(listsv);
10365         SvREFCNT_dec(unicode_alternate);
10366     }
10367     else {
10368
10369         AV * const av = newAV();
10370         SV *rv;
10371         /* The 0th element stores the character class description
10372          * in its textual form: used later (regexec.c:Perl_regclass_swash())
10373          * to initialize the appropriate swash (which gets stored in
10374          * the 1st element), and also useful for dumping the regnode.
10375          * The 2nd element stores the multicharacter foldings,
10376          * used later (regexec.c:S_reginclass()). */
10377         av_store(av, 0, listsv);
10378         av_store(av, 1, NULL);
10379
10380         /* Store any computed multi-char folds only if we are allowing
10381          * them */
10382         if (allow_full_fold) {
10383             av_store(av, 2, MUTABLE_SV(unicode_alternate));
10384             if (unicode_alternate) { /* This node is variable length */
10385                 OP(ret) = ANYOFV;
10386             }
10387         }
10388         else {
10389             av_store(av, 2, NULL);
10390         }
10391         rv = newRV_noinc(MUTABLE_SV(av));
10392         n = add_data(pRExC_state, 1, "s");
10393         RExC_rxi->data->data[n] = (void*)rv;
10394         ARG_SET(ret, n);
10395     }
10396     return ret;
10397 }
10398 #undef _C_C_T_
10399
10400
10401 /* reg_skipcomment()
10402
10403    Absorbs an /x style # comments from the input stream.
10404    Returns true if there is more text remaining in the stream.
10405    Will set the REG_SEEN_RUN_ON_COMMENT flag if the comment
10406    terminates the pattern without including a newline.
10407
10408    Note its the callers responsibility to ensure that we are
10409    actually in /x mode
10410
10411 */
10412
10413 STATIC bool
10414 S_reg_skipcomment(pTHX_ RExC_state_t *pRExC_state)
10415 {
10416     bool ended = 0;
10417
10418     PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
10419
10420     while (RExC_parse < RExC_end)
10421         if (*RExC_parse++ == '\n') {
10422             ended = 1;
10423             break;
10424         }
10425     if (!ended) {
10426         /* we ran off the end of the pattern without ending
10427            the comment, so we have to add an \n when wrapping */
10428         RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
10429         return 0;
10430     } else
10431         return 1;
10432 }
10433
10434 /* nextchar()
10435
10436    Advances the parse position, and optionally absorbs
10437    "whitespace" from the inputstream.
10438
10439    Without /x "whitespace" means (?#...) style comments only,
10440    with /x this means (?#...) and # comments and whitespace proper.
10441
10442    Returns the RExC_parse point from BEFORE the scan occurs.
10443
10444    This is the /x friendly way of saying RExC_parse++.
10445 */
10446
10447 STATIC char*
10448 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
10449 {
10450     char* const retval = RExC_parse++;
10451
10452     PERL_ARGS_ASSERT_NEXTCHAR;
10453
10454     for (;;) {
10455         if (*RExC_parse == '(' && RExC_parse[1] == '?' &&
10456                 RExC_parse[2] == '#') {
10457             while (*RExC_parse != ')') {
10458                 if (RExC_parse == RExC_end)
10459                     FAIL("Sequence (?#... not terminated");
10460                 RExC_parse++;
10461             }
10462             RExC_parse++;
10463             continue;
10464         }
10465         if (RExC_flags & RXf_PMf_EXTENDED) {
10466             if (isSPACE(*RExC_parse)) {
10467                 RExC_parse++;
10468                 continue;
10469             }
10470             else if (*RExC_parse == '#') {
10471                 if ( reg_skipcomment( pRExC_state ) )
10472                     continue;
10473             }
10474         }
10475         return retval;
10476     }
10477 }
10478
10479 /*
10480 - reg_node - emit a node
10481 */
10482 STATIC regnode *                        /* Location. */
10483 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
10484 {
10485     dVAR;
10486     register regnode *ptr;
10487     regnode * const ret = RExC_emit;
10488     GET_RE_DEBUG_FLAGS_DECL;
10489
10490     PERL_ARGS_ASSERT_REG_NODE;
10491
10492     if (SIZE_ONLY) {
10493         SIZE_ALIGN(RExC_size);
10494         RExC_size += 1;
10495         return(ret);
10496     }
10497     if (RExC_emit >= RExC_emit_bound)
10498         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d", op);
10499
10500     NODE_ALIGN_FILL(ret);
10501     ptr = ret;
10502     FILL_ADVANCE_NODE(ptr, op);
10503     REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, (ptr) - 1);
10504 #ifdef RE_TRACK_PATTERN_OFFSETS
10505     if (RExC_offsets) {         /* MJD */
10506         MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n", 
10507               "reg_node", __LINE__, 
10508               PL_reg_name[op],
10509               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] 
10510                 ? "Overwriting end of array!\n" : "OK",
10511               (UV)(RExC_emit - RExC_emit_start),
10512               (UV)(RExC_parse - RExC_start),
10513               (UV)RExC_offsets[0])); 
10514         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
10515     }
10516 #endif
10517     RExC_emit = ptr;
10518     return(ret);
10519 }
10520
10521 /*
10522 - reganode - emit a node with an argument
10523 */
10524 STATIC regnode *                        /* Location. */
10525 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
10526 {
10527     dVAR;
10528     register regnode *ptr;
10529     regnode * const ret = RExC_emit;
10530     GET_RE_DEBUG_FLAGS_DECL;
10531
10532     PERL_ARGS_ASSERT_REGANODE;
10533
10534     if (SIZE_ONLY) {
10535         SIZE_ALIGN(RExC_size);
10536         RExC_size += 2;
10537         /* 
10538            We can't do this:
10539            
10540            assert(2==regarglen[op]+1); 
10541         
10542            Anything larger than this has to allocate the extra amount.
10543            If we changed this to be:
10544            
10545            RExC_size += (1 + regarglen[op]);
10546            
10547            then it wouldn't matter. Its not clear what side effect
10548            might come from that so its not done so far.
10549            -- dmq
10550         */
10551         return(ret);
10552     }
10553     if (RExC_emit >= RExC_emit_bound)
10554         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d", op);
10555
10556     NODE_ALIGN_FILL(ret);
10557     ptr = ret;
10558     FILL_ADVANCE_NODE_ARG(ptr, op, arg);
10559     REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, (ptr) - 2);
10560 #ifdef RE_TRACK_PATTERN_OFFSETS
10561     if (RExC_offsets) {         /* MJD */
10562         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
10563               "reganode",
10564               __LINE__,
10565               PL_reg_name[op],
10566               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ? 
10567               "Overwriting end of array!\n" : "OK",
10568               (UV)(RExC_emit - RExC_emit_start),
10569               (UV)(RExC_parse - RExC_start),
10570               (UV)RExC_offsets[0])); 
10571         Set_Cur_Node_Offset;
10572     }
10573 #endif            
10574     RExC_emit = ptr;
10575     return(ret);
10576 }
10577
10578 /*
10579 - reguni - emit (if appropriate) a Unicode character
10580 */
10581 STATIC STRLEN
10582 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
10583 {
10584     dVAR;
10585
10586     PERL_ARGS_ASSERT_REGUNI;
10587
10588     return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
10589 }
10590
10591 /*
10592 - reginsert - insert an operator in front of already-emitted operand
10593 *
10594 * Means relocating the operand.
10595 */
10596 STATIC void
10597 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
10598 {
10599     dVAR;
10600     register regnode *src;
10601     register regnode *dst;
10602     register regnode *place;
10603     const int offset = regarglen[(U8)op];
10604     const int size = NODE_STEP_REGNODE + offset;
10605     GET_RE_DEBUG_FLAGS_DECL;
10606
10607     PERL_ARGS_ASSERT_REGINSERT;
10608     PERL_UNUSED_ARG(depth);
10609 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
10610     DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
10611     if (SIZE_ONLY) {
10612         RExC_size += size;
10613         return;
10614     }
10615
10616     src = RExC_emit;
10617     RExC_emit += size;
10618     dst = RExC_emit;
10619     if (RExC_open_parens) {
10620         int paren;
10621         /*DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);*/
10622         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
10623             if ( RExC_open_parens[paren] >= opnd ) {
10624                 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
10625                 RExC_open_parens[paren] += size;
10626             } else {
10627                 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
10628             }
10629             if ( RExC_close_parens[paren] >= opnd ) {
10630                 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
10631                 RExC_close_parens[paren] += size;
10632             } else {
10633                 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
10634             }
10635         }
10636     }
10637
10638     while (src > opnd) {
10639         StructCopy(--src, --dst, regnode);
10640 #ifdef RE_TRACK_PATTERN_OFFSETS
10641         if (RExC_offsets) {     /* MJD 20010112 */
10642             MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
10643                   "reg_insert",
10644                   __LINE__,
10645                   PL_reg_name[op],
10646                   (UV)(dst - RExC_emit_start) > RExC_offsets[0] 
10647                     ? "Overwriting end of array!\n" : "OK",
10648                   (UV)(src - RExC_emit_start),
10649                   (UV)(dst - RExC_emit_start),
10650                   (UV)RExC_offsets[0])); 
10651             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
10652             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
10653         }
10654 #endif
10655     }
10656     
10657
10658     place = opnd;               /* Op node, where operand used to be. */
10659 #ifdef RE_TRACK_PATTERN_OFFSETS
10660     if (RExC_offsets) {         /* MJD */
10661         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n", 
10662               "reginsert",
10663               __LINE__,
10664               PL_reg_name[op],
10665               (UV)(place - RExC_emit_start) > RExC_offsets[0] 
10666               ? "Overwriting end of array!\n" : "OK",
10667               (UV)(place - RExC_emit_start),
10668               (UV)(RExC_parse - RExC_start),
10669               (UV)RExC_offsets[0]));
10670         Set_Node_Offset(place, RExC_parse);
10671         Set_Node_Length(place, 1);
10672     }
10673 #endif    
10674     src = NEXTOPER(place);
10675     FILL_ADVANCE_NODE(place, op);
10676     REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, (place) - 1);
10677     Zero(src, offset, regnode);
10678 }
10679
10680 /*
10681 - regtail - set the next-pointer at the end of a node chain of p to val.
10682 - SEE ALSO: regtail_study
10683 */
10684 /* TODO: All three parms should be const */
10685 STATIC void
10686 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
10687 {
10688     dVAR;
10689     register regnode *scan;
10690     GET_RE_DEBUG_FLAGS_DECL;
10691
10692     PERL_ARGS_ASSERT_REGTAIL;
10693 #ifndef DEBUGGING
10694     PERL_UNUSED_ARG(depth);
10695 #endif
10696
10697     if (SIZE_ONLY)
10698         return;
10699
10700     /* Find last node. */
10701     scan = p;
10702     for (;;) {
10703         regnode * const temp = regnext(scan);
10704         DEBUG_PARSE_r({
10705             SV * const mysv=sv_newmortal();
10706             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
10707             regprop(RExC_rx, mysv, scan);
10708             PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
10709                 SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
10710                     (temp == NULL ? "->" : ""),
10711                     (temp == NULL ? PL_reg_name[OP(val)] : "")
10712             );
10713         });
10714         if (temp == NULL)
10715             break;
10716         scan = temp;
10717     }
10718
10719     if (reg_off_by_arg[OP(scan)]) {
10720         ARG_SET(scan, val - scan);
10721     }
10722     else {
10723         NEXT_OFF(scan) = val - scan;
10724     }
10725 }
10726
10727 #ifdef DEBUGGING
10728 /*
10729 - regtail_study - set the next-pointer at the end of a node chain of p to val.
10730 - Look for optimizable sequences at the same time.
10731 - currently only looks for EXACT chains.
10732
10733 This is experimental code. The idea is to use this routine to perform 
10734 in place optimizations on branches and groups as they are constructed,
10735 with the long term intention of removing optimization from study_chunk so
10736 that it is purely analytical.
10737
10738 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
10739 to control which is which.
10740
10741 */
10742 /* TODO: All four parms should be const */
10743
10744 STATIC U8
10745 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
10746 {
10747     dVAR;
10748     register regnode *scan;
10749     U8 exact = PSEUDO;
10750 #ifdef EXPERIMENTAL_INPLACESCAN
10751     I32 min = 0;
10752 #endif
10753     GET_RE_DEBUG_FLAGS_DECL;
10754
10755     PERL_ARGS_ASSERT_REGTAIL_STUDY;
10756
10757
10758     if (SIZE_ONLY)
10759         return exact;
10760
10761     /* Find last node. */
10762
10763     scan = p;
10764     for (;;) {
10765         regnode * const temp = regnext(scan);
10766 #ifdef EXPERIMENTAL_INPLACESCAN
10767         if (PL_regkind[OP(scan)] == EXACT)
10768             if (join_exact(pRExC_state,scan,&min,1,val,depth+1))
10769                 return EXACT;
10770 #endif
10771         if ( exact ) {
10772             switch (OP(scan)) {
10773                 case EXACT:
10774                 case EXACTF:
10775                 case EXACTFA:
10776                 case EXACTFU:
10777                 case EXACTFL:
10778                         if( exact == PSEUDO )
10779                             exact= OP(scan);
10780                         else if ( exact != OP(scan) )
10781                             exact= 0;
10782                 case NOTHING:
10783                     break;
10784                 default:
10785                     exact= 0;
10786             }
10787         }
10788         DEBUG_PARSE_r({
10789             SV * const mysv=sv_newmortal();
10790             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
10791             regprop(RExC_rx, mysv, scan);
10792             PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
10793                 SvPV_nolen_const(mysv),
10794                 REG_NODE_NUM(scan),
10795                 PL_reg_name[exact]);
10796         });
10797         if (temp == NULL)
10798             break;
10799         scan = temp;
10800     }
10801     DEBUG_PARSE_r({
10802         SV * const mysv_val=sv_newmortal();
10803         DEBUG_PARSE_MSG("");
10804         regprop(RExC_rx, mysv_val, val);
10805         PerlIO_printf(Perl_debug_log, "~ attach to %s (%"IVdf") offset to %"IVdf"\n",
10806                       SvPV_nolen_const(mysv_val),
10807                       (IV)REG_NODE_NUM(val),
10808                       (IV)(val - scan)
10809         );
10810     });
10811     if (reg_off_by_arg[OP(scan)]) {
10812         ARG_SET(scan, val - scan);
10813     }
10814     else {
10815         NEXT_OFF(scan) = val - scan;
10816     }
10817
10818     return exact;
10819 }
10820 #endif
10821
10822 /*
10823  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
10824  */
10825 #ifdef DEBUGGING
10826 static void 
10827 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
10828 {
10829     int bit;
10830     int set=0;
10831     regex_charset cs;
10832
10833     for (bit=0; bit<32; bit++) {
10834         if (flags & (1<<bit)) {
10835             if ((1<<bit) & RXf_PMf_CHARSET) {   /* Output separately, below */
10836                 continue;
10837             }
10838             if (!set++ && lead) 
10839                 PerlIO_printf(Perl_debug_log, "%s",lead);
10840             PerlIO_printf(Perl_debug_log, "%s ",PL_reg_extflags_name[bit]);
10841         }               
10842     }      
10843     if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
10844             if (!set++ && lead) {
10845                 PerlIO_printf(Perl_debug_log, "%s",lead);
10846             }
10847             switch (cs) {
10848                 case REGEX_UNICODE_CHARSET:
10849                     PerlIO_printf(Perl_debug_log, "UNICODE");
10850                     break;
10851                 case REGEX_LOCALE_CHARSET:
10852                     PerlIO_printf(Perl_debug_log, "LOCALE");
10853                     break;
10854                 case REGEX_ASCII_RESTRICTED_CHARSET:
10855                     PerlIO_printf(Perl_debug_log, "ASCII-RESTRICTED");
10856                     break;
10857                 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
10858                     PerlIO_printf(Perl_debug_log, "ASCII-MORE_RESTRICTED");
10859                     break;
10860                 default:
10861                     PerlIO_printf(Perl_debug_log, "UNKNOWN CHARACTER SET");
10862                     break;
10863             }
10864     }
10865     if (lead)  {
10866         if (set) 
10867             PerlIO_printf(Perl_debug_log, "\n");
10868         else 
10869             PerlIO_printf(Perl_debug_log, "%s[none-set]\n",lead);
10870     }            
10871 }   
10872 #endif
10873
10874 void
10875 Perl_regdump(pTHX_ const regexp *r)
10876 {
10877 #ifdef DEBUGGING
10878     dVAR;
10879     SV * const sv = sv_newmortal();
10880     SV *dsv= sv_newmortal();
10881     RXi_GET_DECL(r,ri);
10882     GET_RE_DEBUG_FLAGS_DECL;
10883
10884     PERL_ARGS_ASSERT_REGDUMP;
10885
10886     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
10887
10888     /* Header fields of interest. */
10889     if (r->anchored_substr) {
10890         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr), 
10891             RE_SV_DUMPLEN(r->anchored_substr), 30);
10892         PerlIO_printf(Perl_debug_log,
10893                       "anchored %s%s at %"IVdf" ",
10894                       s, RE_SV_TAIL(r->anchored_substr),
10895                       (IV)r->anchored_offset);
10896     } else if (r->anchored_utf8) {
10897         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8), 
10898             RE_SV_DUMPLEN(r->anchored_utf8), 30);
10899         PerlIO_printf(Perl_debug_log,
10900                       "anchored utf8 %s%s at %"IVdf" ",
10901                       s, RE_SV_TAIL(r->anchored_utf8),
10902                       (IV)r->anchored_offset);
10903     }                 
10904     if (r->float_substr) {
10905         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr), 
10906             RE_SV_DUMPLEN(r->float_substr), 30);
10907         PerlIO_printf(Perl_debug_log,
10908                       "floating %s%s at %"IVdf"..%"UVuf" ",
10909                       s, RE_SV_TAIL(r->float_substr),
10910                       (IV)r->float_min_offset, (UV)r->float_max_offset);
10911     } else if (r->float_utf8) {
10912         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8), 
10913             RE_SV_DUMPLEN(r->float_utf8), 30);
10914         PerlIO_printf(Perl_debug_log,
10915                       "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
10916                       s, RE_SV_TAIL(r->float_utf8),
10917                       (IV)r->float_min_offset, (UV)r->float_max_offset);
10918     }
10919     if (r->check_substr || r->check_utf8)
10920         PerlIO_printf(Perl_debug_log,
10921                       (const char *)
10922                       (r->check_substr == r->float_substr
10923                        && r->check_utf8 == r->float_utf8
10924                        ? "(checking floating" : "(checking anchored"));
10925     if (r->extflags & RXf_NOSCAN)
10926         PerlIO_printf(Perl_debug_log, " noscan");
10927     if (r->extflags & RXf_CHECK_ALL)
10928         PerlIO_printf(Perl_debug_log, " isall");
10929     if (r->check_substr || r->check_utf8)
10930         PerlIO_printf(Perl_debug_log, ") ");
10931
10932     if (ri->regstclass) {
10933         regprop(r, sv, ri->regstclass);
10934         PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
10935     }
10936     if (r->extflags & RXf_ANCH) {
10937         PerlIO_printf(Perl_debug_log, "anchored");
10938         if (r->extflags & RXf_ANCH_BOL)
10939             PerlIO_printf(Perl_debug_log, "(BOL)");
10940         if (r->extflags & RXf_ANCH_MBOL)
10941             PerlIO_printf(Perl_debug_log, "(MBOL)");
10942         if (r->extflags & RXf_ANCH_SBOL)
10943             PerlIO_printf(Perl_debug_log, "(SBOL)");
10944         if (r->extflags & RXf_ANCH_GPOS)
10945             PerlIO_printf(Perl_debug_log, "(GPOS)");
10946         PerlIO_putc(Perl_debug_log, ' ');
10947     }
10948     if (r->extflags & RXf_GPOS_SEEN)
10949         PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs);
10950     if (r->intflags & PREGf_SKIP)
10951         PerlIO_printf(Perl_debug_log, "plus ");
10952     if (r->intflags & PREGf_IMPLICIT)
10953         PerlIO_printf(Perl_debug_log, "implicit ");
10954     PerlIO_printf(Perl_debug_log, "minlen %"IVdf" ", (IV)r->minlen);
10955     if (r->extflags & RXf_EVAL_SEEN)
10956         PerlIO_printf(Perl_debug_log, "with eval ");
10957     PerlIO_printf(Perl_debug_log, "\n");
10958     DEBUG_FLAGS_r(regdump_extflags("r->extflags: ",r->extflags));            
10959 #else
10960     PERL_ARGS_ASSERT_REGDUMP;
10961     PERL_UNUSED_CONTEXT;
10962     PERL_UNUSED_ARG(r);
10963 #endif  /* DEBUGGING */
10964 }
10965
10966 /*
10967 - regprop - printable representation of opcode
10968 */
10969 #define EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags) \
10970 STMT_START { \
10971         if (do_sep) {                           \
10972             Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]); \
10973             if (flags & ANYOF_INVERT)           \
10974                 /*make sure the invert info is in each */ \
10975                 sv_catpvs(sv, "^");             \
10976             do_sep = 0;                         \
10977         }                                       \
10978 } STMT_END
10979
10980 void
10981 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
10982 {
10983 #ifdef DEBUGGING
10984     dVAR;
10985     register int k;
10986     RXi_GET_DECL(prog,progi);
10987     GET_RE_DEBUG_FLAGS_DECL;
10988     
10989     PERL_ARGS_ASSERT_REGPROP;
10990
10991     sv_setpvs(sv, "");
10992
10993     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
10994         /* It would be nice to FAIL() here, but this may be called from
10995            regexec.c, and it would be hard to supply pRExC_state. */
10996         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX);
10997     sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
10998
10999     k = PL_regkind[OP(o)];
11000
11001     if (k == EXACT) {
11002         sv_catpvs(sv, " ");
11003         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT) 
11004          * is a crude hack but it may be the best for now since 
11005          * we have no flag "this EXACTish node was UTF-8" 
11006          * --jhi */
11007         pv_pretty(sv, STRING(o), STR_LEN(o), 60, PL_colors[0], PL_colors[1],
11008                   PERL_PV_ESCAPE_UNI_DETECT |
11009                   PERL_PV_ESCAPE_NONASCII   |
11010                   PERL_PV_PRETTY_ELLIPSES   |
11011                   PERL_PV_PRETTY_LTGT       |
11012                   PERL_PV_PRETTY_NOCLEAR
11013                   );
11014     } else if (k == TRIE) {
11015         /* print the details of the trie in dumpuntil instead, as
11016          * progi->data isn't available here */
11017         const char op = OP(o);
11018         const U32 n = ARG(o);
11019         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
11020                (reg_ac_data *)progi->data->data[n] :
11021                NULL;
11022         const reg_trie_data * const trie
11023             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
11024         
11025         Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
11026         DEBUG_TRIE_COMPILE_r(
11027             Perl_sv_catpvf(aTHX_ sv,
11028                 "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
11029                 (UV)trie->startstate,
11030                 (IV)trie->statecount-1, /* -1 because of the unused 0 element */
11031                 (UV)trie->wordcount,
11032                 (UV)trie->minlen,
11033                 (UV)trie->maxlen,
11034                 (UV)TRIE_CHARCOUNT(trie),
11035                 (UV)trie->uniquecharcount
11036             )
11037         );
11038         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
11039             int i;
11040             int rangestart = -1;
11041             U8* bitmap = IS_ANYOF_TRIE(op) ? (U8*)ANYOF_BITMAP(o) : (U8*)TRIE_BITMAP(trie);
11042             sv_catpvs(sv, "[");
11043             for (i = 0; i <= 256; i++) {
11044                 if (i < 256 && BITMAP_TEST(bitmap,i)) {
11045                     if (rangestart == -1)
11046                         rangestart = i;
11047                 } else if (rangestart != -1) {
11048                     if (i <= rangestart + 3)
11049                         for (; rangestart < i; rangestart++)
11050                             put_byte(sv, rangestart);
11051                     else {
11052                         put_byte(sv, rangestart);
11053                         sv_catpvs(sv, "-");
11054                         put_byte(sv, i - 1);
11055                     }
11056                     rangestart = -1;
11057                 }
11058             }
11059             sv_catpvs(sv, "]");
11060         } 
11061          
11062     } else if (k == CURLY) {
11063         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
11064             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
11065         Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
11066     }
11067     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
11068         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
11069     else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) {
11070         Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o));    /* Parenth number */
11071         if ( RXp_PAREN_NAMES(prog) ) {
11072             if ( k != REF || (OP(o) < NREF)) {
11073                 AV *list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
11074                 SV **name= av_fetch(list, ARG(o), 0 );
11075                 if (name)
11076                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
11077             }       
11078             else {
11079                 AV *list= MUTABLE_AV(progi->data->data[ progi->name_list_idx ]);
11080                 SV *sv_dat= MUTABLE_SV(progi->data->data[ ARG( o ) ]);
11081                 I32 *nums=(I32*)SvPVX(sv_dat);
11082                 SV **name= av_fetch(list, nums[0], 0 );
11083                 I32 n;
11084                 if (name) {
11085                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
11086                         Perl_sv_catpvf(aTHX_ sv, "%s%"IVdf,
11087                                     (n ? "," : ""), (IV)nums[n]);
11088                     }
11089                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
11090                 }
11091             }
11092         }            
11093     } else if (k == GOSUB) 
11094         Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */
11095     else if (k == VERB) {
11096         if (!o->flags) 
11097             Perl_sv_catpvf(aTHX_ sv, ":%"SVf, 
11098                            SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
11099     } else if (k == LOGICAL)
11100         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);     /* 2: embedded, otherwise 1 */
11101     else if (k == FOLDCHAR)
11102         Perl_sv_catpvf(aTHX_ sv, "[0x%"UVXf"]", PTR2UV(ARG(o)) );
11103     else if (k == ANYOF) {
11104         int i, rangestart = -1;
11105         const U8 flags = ANYOF_FLAGS(o);
11106         int do_sep = 0;
11107
11108         /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
11109         static const char * const anyofs[] = {
11110             "\\w",
11111             "\\W",
11112             "\\s",
11113             "\\S",
11114             "\\d",
11115             "\\D",
11116             "[:alnum:]",
11117             "[:^alnum:]",
11118             "[:alpha:]",
11119             "[:^alpha:]",
11120             "[:ascii:]",
11121             "[:^ascii:]",
11122             "[:cntrl:]",
11123             "[:^cntrl:]",
11124             "[:graph:]",
11125             "[:^graph:]",
11126             "[:lower:]",
11127             "[:^lower:]",
11128             "[:print:]",
11129             "[:^print:]",
11130             "[:punct:]",
11131             "[:^punct:]",
11132             "[:upper:]",
11133             "[:^upper:]",
11134             "[:xdigit:]",
11135             "[:^xdigit:]",
11136             "[:space:]",
11137             "[:^space:]",
11138             "[:blank:]",
11139             "[:^blank:]"
11140         };
11141
11142         if (flags & ANYOF_LOCALE)
11143             sv_catpvs(sv, "{loc}");
11144         if (flags & ANYOF_LOC_NONBITMAP_FOLD)
11145             sv_catpvs(sv, "{i}");
11146         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
11147         if (flags & ANYOF_INVERT)
11148             sv_catpvs(sv, "^");
11149         
11150         /* output what the standard cp 0-255 bitmap matches */
11151         for (i = 0; i <= 256; i++) {
11152             if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
11153                 if (rangestart == -1)
11154                     rangestart = i;
11155             } else if (rangestart != -1) {
11156                 if (i <= rangestart + 3)
11157                     for (; rangestart < i; rangestart++)
11158                         put_byte(sv, rangestart);
11159                 else {
11160                     put_byte(sv, rangestart);
11161                     sv_catpvs(sv, "-");
11162                     put_byte(sv, i - 1);
11163                 }
11164                 do_sep = 1;
11165                 rangestart = -1;
11166             }
11167         }
11168         
11169         EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
11170         /* output any special charclass tests (used entirely under use locale) */
11171         if (ANYOF_CLASS_TEST_ANY_SET(o))
11172             for (i = 0; i < (int)(sizeof(anyofs)/sizeof(char*)); i++)
11173                 if (ANYOF_CLASS_TEST(o,i)) {
11174                     sv_catpv(sv, anyofs[i]);
11175                     do_sep = 1;
11176                 }
11177         
11178         EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
11179         
11180         if (flags & ANYOF_NON_UTF8_LATIN1_ALL) {
11181             sv_catpvs(sv, "{non-utf8-latin1-all}");
11182         }
11183
11184         /* output information about the unicode matching */
11185         if (flags & ANYOF_UNICODE_ALL)
11186             sv_catpvs(sv, "{unicode_all}");
11187         else if (ANYOF_NONBITMAP(o))
11188             sv_catpvs(sv, "{unicode}");
11189         if (flags & ANYOF_NONBITMAP_NON_UTF8)
11190             sv_catpvs(sv, "{outside bitmap}");
11191
11192         if (ANYOF_NONBITMAP(o)) {
11193             SV *lv;
11194             SV * const sw = regclass_swash(prog, o, FALSE, &lv, 0);
11195         
11196             if (lv) {
11197                 if (sw) {
11198                     U8 s[UTF8_MAXBYTES_CASE+1];
11199
11200                     for (i = 0; i <= 256; i++) { /* just the first 256 */
11201                         uvchr_to_utf8(s, i);
11202                         
11203                         if (i < 256 && swash_fetch(sw, s, TRUE)) {
11204                             if (rangestart == -1)
11205                                 rangestart = i;
11206                         } else if (rangestart != -1) {
11207                             if (i <= rangestart + 3)
11208                                 for (; rangestart < i; rangestart++) {
11209                                     const U8 * const e = uvchr_to_utf8(s,rangestart);
11210                                     U8 *p;
11211                                     for(p = s; p < e; p++)
11212                                         put_byte(sv, *p);
11213                                 }
11214                             else {
11215                                 const U8 *e = uvchr_to_utf8(s,rangestart);
11216                                 U8 *p;
11217                                 for (p = s; p < e; p++)
11218                                     put_byte(sv, *p);
11219                                 sv_catpvs(sv, "-");
11220                                 e = uvchr_to_utf8(s, i-1);
11221                                 for (p = s; p < e; p++)
11222                                     put_byte(sv, *p);
11223                                 }
11224                                 rangestart = -1;
11225                             }
11226                         }
11227                         
11228                     sv_catpvs(sv, "..."); /* et cetera */
11229                 }
11230
11231                 {
11232                     char *s = savesvpv(lv);
11233                     char * const origs = s;
11234                 
11235                     while (*s && *s != '\n')
11236                         s++;
11237                 
11238                     if (*s == '\n') {
11239                         const char * const t = ++s;
11240                         
11241                         while (*s) {
11242                             if (*s == '\n')
11243                                 *s = ' ';
11244                             s++;
11245                         }
11246                         if (s[-1] == ' ')
11247                             s[-1] = 0;
11248                         
11249                         sv_catpv(sv, t);
11250                     }
11251                 
11252                     Safefree(origs);
11253                 }
11254             }
11255         }
11256
11257         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
11258     }
11259     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
11260         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
11261 #else
11262     PERL_UNUSED_CONTEXT;
11263     PERL_UNUSED_ARG(sv);
11264     PERL_UNUSED_ARG(o);
11265     PERL_UNUSED_ARG(prog);
11266 #endif  /* DEBUGGING */
11267 }
11268
11269 SV *
11270 Perl_re_intuit_string(pTHX_ REGEXP * const r)
11271 {                               /* Assume that RE_INTUIT is set */
11272     dVAR;
11273     struct regexp *const prog = (struct regexp *)SvANY(r);
11274     GET_RE_DEBUG_FLAGS_DECL;
11275
11276     PERL_ARGS_ASSERT_RE_INTUIT_STRING;
11277     PERL_UNUSED_CONTEXT;
11278
11279     DEBUG_COMPILE_r(
11280         {
11281             const char * const s = SvPV_nolen_const(prog->check_substr
11282                       ? prog->check_substr : prog->check_utf8);
11283
11284             if (!PL_colorset) reginitcolors();
11285             PerlIO_printf(Perl_debug_log,
11286                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
11287                       PL_colors[4],
11288                       prog->check_substr ? "" : "utf8 ",
11289                       PL_colors[5],PL_colors[0],
11290                       s,
11291                       PL_colors[1],
11292                       (strlen(s) > 60 ? "..." : ""));
11293         } );
11294
11295     return prog->check_substr ? prog->check_substr : prog->check_utf8;
11296 }
11297
11298 /* 
11299    pregfree() 
11300    
11301    handles refcounting and freeing the perl core regexp structure. When 
11302    it is necessary to actually free the structure the first thing it 
11303    does is call the 'free' method of the regexp_engine associated to
11304    the regexp, allowing the handling of the void *pprivate; member 
11305    first. (This routine is not overridable by extensions, which is why 
11306    the extensions free is called first.)
11307    
11308    See regdupe and regdupe_internal if you change anything here. 
11309 */
11310 #ifndef PERL_IN_XSUB_RE
11311 void
11312 Perl_pregfree(pTHX_ REGEXP *r)
11313 {
11314     SvREFCNT_dec(r);
11315 }
11316
11317 void
11318 Perl_pregfree2(pTHX_ REGEXP *rx)
11319 {
11320     dVAR;
11321     struct regexp *const r = (struct regexp *)SvANY(rx);
11322     GET_RE_DEBUG_FLAGS_DECL;
11323
11324     PERL_ARGS_ASSERT_PREGFREE2;
11325
11326     if (r->mother_re) {
11327         ReREFCNT_dec(r->mother_re);
11328     } else {
11329         CALLREGFREE_PVT(rx); /* free the private data */
11330         SvREFCNT_dec(RXp_PAREN_NAMES(r));
11331     }        
11332     if (r->substrs) {
11333         SvREFCNT_dec(r->anchored_substr);
11334         SvREFCNT_dec(r->anchored_utf8);
11335         SvREFCNT_dec(r->float_substr);
11336         SvREFCNT_dec(r->float_utf8);
11337         Safefree(r->substrs);
11338     }
11339     RX_MATCH_COPY_FREE(rx);
11340 #ifdef PERL_OLD_COPY_ON_WRITE
11341     SvREFCNT_dec(r->saved_copy);
11342 #endif
11343     Safefree(r->offs);
11344 }
11345
11346 /*  reg_temp_copy()
11347     
11348     This is a hacky workaround to the structural issue of match results
11349     being stored in the regexp structure which is in turn stored in
11350     PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
11351     could be PL_curpm in multiple contexts, and could require multiple
11352     result sets being associated with the pattern simultaneously, such
11353     as when doing a recursive match with (??{$qr})
11354     
11355     The solution is to make a lightweight copy of the regexp structure 
11356     when a qr// is returned from the code executed by (??{$qr}) this
11357     lightweight copy doesn't actually own any of its data except for
11358     the starp/end and the actual regexp structure itself. 
11359     
11360 */    
11361     
11362     
11363 REGEXP *
11364 Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
11365 {
11366     struct regexp *ret;
11367     struct regexp *const r = (struct regexp *)SvANY(rx);
11368     register const I32 npar = r->nparens+1;
11369
11370     PERL_ARGS_ASSERT_REG_TEMP_COPY;
11371
11372     if (!ret_x)
11373         ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
11374     ret = (struct regexp *)SvANY(ret_x);
11375     
11376     (void)ReREFCNT_inc(rx);
11377     /* We can take advantage of the existing "copied buffer" mechanism in SVs
11378        by pointing directly at the buffer, but flagging that the allocated
11379        space in the copy is zero. As we've just done a struct copy, it's now
11380        a case of zero-ing that, rather than copying the current length.  */
11381     SvPV_set(ret_x, RX_WRAPPED(rx));
11382     SvFLAGS(ret_x) |= SvFLAGS(rx) & (SVf_POK|SVp_POK|SVf_UTF8);
11383     memcpy(&(ret->xpv_cur), &(r->xpv_cur),
11384            sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
11385     SvLEN_set(ret_x, 0);
11386     SvSTASH_set(ret_x, NULL);
11387     SvMAGIC_set(ret_x, NULL);
11388     Newx(ret->offs, npar, regexp_paren_pair);
11389     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
11390     if (r->substrs) {
11391         Newx(ret->substrs, 1, struct reg_substr_data);
11392         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
11393
11394         SvREFCNT_inc_void(ret->anchored_substr);
11395         SvREFCNT_inc_void(ret->anchored_utf8);
11396         SvREFCNT_inc_void(ret->float_substr);
11397         SvREFCNT_inc_void(ret->float_utf8);
11398
11399         /* check_substr and check_utf8, if non-NULL, point to either their
11400            anchored or float namesakes, and don't hold a second reference.  */
11401     }
11402     RX_MATCH_COPIED_off(ret_x);
11403 #ifdef PERL_OLD_COPY_ON_WRITE
11404     ret->saved_copy = NULL;
11405 #endif
11406     ret->mother_re = rx;
11407     
11408     return ret_x;
11409 }
11410 #endif
11411
11412 /* regfree_internal() 
11413
11414    Free the private data in a regexp. This is overloadable by 
11415    extensions. Perl takes care of the regexp structure in pregfree(), 
11416    this covers the *pprivate pointer which technically perl doesn't 
11417    know about, however of course we have to handle the 
11418    regexp_internal structure when no extension is in use. 
11419    
11420    Note this is called before freeing anything in the regexp 
11421    structure. 
11422  */
11423  
11424 void
11425 Perl_regfree_internal(pTHX_ REGEXP * const rx)
11426 {
11427     dVAR;
11428     struct regexp *const r = (struct regexp *)SvANY(rx);
11429     RXi_GET_DECL(r,ri);
11430     GET_RE_DEBUG_FLAGS_DECL;
11431
11432     PERL_ARGS_ASSERT_REGFREE_INTERNAL;
11433
11434     DEBUG_COMPILE_r({
11435         if (!PL_colorset)
11436             reginitcolors();
11437         {
11438             SV *dsv= sv_newmortal();
11439             RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
11440                 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60);
11441             PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n", 
11442                 PL_colors[4],PL_colors[5],s);
11443         }
11444     });
11445 #ifdef RE_TRACK_PATTERN_OFFSETS
11446     if (ri->u.offsets)
11447         Safefree(ri->u.offsets);             /* 20010421 MJD */
11448 #endif
11449     if (ri->data) {
11450         int n = ri->data->count;
11451         PAD* new_comppad = NULL;
11452         PAD* old_comppad;
11453         PADOFFSET refcnt;
11454
11455         while (--n >= 0) {
11456           /* If you add a ->what type here, update the comment in regcomp.h */
11457             switch (ri->data->what[n]) {
11458             case 'a':
11459             case 's':
11460             case 'S':
11461             case 'u':
11462                 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
11463                 break;
11464             case 'f':
11465                 Safefree(ri->data->data[n]);
11466                 break;
11467             case 'p':
11468                 new_comppad = MUTABLE_AV(ri->data->data[n]);
11469                 break;
11470             case 'o':
11471                 if (new_comppad == NULL)
11472                     Perl_croak(aTHX_ "panic: pregfree comppad");
11473                 PAD_SAVE_LOCAL(old_comppad,
11474                     /* Watch out for global destruction's random ordering. */
11475                     (SvTYPE(new_comppad) == SVt_PVAV) ? new_comppad : NULL
11476                 );
11477                 OP_REFCNT_LOCK;
11478                 refcnt = OpREFCNT_dec((OP_4tree*)ri->data->data[n]);
11479                 OP_REFCNT_UNLOCK;
11480                 if (!refcnt)
11481                     op_free((OP_4tree*)ri->data->data[n]);
11482
11483                 PAD_RESTORE_LOCAL(old_comppad);
11484                 SvREFCNT_dec(MUTABLE_SV(new_comppad));
11485                 new_comppad = NULL;
11486                 break;
11487             case 'n':
11488                 break;
11489             case 'T':           
11490                 { /* Aho Corasick add-on structure for a trie node.
11491                      Used in stclass optimization only */
11492                     U32 refcount;
11493                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
11494                     OP_REFCNT_LOCK;
11495                     refcount = --aho->refcount;
11496                     OP_REFCNT_UNLOCK;
11497                     if ( !refcount ) {
11498                         PerlMemShared_free(aho->states);
11499                         PerlMemShared_free(aho->fail);
11500                          /* do this last!!!! */
11501                         PerlMemShared_free(ri->data->data[n]);
11502                         PerlMemShared_free(ri->regstclass);
11503                     }
11504                 }
11505                 break;
11506             case 't':
11507                 {
11508                     /* trie structure. */
11509                     U32 refcount;
11510                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
11511                     OP_REFCNT_LOCK;
11512                     refcount = --trie->refcount;
11513                     OP_REFCNT_UNLOCK;
11514                     if ( !refcount ) {
11515                         PerlMemShared_free(trie->charmap);
11516                         PerlMemShared_free(trie->states);
11517                         PerlMemShared_free(trie->trans);
11518                         if (trie->bitmap)
11519                             PerlMemShared_free(trie->bitmap);
11520                         if (trie->jump)
11521                             PerlMemShared_free(trie->jump);
11522                         PerlMemShared_free(trie->wordinfo);
11523                         /* do this last!!!! */
11524                         PerlMemShared_free(ri->data->data[n]);
11525                     }
11526                 }
11527                 break;
11528             default:
11529                 Perl_croak(aTHX_ "panic: regfree data code '%c'", ri->data->what[n]);
11530             }
11531         }
11532         Safefree(ri->data->what);
11533         Safefree(ri->data);
11534     }
11535
11536     Safefree(ri);
11537 }
11538
11539 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
11540 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
11541 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
11542
11543 /* 
11544    re_dup - duplicate a regexp. 
11545    
11546    This routine is expected to clone a given regexp structure. It is only
11547    compiled under USE_ITHREADS.
11548
11549    After all of the core data stored in struct regexp is duplicated
11550    the regexp_engine.dupe method is used to copy any private data
11551    stored in the *pprivate pointer. This allows extensions to handle
11552    any duplication it needs to do.
11553
11554    See pregfree() and regfree_internal() if you change anything here. 
11555 */
11556 #if defined(USE_ITHREADS)
11557 #ifndef PERL_IN_XSUB_RE
11558 void
11559 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
11560 {
11561     dVAR;
11562     I32 npar;
11563     const struct regexp *r = (const struct regexp *)SvANY(sstr);
11564     struct regexp *ret = (struct regexp *)SvANY(dstr);
11565     
11566     PERL_ARGS_ASSERT_RE_DUP_GUTS;
11567
11568     npar = r->nparens+1;
11569     Newx(ret->offs, npar, regexp_paren_pair);
11570     Copy(r->offs, ret->offs, npar, regexp_paren_pair);
11571     if(ret->swap) {
11572         /* no need to copy these */
11573         Newx(ret->swap, npar, regexp_paren_pair);
11574     }
11575
11576     if (ret->substrs) {
11577         /* Do it this way to avoid reading from *r after the StructCopy().
11578            That way, if any of the sv_dup_inc()s dislodge *r from the L1
11579            cache, it doesn't matter.  */
11580         const bool anchored = r->check_substr
11581             ? r->check_substr == r->anchored_substr
11582             : r->check_utf8 == r->anchored_utf8;
11583         Newx(ret->substrs, 1, struct reg_substr_data);
11584         StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
11585
11586         ret->anchored_substr = sv_dup_inc(ret->anchored_substr, param);
11587         ret->anchored_utf8 = sv_dup_inc(ret->anchored_utf8, param);
11588         ret->float_substr = sv_dup_inc(ret->float_substr, param);
11589         ret->float_utf8 = sv_dup_inc(ret->float_utf8, param);
11590
11591         /* check_substr and check_utf8, if non-NULL, point to either their
11592            anchored or float namesakes, and don't hold a second reference.  */
11593
11594         if (ret->check_substr) {
11595             if (anchored) {
11596                 assert(r->check_utf8 == r->anchored_utf8);
11597                 ret->check_substr = ret->anchored_substr;
11598                 ret->check_utf8 = ret->anchored_utf8;
11599             } else {
11600                 assert(r->check_substr == r->float_substr);
11601                 assert(r->check_utf8 == r->float_utf8);
11602                 ret->check_substr = ret->float_substr;
11603                 ret->check_utf8 = ret->float_utf8;
11604             }
11605         } else if (ret->check_utf8) {
11606             if (anchored) {
11607                 ret->check_utf8 = ret->anchored_utf8;
11608             } else {
11609                 ret->check_utf8 = ret->float_utf8;
11610             }
11611         }
11612     }
11613
11614     RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
11615
11616     if (ret->pprivate)
11617         RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
11618
11619     if (RX_MATCH_COPIED(dstr))
11620         ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
11621     else
11622         ret->subbeg = NULL;
11623 #ifdef PERL_OLD_COPY_ON_WRITE
11624     ret->saved_copy = NULL;
11625 #endif
11626
11627     if (ret->mother_re) {
11628         if (SvPVX_const(dstr) == SvPVX_const(ret->mother_re)) {
11629             /* Our storage points directly to our mother regexp, but that's
11630                1: a buffer in a different thread
11631                2: something we no longer hold a reference on
11632                so we need to copy it locally.  */
11633             /* Note we need to sue SvCUR() on our mother_re, because it, in
11634                turn, may well be pointing to its own mother_re.  */
11635             SvPV_set(dstr, SAVEPVN(SvPVX_const(ret->mother_re),
11636                                    SvCUR(ret->mother_re)+1));
11637             SvLEN_set(dstr, SvCUR(ret->mother_re)+1);
11638         }
11639         ret->mother_re      = NULL;
11640     }
11641     ret->gofs = 0;
11642 }
11643 #endif /* PERL_IN_XSUB_RE */
11644
11645 /*
11646    regdupe_internal()
11647    
11648    This is the internal complement to regdupe() which is used to copy
11649    the structure pointed to by the *pprivate pointer in the regexp.
11650    This is the core version of the extension overridable cloning hook.
11651    The regexp structure being duplicated will be copied by perl prior
11652    to this and will be provided as the regexp *r argument, however 
11653    with the /old/ structures pprivate pointer value. Thus this routine
11654    may override any copying normally done by perl.
11655    
11656    It returns a pointer to the new regexp_internal structure.
11657 */
11658
11659 void *
11660 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
11661 {
11662     dVAR;
11663     struct regexp *const r = (struct regexp *)SvANY(rx);
11664     regexp_internal *reti;
11665     int len, npar;
11666     RXi_GET_DECL(r,ri);
11667
11668     PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
11669     
11670     npar = r->nparens+1;
11671     len = ProgLen(ri);
11672     
11673     Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode), char, regexp_internal);
11674     Copy(ri->program, reti->program, len+1, regnode);
11675     
11676
11677     reti->regstclass = NULL;
11678
11679     if (ri->data) {
11680         struct reg_data *d;
11681         const int count = ri->data->count;
11682         int i;
11683
11684         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
11685                 char, struct reg_data);
11686         Newx(d->what, count, U8);
11687
11688         d->count = count;
11689         for (i = 0; i < count; i++) {
11690             d->what[i] = ri->data->what[i];
11691             switch (d->what[i]) {
11692                 /* legal options are one of: sSfpontTua
11693                    see also regcomp.h and pregfree() */
11694             case 'a': /* actually an AV, but the dup function is identical.  */
11695             case 's':
11696             case 'S':
11697             case 'p': /* actually an AV, but the dup function is identical.  */
11698             case 'u': /* actually an HV, but the dup function is identical.  */
11699                 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
11700                 break;
11701             case 'f':
11702                 /* This is cheating. */
11703                 Newx(d->data[i], 1, struct regnode_charclass_class);
11704                 StructCopy(ri->data->data[i], d->data[i],
11705                             struct regnode_charclass_class);
11706                 reti->regstclass = (regnode*)d->data[i];
11707                 break;
11708             case 'o':
11709                 /* Compiled op trees are readonly and in shared memory,
11710                    and can thus be shared without duplication. */
11711                 OP_REFCNT_LOCK;
11712                 d->data[i] = (void*)OpREFCNT_inc((OP*)ri->data->data[i]);
11713                 OP_REFCNT_UNLOCK;
11714                 break;
11715             case 'T':
11716                 /* Trie stclasses are readonly and can thus be shared
11717                  * without duplication. We free the stclass in pregfree
11718                  * when the corresponding reg_ac_data struct is freed.
11719                  */
11720                 reti->regstclass= ri->regstclass;
11721                 /* Fall through */
11722             case 't':
11723                 OP_REFCNT_LOCK;
11724                 ((reg_trie_data*)ri->data->data[i])->refcount++;
11725                 OP_REFCNT_UNLOCK;
11726                 /* Fall through */
11727             case 'n':
11728                 d->data[i] = ri->data->data[i];
11729                 break;
11730             default:
11731                 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", ri->data->what[i]);
11732             }
11733         }
11734
11735         reti->data = d;
11736     }
11737     else
11738         reti->data = NULL;
11739
11740     reti->name_list_idx = ri->name_list_idx;
11741
11742 #ifdef RE_TRACK_PATTERN_OFFSETS
11743     if (ri->u.offsets) {
11744         Newx(reti->u.offsets, 2*len+1, U32);
11745         Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
11746     }
11747 #else
11748     SetProgLen(reti,len);
11749 #endif
11750
11751     return (void*)reti;
11752 }
11753
11754 #endif    /* USE_ITHREADS */
11755
11756 #ifndef PERL_IN_XSUB_RE
11757
11758 /*
11759  - regnext - dig the "next" pointer out of a node
11760  */
11761 regnode *
11762 Perl_regnext(pTHX_ register regnode *p)
11763 {
11764     dVAR;
11765     register I32 offset;
11766
11767     if (!p)
11768         return(NULL);
11769
11770     if (OP(p) > REGNODE_MAX) {          /* regnode.type is unsigned */
11771         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(p), (int)REGNODE_MAX);
11772     }
11773
11774     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
11775     if (offset == 0)
11776         return(NULL);
11777
11778     return(p+offset);
11779 }
11780 #endif
11781
11782 STATIC void     
11783 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
11784 {
11785     va_list args;
11786     STRLEN l1 = strlen(pat1);
11787     STRLEN l2 = strlen(pat2);
11788     char buf[512];
11789     SV *msv;
11790     const char *message;
11791
11792     PERL_ARGS_ASSERT_RE_CROAK2;
11793
11794     if (l1 > 510)
11795         l1 = 510;
11796     if (l1 + l2 > 510)
11797         l2 = 510 - l1;
11798     Copy(pat1, buf, l1 , char);
11799     Copy(pat2, buf + l1, l2 , char);
11800     buf[l1 + l2] = '\n';
11801     buf[l1 + l2 + 1] = '\0';
11802 #ifdef I_STDARG
11803     /* ANSI variant takes additional second argument */
11804     va_start(args, pat2);
11805 #else
11806     va_start(args);
11807 #endif
11808     msv = vmess(buf, &args);
11809     va_end(args);
11810     message = SvPV_const(msv,l1);
11811     if (l1 > 512)
11812         l1 = 512;
11813     Copy(message, buf, l1 , char);
11814     buf[l1-1] = '\0';                   /* Overwrite \n */
11815     Perl_croak(aTHX_ "%s", buf);
11816 }
11817
11818 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
11819
11820 #ifndef PERL_IN_XSUB_RE
11821 void
11822 Perl_save_re_context(pTHX)
11823 {
11824     dVAR;
11825
11826     struct re_save_state *state;
11827
11828     SAVEVPTR(PL_curcop);
11829     SSGROW(SAVESTACK_ALLOC_FOR_RE_SAVE_STATE + 1);
11830
11831     state = (struct re_save_state *)(PL_savestack + PL_savestack_ix);
11832     PL_savestack_ix += SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
11833     SSPUSHUV(SAVEt_RE_STATE);
11834
11835     Copy(&PL_reg_state, state, 1, struct re_save_state);
11836
11837     PL_reg_start_tmp = 0;
11838     PL_reg_start_tmpl = 0;
11839     PL_reg_oldsaved = NULL;
11840     PL_reg_oldsavedlen = 0;
11841     PL_reg_maxiter = 0;
11842     PL_reg_leftiter = 0;
11843     PL_reg_poscache = NULL;
11844     PL_reg_poscache_size = 0;
11845 #ifdef PERL_OLD_COPY_ON_WRITE
11846     PL_nrs = NULL;
11847 #endif
11848
11849     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
11850     if (PL_curpm) {
11851         const REGEXP * const rx = PM_GETRE(PL_curpm);
11852         if (rx) {
11853             U32 i;
11854             for (i = 1; i <= RX_NPARENS(rx); i++) {
11855                 char digits[TYPE_CHARS(long)];
11856                 const STRLEN len = my_snprintf(digits, sizeof(digits), "%lu", (long)i);
11857                 GV *const *const gvp
11858                     = (GV**)hv_fetch(PL_defstash, digits, len, 0);
11859
11860                 if (gvp) {
11861                     GV * const gv = *gvp;
11862                     if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
11863                         save_scalar(gv);
11864                 }
11865             }
11866         }
11867     }
11868 }
11869 #endif
11870
11871 static void
11872 clear_re(pTHX_ void *r)
11873 {
11874     dVAR;
11875     ReREFCNT_dec((REGEXP *)r);
11876 }
11877
11878 #ifdef DEBUGGING
11879
11880 STATIC void
11881 S_put_byte(pTHX_ SV *sv, int c)
11882 {
11883     PERL_ARGS_ASSERT_PUT_BYTE;
11884
11885     /* Our definition of isPRINT() ignores locales, so only bytes that are
11886        not part of UTF-8 are considered printable. I assume that the same
11887        holds for UTF-EBCDIC.
11888        Also, code point 255 is not printable in either (it's E0 in EBCDIC,
11889        which Wikipedia says:
11890
11891        EO, or Eight Ones, is an 8-bit EBCDIC character code represented as all
11892        ones (binary 1111 1111, hexadecimal FF). It is similar, but not
11893        identical, to the ASCII delete (DEL) or rubout control character.
11894        ) So the old condition can be simplified to !isPRINT(c)  */
11895     if (!isPRINT(c)) {
11896         if (c < 256) {
11897             Perl_sv_catpvf(aTHX_ sv, "\\x%02x", c);
11898         }
11899         else {
11900             Perl_sv_catpvf(aTHX_ sv, "\\x{%x}", c);
11901         }
11902     }
11903     else {
11904         const char string = c;
11905         if (c == '-' || c == ']' || c == '\\' || c == '^')
11906             sv_catpvs(sv, "\\");
11907         sv_catpvn(sv, &string, 1);
11908     }
11909 }
11910
11911
11912 #define CLEAR_OPTSTART \
11913     if (optstart) STMT_START { \
11914             DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%"IVdf" nodes)\n", (IV)(node - optstart))); \
11915             optstart=NULL; \
11916     } STMT_END
11917
11918 #define DUMPUNTIL(b,e) CLEAR_OPTSTART; node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
11919
11920 STATIC const regnode *
11921 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
11922             const regnode *last, const regnode *plast, 
11923             SV* sv, I32 indent, U32 depth)
11924 {
11925     dVAR;
11926     register U8 op = PSEUDO;    /* Arbitrary non-END op. */
11927     register const regnode *next;
11928     const regnode *optstart= NULL;
11929     
11930     RXi_GET_DECL(r,ri);
11931     GET_RE_DEBUG_FLAGS_DECL;
11932
11933     PERL_ARGS_ASSERT_DUMPUNTIL;
11934
11935 #ifdef DEBUG_DUMPUNTIL
11936     PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
11937         last ? last-start : 0,plast ? plast-start : 0);
11938 #endif
11939             
11940     if (plast && plast < last) 
11941         last= plast;
11942
11943     while (PL_regkind[op] != END && (!last || node < last)) {
11944         /* While that wasn't END last time... */
11945         NODE_ALIGN(node);
11946         op = OP(node);
11947         if (op == CLOSE || op == WHILEM)
11948             indent--;
11949         next = regnext((regnode *)node);
11950
11951         /* Where, what. */
11952         if (OP(node) == OPTIMIZED) {
11953             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
11954                 optstart = node;
11955             else
11956                 goto after_print;
11957         } else
11958             CLEAR_OPTSTART;
11959         
11960         regprop(r, sv, node);
11961         PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
11962                       (int)(2*indent + 1), "", SvPVX_const(sv));
11963         
11964         if (OP(node) != OPTIMIZED) {                  
11965             if (next == NULL)           /* Next ptr. */
11966                 PerlIO_printf(Perl_debug_log, " (0)");
11967             else if (PL_regkind[(U8)op] == BRANCH && PL_regkind[OP(next)] != BRANCH )
11968                 PerlIO_printf(Perl_debug_log, " (FAIL)");
11969             else 
11970                 PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start));
11971             (void)PerlIO_putc(Perl_debug_log, '\n'); 
11972         }
11973         
11974       after_print:
11975         if (PL_regkind[(U8)op] == BRANCHJ) {
11976             assert(next);
11977             {
11978                 register const regnode *nnode = (OP(next) == LONGJMP
11979                                              ? regnext((regnode *)next)
11980                                              : next);
11981                 if (last && nnode > last)
11982                     nnode = last;
11983                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
11984             }
11985         }
11986         else if (PL_regkind[(U8)op] == BRANCH) {
11987             assert(next);
11988             DUMPUNTIL(NEXTOPER(node), next);
11989         }
11990         else if ( PL_regkind[(U8)op]  == TRIE ) {
11991             const regnode *this_trie = node;
11992             const char op = OP(node);
11993             const U32 n = ARG(node);
11994             const reg_ac_data * const ac = op>=AHOCORASICK ?
11995                (reg_ac_data *)ri->data->data[n] :
11996                NULL;
11997             const reg_trie_data * const trie =
11998                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
11999 #ifdef DEBUGGING
12000             AV *const trie_words = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
12001 #endif
12002             const regnode *nextbranch= NULL;
12003             I32 word_idx;
12004             sv_setpvs(sv, "");
12005             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
12006                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
12007                 
12008                 PerlIO_printf(Perl_debug_log, "%*s%s ",
12009                    (int)(2*(indent+3)), "",
12010                     elem_ptr ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60,
12011                             PL_colors[0], PL_colors[1],
12012                             (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) |
12013                             PERL_PV_PRETTY_ELLIPSES    |
12014                             PERL_PV_PRETTY_LTGT
12015                             )
12016                             : "???"
12017                 );
12018                 if (trie->jump) {
12019                     U16 dist= trie->jump[word_idx+1];
12020                     PerlIO_printf(Perl_debug_log, "(%"UVuf")\n",
12021                                   (UV)((dist ? this_trie + dist : next) - start));
12022                     if (dist) {
12023                         if (!nextbranch)
12024                             nextbranch= this_trie + trie->jump[0];    
12025                         DUMPUNTIL(this_trie + dist, nextbranch);
12026                     }
12027                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
12028                         nextbranch= regnext((regnode *)nextbranch);
12029                 } else {
12030                     PerlIO_printf(Perl_debug_log, "\n");
12031                 }
12032             }
12033             if (last && next > last)
12034                 node= last;
12035             else
12036                 node= next;
12037         }
12038         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
12039             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
12040                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
12041         }
12042         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
12043             assert(next);
12044             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
12045         }
12046         else if ( op == PLUS || op == STAR) {
12047             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
12048         }
12049         else if (PL_regkind[(U8)op] == ANYOF) {
12050             /* arglen 1 + class block */
12051             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_CLASS)
12052                     ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
12053             node = NEXTOPER(node);
12054         }
12055         else if (PL_regkind[(U8)op] == EXACT) {
12056             /* Literal string, where present. */
12057             node += NODE_SZ_STR(node) - 1;
12058             node = NEXTOPER(node);
12059         }
12060         else {
12061             node = NEXTOPER(node);
12062             node += regarglen[(U8)op];
12063         }
12064         if (op == CURLYX || op == OPEN)
12065             indent++;
12066     }
12067     CLEAR_OPTSTART;
12068 #ifdef DEBUG_DUMPUNTIL    
12069     PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent);
12070 #endif
12071     return node;
12072 }
12073
12074 #endif  /* DEBUGGING */
12075
12076 /*
12077  * Local variables:
12078  * c-indentation-style: bsd
12079  * c-basic-offset: 4
12080  * indent-tabs-mode: t
12081  * End:
12082  *
12083  * ex: set ts=8 sts=4 sw=4 noet:
12084  */