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