This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Rmv unused regex implementation structure element
[perl5.git] / 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 "INTERN.h"
79 #endif
80
81 #define REG_COMP_C
82 #ifdef PERL_IN_XSUB_RE
83 #  include "re_comp.h"
84 EXTERN_C const struct regexp_engine my_reg_engine;
85 #else
86 #  include "regcomp.h"
87 #endif
88
89 #include "dquote_inline.h"
90 #include "invlist_inline.h"
91 #include "unicode_constants.h"
92
93 #define HAS_NONLATIN1_FOLD_CLOSURE(i) \
94  _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
95 #define HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE(i) \
96  _HAS_NONLATIN1_SIMPLE_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
97 #define IS_NON_FINAL_FOLD(c) _IS_NON_FINAL_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
98 #define IS_IN_SOME_FOLD_L1(c) _IS_IN_SOME_FOLD_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
99
100 #ifndef STATIC
101 #define STATIC  static
102 #endif
103
104 /* this is a chain of data about sub patterns we are processing that
105    need to be handled separately/specially in study_chunk. Its so
106    we can simulate recursion without losing state.  */
107 struct scan_frame;
108 typedef struct scan_frame {
109     regnode *last_regnode;      /* last node to process in this frame */
110     regnode *next_regnode;      /* next node to process when last is reached */
111     U32 prev_recursed_depth;
112     I32 stopparen;              /* what stopparen do we use */
113     U32 is_top_frame;           /* what flags do we use? */
114
115     struct scan_frame *this_prev_frame; /* this previous frame */
116     struct scan_frame *prev_frame;      /* previous frame */
117     struct scan_frame *next_frame;      /* next frame */
118 } scan_frame;
119
120 /* Certain characters are output as a sequence with the first being a
121  * backslash. */
122 #define isBACKSLASHED_PUNCT(c)                                              \
123                     ((c) == '-' || (c) == ']' || (c) == '\\' || (c) == '^')
124
125
126 struct RExC_state_t {
127     U32         flags;                  /* RXf_* are we folding, multilining? */
128     U32         pm_flags;               /* PMf_* stuff from the calling PMOP */
129     char        *precomp;               /* uncompiled string. */
130     char        *precomp_end;           /* pointer to end of uncompiled string. */
131     REGEXP      *rx_sv;                 /* The SV that is the regexp. */
132     regexp      *rx;                    /* perl core regexp structure */
133     regexp_internal     *rxi;           /* internal data for regexp object
134                                            pprivate field */
135     char        *start;                 /* Start of input for compile */
136     char        *end;                   /* End of input for compile */
137     char        *parse;                 /* Input-scan pointer. */
138     char        *adjusted_start;        /* 'start', adjusted.  See code use */
139     STRLEN      precomp_adj;            /* an offset beyond precomp.  See code use */
140     SSize_t     whilem_seen;            /* number of WHILEM in this expr */
141     regnode     *emit_start;            /* Start of emitted-code area */
142     regnode     *emit_bound;            /* First regnode outside of the
143                                            allocated space */
144     regnode     *emit;                  /* Code-emit pointer; if = &emit_dummy,
145                                            implies compiling, so don't emit */
146     regnode_ssc emit_dummy;             /* placeholder for emit to point to;
147                                            large enough for the largest
148                                            non-EXACTish node, so can use it as
149                                            scratch in pass1 */
150     I32         naughty;                /* How bad is this pattern? */
151     I32         sawback;                /* Did we see \1, ...? */
152     U32         seen;
153     SSize_t     size;                   /* Code size. */
154     I32                npar;            /* Capture buffer count, (OPEN) plus
155                                            one. ("par" 0 is the whole
156                                            pattern)*/
157     I32         nestroot;               /* root parens we are in - used by
158                                            accept */
159     I32         extralen;
160     I32         seen_zerolen;
161     regnode     **open_parens;          /* pointers to open parens */
162     regnode     **close_parens;         /* pointers to close parens */
163     regnode     *end_op;                /* END node in program */
164     I32         utf8;           /* whether the pattern is utf8 or not */
165     I32         orig_utf8;      /* whether the pattern was originally in utf8 */
166                                 /* XXX use this for future optimisation of case
167                                  * where pattern must be upgraded to utf8. */
168     I32         uni_semantics;  /* If a d charset modifier should use unicode
169                                    rules, even if the pattern is not in
170                                    utf8 */
171     HV          *paren_names;           /* Paren names */
172
173     regnode     **recurse;              /* Recurse regops */
174     I32                recurse_count;                /* Number of recurse regops we have generated */
175     U8          *study_chunk_recursed;  /* bitmap of which subs we have moved
176                                            through */
177     U32         study_chunk_recursed_bytes;  /* bytes in bitmap */
178     I32         in_lookbehind;
179     I32         contains_locale;
180     I32         override_recoding;
181 #ifdef EBCDIC
182     I32         recode_x_to_native;
183 #endif
184     I32         in_multi_char_class;
185     struct reg_code_block *code_blocks; /* positions of literal (?{})
186                                             within pattern */
187     int         num_code_blocks;        /* size of code_blocks[] */
188     int         code_index;             /* next code_blocks[] slot */
189     SSize_t     maxlen;                        /* mininum possible number of chars in string to match */
190     scan_frame *frame_head;
191     scan_frame *frame_last;
192     U32         frame_count;
193     AV         *warn_text;
194 #ifdef ADD_TO_REGEXEC
195     char        *starttry;              /* -Dr: where regtry was called. */
196 #define RExC_starttry   (pRExC_state->starttry)
197 #endif
198     SV          *runtime_code_qr;       /* qr with the runtime code blocks */
199 #ifdef DEBUGGING
200     const char  *lastparse;
201     I32         lastnum;
202     AV          *paren_name_list;       /* idx -> name */
203     U32         study_chunk_recursed_count;
204     SV          *mysv1;
205     SV          *mysv2;
206 #define RExC_lastparse  (pRExC_state->lastparse)
207 #define RExC_lastnum    (pRExC_state->lastnum)
208 #define RExC_paren_name_list    (pRExC_state->paren_name_list)
209 #define RExC_study_chunk_recursed_count    (pRExC_state->study_chunk_recursed_count)
210 #define RExC_mysv       (pRExC_state->mysv1)
211 #define RExC_mysv1      (pRExC_state->mysv1)
212 #define RExC_mysv2      (pRExC_state->mysv2)
213
214 #endif
215     bool        seen_unfolded_sharp_s;
216     bool        strict;
217     bool        study_started;
218 };
219
220 #define RExC_flags      (pRExC_state->flags)
221 #define RExC_pm_flags   (pRExC_state->pm_flags)
222 #define RExC_precomp    (pRExC_state->precomp)
223 #define RExC_precomp_adj (pRExC_state->precomp_adj)
224 #define RExC_adjusted_start  (pRExC_state->adjusted_start)
225 #define RExC_precomp_end (pRExC_state->precomp_end)
226 #define RExC_rx_sv      (pRExC_state->rx_sv)
227 #define RExC_rx         (pRExC_state->rx)
228 #define RExC_rxi        (pRExC_state->rxi)
229 #define RExC_start      (pRExC_state->start)
230 #define RExC_end        (pRExC_state->end)
231 #define RExC_parse      (pRExC_state->parse)
232 #define RExC_whilem_seen        (pRExC_state->whilem_seen)
233
234 /* Set during the sizing pass when there is a LATIN SMALL LETTER SHARP S in any
235  * EXACTF node, hence was parsed under /di rules.  If later in the parse,
236  * something forces the pattern into using /ui rules, the sharp s should be
237  * folded into the sequence 'ss', which takes up more space than previously
238  * calculated.  This means that the sizing pass needs to be restarted.  (The
239  * node also becomes an EXACTFU_SS.)  For all other characters, an EXACTF node
240  * that gets converted to /ui (and EXACTFU) occupies the same amount of space,
241  * so there is no need to resize [perl #125990]. */
242 #define RExC_seen_unfolded_sharp_s (pRExC_state->seen_unfolded_sharp_s)
243
244 #ifdef RE_TRACK_PATTERN_OFFSETS
245 #define RExC_offsets    (pRExC_state->rxi->u.offsets) /* I am not like the
246                                                          others */
247 #endif
248 #define RExC_emit       (pRExC_state->emit)
249 #define RExC_emit_dummy (pRExC_state->emit_dummy)
250 #define RExC_emit_start (pRExC_state->emit_start)
251 #define RExC_emit_bound (pRExC_state->emit_bound)
252 #define RExC_sawback    (pRExC_state->sawback)
253 #define RExC_seen       (pRExC_state->seen)
254 #define RExC_size       (pRExC_state->size)
255 #define RExC_maxlen        (pRExC_state->maxlen)
256 #define RExC_npar       (pRExC_state->npar)
257 #define RExC_nestroot   (pRExC_state->nestroot)
258 #define RExC_extralen   (pRExC_state->extralen)
259 #define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
260 #define RExC_utf8       (pRExC_state->utf8)
261 #define RExC_uni_semantics      (pRExC_state->uni_semantics)
262 #define RExC_orig_utf8  (pRExC_state->orig_utf8)
263 #define RExC_open_parens        (pRExC_state->open_parens)
264 #define RExC_close_parens       (pRExC_state->close_parens)
265 #define RExC_end_op     (pRExC_state->end_op)
266 #define RExC_paren_names        (pRExC_state->paren_names)
267 #define RExC_recurse    (pRExC_state->recurse)
268 #define RExC_recurse_count      (pRExC_state->recurse_count)
269 #define RExC_study_chunk_recursed        (pRExC_state->study_chunk_recursed)
270 #define RExC_study_chunk_recursed_bytes  \
271                                    (pRExC_state->study_chunk_recursed_bytes)
272 #define RExC_in_lookbehind      (pRExC_state->in_lookbehind)
273 #define RExC_contains_locale    (pRExC_state->contains_locale)
274 #define RExC_override_recoding (pRExC_state->override_recoding)
275 #ifdef EBCDIC
276 #   define RExC_recode_x_to_native (pRExC_state->recode_x_to_native)
277 #endif
278 #define RExC_in_multi_char_class (pRExC_state->in_multi_char_class)
279 #define RExC_frame_head (pRExC_state->frame_head)
280 #define RExC_frame_last (pRExC_state->frame_last)
281 #define RExC_frame_count (pRExC_state->frame_count)
282 #define RExC_strict (pRExC_state->strict)
283 #define RExC_study_started      (pRExC_state->study_started)
284 #define RExC_warn_text (pRExC_state->warn_text)
285
286 /* Heuristic check on the complexity of the pattern: if TOO_NAUGHTY, we set
287  * a flag to disable back-off on the fixed/floating substrings - if it's
288  * a high complexity pattern we assume the benefit of avoiding a full match
289  * is worth the cost of checking for the substrings even if they rarely help.
290  */
291 #define RExC_naughty    (pRExC_state->naughty)
292 #define TOO_NAUGHTY (10)
293 #define MARK_NAUGHTY(add) \
294     if (RExC_naughty < TOO_NAUGHTY) \
295         RExC_naughty += (add)
296 #define MARK_NAUGHTY_EXP(exp, add) \
297     if (RExC_naughty < TOO_NAUGHTY) \
298         RExC_naughty += RExC_naughty / (exp) + (add)
299
300 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
301 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
302         ((*s) == '{' && regcurly(s)))
303
304 /*
305  * Flags to be passed up and down.
306  */
307 #define WORST           0       /* Worst case. */
308 #define HASWIDTH        0x01    /* Known to match non-null strings. */
309
310 /* Simple enough to be STAR/PLUS operand; in an EXACTish node must be a single
311  * character.  (There needs to be a case: in the switch statement in regexec.c
312  * for any node marked SIMPLE.)  Note that this is not the same thing as
313  * REGNODE_SIMPLE */
314 #define SIMPLE          0x02
315 #define SPSTART         0x04    /* Starts with * or + */
316 #define POSTPONED       0x08    /* (?1),(?&name), (??{...}) or similar */
317 #define TRYAGAIN        0x10    /* Weeded out a declaration. */
318 #define RESTART_PASS1   0x20    /* Need to restart sizing pass */
319 #define NEED_UTF8       0x40    /* In conjunction with RESTART_PASS1, need to
320                                    calcuate sizes as UTF-8 */
321
322 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
323
324 /* whether trie related optimizations are enabled */
325 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
326 #define TRIE_STUDY_OPT
327 #define FULL_TRIE_STUDY
328 #define TRIE_STCLASS
329 #endif
330
331
332
333 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
334 #define PBITVAL(paren) (1 << ((paren) & 7))
335 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
336 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
337 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
338
339 #define REQUIRE_UTF8(flagp) STMT_START {                                   \
340                                      if (!UTF) {                           \
341                                          assert(PASS1);                    \
342                                          *flagp = RESTART_PASS1|NEED_UTF8; \
343                                          return NULL;                      \
344                                      }                                     \
345                              } STMT_END
346
347 /* Change from /d into /u rules, and restart the parse if we've already seen
348  * something whose size would increase as a result, by setting *flagp and
349  * returning 'restart_retval'.  RExC_uni_semantics is a flag that indicates
350  * we've change to /u during the parse.  */
351 #define REQUIRE_UNI_RULES(flagp, restart_retval)                            \
352     STMT_START {                                                            \
353             if (DEPENDS_SEMANTICS) {                                        \
354                 assert(PASS1);                                              \
355                 set_regex_charset(&RExC_flags, REGEX_UNICODE_CHARSET);      \
356                 RExC_uni_semantics = 1;                                     \
357                 if (RExC_seen_unfolded_sharp_s) {                           \
358                     *flagp |= RESTART_PASS1;                                \
359                     return restart_retval;                                  \
360                 }                                                           \
361             }                                                               \
362     } STMT_END
363
364 /* This converts the named class defined in regcomp.h to its equivalent class
365  * number defined in handy.h. */
366 #define namedclass_to_classnum(class)  ((int) ((class) / 2))
367 #define classnum_to_namedclass(classnum)  ((classnum) * 2)
368
369 #define _invlist_union_complement_2nd(a, b, output) \
370                         _invlist_union_maybe_complement_2nd(a, b, TRUE, output)
371 #define _invlist_intersection_complement_2nd(a, b, output) \
372                  _invlist_intersection_maybe_complement_2nd(a, b, TRUE, output)
373
374 /* About scan_data_t.
375
376   During optimisation we recurse through the regexp program performing
377   various inplace (keyhole style) optimisations. In addition study_chunk
378   and scan_commit populate this data structure with information about
379   what strings MUST appear in the pattern. We look for the longest
380   string that must appear at a fixed location, and we look for the
381   longest string that may appear at a floating location. So for instance
382   in the pattern:
383
384     /FOO[xX]A.*B[xX]BAR/
385
386   Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
387   strings (because they follow a .* construct). study_chunk will identify
388   both FOO and BAR as being the longest fixed and floating strings respectively.
389
390   The strings can be composites, for instance
391
392      /(f)(o)(o)/
393
394   will result in a composite fixed substring 'foo'.
395
396   For each string some basic information is maintained:
397
398   - offset or min_offset
399     This is the position the string must appear at, or not before.
400     It also implicitly (when combined with minlenp) tells us how many
401     characters must match before the string we are searching for.
402     Likewise when combined with minlenp and the length of the string it
403     tells us how many characters must appear after the string we have
404     found.
405
406   - max_offset
407     Only used for floating strings. This is the rightmost point that
408     the string can appear at. If set to SSize_t_MAX it indicates that the
409     string can occur infinitely far to the right.
410
411   - minlenp
412     A pointer to the minimum number of characters of the pattern that the
413     string was found inside. This is important as in the case of positive
414     lookahead or positive lookbehind we can have multiple patterns
415     involved. Consider
416
417     /(?=FOO).*F/
418
419     The minimum length of the pattern overall is 3, the minimum length
420     of the lookahead part is 3, but the minimum length of the part that
421     will actually match is 1. So 'FOO's minimum length is 3, but the
422     minimum length for the F is 1. This is important as the minimum length
423     is used to determine offsets in front of and behind the string being
424     looked for.  Since strings can be composites this is the length of the
425     pattern at the time it was committed with a scan_commit. Note that
426     the length is calculated by study_chunk, so that the minimum lengths
427     are not known until the full pattern has been compiled, thus the
428     pointer to the value.
429
430   - lookbehind
431
432     In the case of lookbehind the string being searched for can be
433     offset past the start point of the final matching string.
434     If this value was just blithely removed from the min_offset it would
435     invalidate some of the calculations for how many chars must match
436     before or after (as they are derived from min_offset and minlen and
437     the length of the string being searched for).
438     When the final pattern is compiled and the data is moved from the
439     scan_data_t structure into the regexp structure the information
440     about lookbehind is factored in, with the information that would
441     have been lost precalculated in the end_shift field for the
442     associated string.
443
444   The fields pos_min and pos_delta are used to store the minimum offset
445   and the delta to the maximum offset at the current point in the pattern.
446
447 */
448
449 typedef struct scan_data_t {
450     /*I32 len_min;      unused */
451     /*I32 len_delta;    unused */
452     SSize_t pos_min;
453     SSize_t pos_delta;
454     SV *last_found;
455     SSize_t last_end;       /* min value, <0 unless valid. */
456     SSize_t last_start_min;
457     SSize_t last_start_max;
458     SV **longest;           /* Either &l_fixed, or &l_float. */
459     SV *longest_fixed;      /* longest fixed string found in pattern */
460     SSize_t offset_fixed;   /* offset where it starts */
461     SSize_t *minlen_fixed;  /* pointer to the minlen relevant to the string */
462     I32 lookbehind_fixed;   /* is the position of the string modfied by LB */
463     SV *longest_float;      /* longest floating string found in pattern */
464     SSize_t offset_float_min; /* earliest point in string it can appear */
465     SSize_t offset_float_max; /* latest point in string it can appear */
466     SSize_t *minlen_float;  /* pointer to the minlen relevant to the string */
467     SSize_t lookbehind_float; /* is the pos of the string modified by LB */
468     I32 flags;
469     I32 whilem_c;
470     SSize_t *last_closep;
471     regnode_ssc *start_class;
472 } scan_data_t;
473
474 /*
475  * Forward declarations for pregcomp()'s friends.
476  */
477
478 static const scan_data_t zero_scan_data =
479   { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,0};
480
481 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
482 #define SF_BEFORE_SEOL          0x0001
483 #define SF_BEFORE_MEOL          0x0002
484 #define SF_FIX_BEFORE_EOL       (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
485 #define SF_FL_BEFORE_EOL        (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
486
487 #define SF_FIX_SHIFT_EOL        (+2)
488 #define SF_FL_SHIFT_EOL         (+4)
489
490 #define SF_FIX_BEFORE_SEOL      (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
491 #define SF_FIX_BEFORE_MEOL      (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
492
493 #define SF_FL_BEFORE_SEOL       (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
494 #define SF_FL_BEFORE_MEOL       (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
495 #define SF_IS_INF               0x0040
496 #define SF_HAS_PAR              0x0080
497 #define SF_IN_PAR               0x0100
498 #define SF_HAS_EVAL             0x0200
499
500
501 /* SCF_DO_SUBSTR is the flag that tells the regexp analyzer to track the
502  * longest substring in the pattern. When it is not set the optimiser keeps
503  * track of position, but does not keep track of the actual strings seen,
504  *
505  * So for instance /foo/ will be parsed with SCF_DO_SUBSTR being true, but
506  * /foo/i will not.
507  *
508  * Similarly, /foo.*(blah|erm|huh).*fnorble/ will have "foo" and "fnorble"
509  * parsed with SCF_DO_SUBSTR on, but while processing the (...) it will be
510  * turned off because of the alternation (BRANCH). */
511 #define SCF_DO_SUBSTR           0x0400
512
513 #define SCF_DO_STCLASS_AND      0x0800
514 #define SCF_DO_STCLASS_OR       0x1000
515 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
516 #define SCF_WHILEM_VISITED_POS  0x2000
517
518 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
519 #define SCF_SEEN_ACCEPT         0x8000
520 #define SCF_TRIE_DOING_RESTUDY 0x10000
521 #define SCF_IN_DEFINE          0x20000
522
523
524
525
526 #define UTF cBOOL(RExC_utf8)
527
528 /* The enums for all these are ordered so things work out correctly */
529 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
530 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags)                    \
531                                                      == REGEX_DEPENDS_CHARSET)
532 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
533 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags)                \
534                                                      >= REGEX_UNICODE_CHARSET)
535 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags)                      \
536                                             == REGEX_ASCII_RESTRICTED_CHARSET)
537 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags)             \
538                                             >= REGEX_ASCII_RESTRICTED_CHARSET)
539 #define ASCII_FOLD_RESTRICTED (get_regex_charset(RExC_flags)                 \
540                                         == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
541
542 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
543
544 /* For programs that want to be strictly Unicode compatible by dying if any
545  * attempt is made to match a non-Unicode code point against a Unicode
546  * property.  */
547 #define ALWAYS_WARN_SUPER  ckDEAD(packWARN(WARN_NON_UNICODE))
548
549 #define OOB_NAMEDCLASS          -1
550
551 /* There is no code point that is out-of-bounds, so this is problematic.  But
552  * its only current use is to initialize a variable that is always set before
553  * looked at. */
554 #define OOB_UNICODE             0xDEADBEEF
555
556 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
557
558
559 /* length of regex to show in messages that don't mark a position within */
560 #define RegexLengthToShowInErrorMessages 127
561
562 /*
563  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
564  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
565  * op/pragma/warn/regcomp.
566  */
567 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
568 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
569
570 #define REPORT_LOCATION " in regex; marked by " MARKER1    \
571                         " in m/%" UTF8f MARKER2 "%" UTF8f "/"
572
573 /* The code in this file in places uses one level of recursion with parsing
574  * rebased to an alternate string constructed by us in memory.  This can take
575  * the form of something that is completely different from the input, or
576  * something that uses the input as part of the alternate.  In the first case,
577  * there should be no possibility of an error, as we are in complete control of
578  * the alternate string.  But in the second case we don't control the input
579  * portion, so there may be errors in that.  Here's an example:
580  *      /[abc\x{DF}def]/ui
581  * is handled specially because \x{df} folds to a sequence of more than one
582  * character, 'ss'.  What is done is to create and parse an alternate string,
583  * which looks like this:
584  *      /(?:\x{DF}|[abc\x{DF}def])/ui
585  * where it uses the input unchanged in the middle of something it constructs,
586  * which is a branch for the DF outside the character class, and clustering
587  * parens around the whole thing. (It knows enough to skip the DF inside the
588  * class while in this substitute parse.) 'abc' and 'def' may have errors that
589  * need to be reported.  The general situation looks like this:
590  *
591  *              sI                       tI               xI       eI
592  * Input:       ----------------------------------------------------
593  * Constructed:         ---------------------------------------------------
594  *                      sC               tC               xC       eC     EC
595  *
596  * The input string sI..eI is the input pattern.  The string sC..EC is the
597  * constructed substitute parse string.  The portions sC..tC and eC..EC are
598  * constructed by us.  The portion tC..eC is an exact duplicate of the input
599  * pattern tI..eI.  In the diagram, these are vertically aligned.  Suppose that
600  * while parsing, we find an error at xC.  We want to display a message showing
601  * the real input string.  Thus we need to find the point xI in it which
602  * corresponds to xC.  xC >= tC, since the portion of the string sC..tC has
603  * been constructed by us, and so shouldn't have errors.  We get:
604  *
605  *      xI = sI + (tI - sI) + (xC - tC)
606  *
607  * and, the offset into sI is:
608  *
609  *      (xI - sI) = (tI - sI) + (xC - tC)
610  *
611  * When the substitute is constructed, we save (tI -sI) as RExC_precomp_adj,
612  * and we save tC as RExC_adjusted_start.
613  *
614  * During normal processing of the input pattern, everything points to that,
615  * with RExC_precomp_adj set to 0, and RExC_adjusted_start set to sI.
616  */
617
618 #define tI_sI           RExC_precomp_adj
619 #define tC              RExC_adjusted_start
620 #define sC              RExC_precomp
621 #define xI_offset(xC)   ((IV) (tI_sI + (xC - tC)))
622 #define xI(xC)          (sC + xI_offset(xC))
623 #define eC              RExC_precomp_end
624
625 #define REPORT_LOCATION_ARGS(xC)                                            \
626     UTF8fARG(UTF,                                                           \
627              (xI(xC) > eC) /* Don't run off end */                          \
628               ? eC - sC   /* Length before the <--HERE */                   \
629               : xI_offset(xC),                                              \
630              sC),         /* The input pattern printed up to the <--HERE */ \
631     UTF8fARG(UTF,                                                           \
632              (xI(xC) > eC) ? 0 : eC - xI(xC), /* Length after <--HERE */    \
633              (xI(xC) > eC) ? eC : xI(xC))     /* pattern after <--HERE */
634
635 /* Used to point after bad bytes for an error message, but avoid skipping
636  * past a nul byte. */
637 #define SKIP_IF_CHAR(s) (!*(s) ? 0 : UTF ? UTF8SKIP(s) : 1)
638
639 /*
640  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
641  * arg. Show regex, up to a maximum length. If it's too long, chop and add
642  * "...".
643  */
644 #define _FAIL(code) STMT_START {                                        \
645     const char *ellipses = "";                                          \
646     IV len = RExC_precomp_end - RExC_precomp;                                   \
647                                                                         \
648     if (!SIZE_ONLY)                                                     \
649         SAVEFREESV(RExC_rx_sv);                                         \
650     if (len > RegexLengthToShowInErrorMessages) {                       \
651         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
652         len = RegexLengthToShowInErrorMessages - 10;                    \
653         ellipses = "...";                                               \
654     }                                                                   \
655     code;                                                               \
656 } STMT_END
657
658 #define FAIL(msg) _FAIL(                            \
659     Perl_croak(aTHX_ "%s in regex m/%" UTF8f "%s/",         \
660             msg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
661
662 #define FAIL2(msg,arg) _FAIL(                       \
663     Perl_croak(aTHX_ msg " in regex m/%" UTF8f "%s/",       \
664             arg, UTF8fARG(UTF, len, RExC_precomp), ellipses))
665
666 /*
667  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
668  */
669 #define Simple_vFAIL(m) STMT_START {                                    \
670     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
671             m, REPORT_LOCATION_ARGS(RExC_parse));                       \
672 } STMT_END
673
674 /*
675  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
676  */
677 #define vFAIL(m) STMT_START {                           \
678     if (!SIZE_ONLY)                                     \
679         SAVEFREESV(RExC_rx_sv);                         \
680     Simple_vFAIL(m);                                    \
681 } STMT_END
682
683 /*
684  * Like Simple_vFAIL(), but accepts two arguments.
685  */
686 #define Simple_vFAIL2(m,a1) STMT_START {                        \
687     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1,              \
688                       REPORT_LOCATION_ARGS(RExC_parse));        \
689 } STMT_END
690
691 /*
692  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
693  */
694 #define vFAIL2(m,a1) STMT_START {                       \
695     if (!SIZE_ONLY)                                     \
696         SAVEFREESV(RExC_rx_sv);                         \
697     Simple_vFAIL2(m, a1);                               \
698 } STMT_END
699
700
701 /*
702  * Like Simple_vFAIL(), but accepts three arguments.
703  */
704 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
705     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2,          \
706             REPORT_LOCATION_ARGS(RExC_parse));                  \
707 } STMT_END
708
709 /*
710  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
711  */
712 #define vFAIL3(m,a1,a2) STMT_START {                    \
713     if (!SIZE_ONLY)                                     \
714         SAVEFREESV(RExC_rx_sv);                         \
715     Simple_vFAIL3(m, a1, a2);                           \
716 } STMT_END
717
718 /*
719  * Like Simple_vFAIL(), but accepts four arguments.
720  */
721 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
722     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2, a3,      \
723             REPORT_LOCATION_ARGS(RExC_parse));                  \
724 } STMT_END
725
726 #define vFAIL4(m,a1,a2,a3) STMT_START {                 \
727     if (!SIZE_ONLY)                                     \
728         SAVEFREESV(RExC_rx_sv);                         \
729     Simple_vFAIL4(m, a1, a2, a3);                       \
730 } STMT_END
731
732 /* A specialized version of vFAIL2 that works with UTF8f */
733 #define vFAIL2utf8f(m, a1) STMT_START {             \
734     if (!SIZE_ONLY)                                 \
735         SAVEFREESV(RExC_rx_sv);                     \
736     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1,  \
737             REPORT_LOCATION_ARGS(RExC_parse));      \
738 } STMT_END
739
740 #define vFAIL3utf8f(m, a1, a2) STMT_START {             \
741     if (!SIZE_ONLY)                                     \
742         SAVEFREESV(RExC_rx_sv);                         \
743     S_re_croak2(aTHX_ UTF, m, REPORT_LOCATION, a1, a2,  \
744             REPORT_LOCATION_ARGS(RExC_parse));          \
745 } STMT_END
746
747 /* These have asserts in them because of [perl #122671] Many warnings in
748  * regcomp.c can occur twice.  If they get output in pass1 and later in that
749  * pass, the pattern has to be converted to UTF-8 and the pass restarted, they
750  * would get output again.  So they should be output in pass2, and these
751  * asserts make sure new warnings follow that paradigm. */
752
753 /* m is not necessarily a "literal string", in this macro */
754 #define reg_warn_non_literal_string(loc, m) STMT_START {                \
755     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
756                                        "%s" REPORT_LOCATION,            \
757                                   m, REPORT_LOCATION_ARGS(loc));        \
758 } STMT_END
759
760 #define ckWARNreg(loc,m) STMT_START {                                   \
761     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),        \
762                                           m REPORT_LOCATION,            \
763                                           REPORT_LOCATION_ARGS(loc));   \
764 } STMT_END
765
766 #define vWARN(loc, m) STMT_START {                                      \
767     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
768                                        m REPORT_LOCATION,               \
769                                        REPORT_LOCATION_ARGS(loc));      \
770 } STMT_END
771
772 #define vWARN_dep(loc, m) STMT_START {                                  \
773     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),       \
774                                        m REPORT_LOCATION,               \
775                                        REPORT_LOCATION_ARGS(loc));      \
776 } STMT_END
777
778 #define ckWARNdep(loc,m) STMT_START {                                   \
779     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),  \
780                                             m REPORT_LOCATION,          \
781                                             REPORT_LOCATION_ARGS(loc)); \
782 } STMT_END
783
784 #define ckWARNregdep(loc,m) STMT_START {                                    \
785     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED,      \
786                                                       WARN_REGEXP),         \
787                                              m REPORT_LOCATION,             \
788                                              REPORT_LOCATION_ARGS(loc));    \
789 } STMT_END
790
791 #define ckWARN2reg_d(loc,m, a1) STMT_START {                                \
792     __ASSERT_(PASS2) Perl_ck_warner_d(aTHX_ packWARN(WARN_REGEXP),          \
793                                             m REPORT_LOCATION,              \
794                                             a1, REPORT_LOCATION_ARGS(loc)); \
795 } STMT_END
796
797 #define ckWARN2reg(loc, m, a1) STMT_START {                                 \
798     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),            \
799                                           m REPORT_LOCATION,                \
800                                           a1, REPORT_LOCATION_ARGS(loc));   \
801 } STMT_END
802
803 #define vWARN3(loc, m, a1, a2) STMT_START {                                 \
804     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),               \
805                                        m REPORT_LOCATION,                   \
806                                        a1, a2, REPORT_LOCATION_ARGS(loc));  \
807 } STMT_END
808
809 #define ckWARN3reg(loc, m, a1, a2) STMT_START {                             \
810     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),            \
811                                           m REPORT_LOCATION,                \
812                                           a1, a2,                           \
813                                           REPORT_LOCATION_ARGS(loc));       \
814 } STMT_END
815
816 #define vWARN4(loc, m, a1, a2, a3) STMT_START {                         \
817     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
818                                        m REPORT_LOCATION,               \
819                                        a1, a2, a3,                      \
820                                        REPORT_LOCATION_ARGS(loc));      \
821 } STMT_END
822
823 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START {                     \
824     __ASSERT_(PASS2) Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP),        \
825                                           m REPORT_LOCATION,            \
826                                           a1, a2, a3,                   \
827                                           REPORT_LOCATION_ARGS(loc));   \
828 } STMT_END
829
830 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {                     \
831     __ASSERT_(PASS2) Perl_warner(aTHX_ packWARN(WARN_REGEXP),           \
832                                        m REPORT_LOCATION,               \
833                                        a1, a2, a3, a4,                  \
834                                        REPORT_LOCATION_ARGS(loc));      \
835 } STMT_END
836
837 /* Macros for recording node offsets.   20001227 mjd@plover.com
838  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
839  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
840  * Element 0 holds the number n.
841  * Position is 1 indexed.
842  */
843 #ifndef RE_TRACK_PATTERN_OFFSETS
844 #define Set_Node_Offset_To_R(node,byte)
845 #define Set_Node_Offset(node,byte)
846 #define Set_Cur_Node_Offset
847 #define Set_Node_Length_To_R(node,len)
848 #define Set_Node_Length(node,len)
849 #define Set_Node_Cur_Length(node,start)
850 #define Node_Offset(n)
851 #define Node_Length(n)
852 #define Set_Node_Offset_Length(node,offset,len)
853 #define ProgLen(ri) ri->u.proglen
854 #define SetProgLen(ri,x) ri->u.proglen = x
855 #else
856 #define ProgLen(ri) ri->u.offsets[0]
857 #define SetProgLen(ri,x) ri->u.offsets[0] = x
858 #define Set_Node_Offset_To_R(node,byte) STMT_START {                    \
859     if (! SIZE_ONLY) {                                                  \
860         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
861                     __LINE__, (int)(node), (int)(byte)));               \
862         if((node) < 0) {                                                \
863             Perl_croak(aTHX_ "value of node is %d in Offset macro",     \
864                                          (int)(node));                  \
865         } else {                                                        \
866             RExC_offsets[2*(node)-1] = (byte);                          \
867         }                                                               \
868     }                                                                   \
869 } STMT_END
870
871 #define Set_Node_Offset(node,byte) \
872     Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
873 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
874
875 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
876     if (! SIZE_ONLY) {                                                  \
877         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
878                 __LINE__, (int)(node), (int)(len)));                    \
879         if((node) < 0) {                                                \
880             Perl_croak(aTHX_ "value of node is %d in Length macro",     \
881                                          (int)(node));                  \
882         } else {                                                        \
883             RExC_offsets[2*(node)] = (len);                             \
884         }                                                               \
885     }                                                                   \
886 } STMT_END
887
888 #define Set_Node_Length(node,len) \
889     Set_Node_Length_To_R((node)-RExC_emit_start, len)
890 #define Set_Node_Cur_Length(node, start)                \
891     Set_Node_Length(node, RExC_parse - start)
892
893 /* Get offsets and lengths */
894 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
895 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
896
897 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
898     Set_Node_Offset_To_R((node)-RExC_emit_start, (offset));     \
899     Set_Node_Length_To_R((node)-RExC_emit_start, (len));        \
900 } STMT_END
901 #endif
902
903 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
904 #define EXPERIMENTAL_INPLACESCAN
905 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
906
907 #ifdef DEBUGGING
908 int
909 Perl_re_printf(pTHX_ const char *fmt, ...)
910 {
911     va_list ap;
912     int result;
913     PerlIO *f= Perl_debug_log;
914     PERL_ARGS_ASSERT_RE_PRINTF;
915     va_start(ap, fmt);
916     result = PerlIO_vprintf(f, fmt, ap);
917     va_end(ap);
918     return result;
919 }
920
921 int
922 Perl_re_indentf(pTHX_ const char *fmt, U32 depth, ...)
923 {
924     va_list ap;
925     int result;
926     PerlIO *f= Perl_debug_log;
927     PERL_ARGS_ASSERT_RE_INDENTF;
928     va_start(ap, depth);
929     PerlIO_printf(f, "%*s", ( (int)depth % 20 ) * 2, "");
930     result = PerlIO_vprintf(f, fmt, ap);
931     va_end(ap);
932     return result;
933 }
934 #endif /* DEBUGGING */
935
936 #define DEBUG_RExC_seen()                                                   \
937         DEBUG_OPTIMISE_MORE_r({                                             \
938             Perl_re_printf( aTHX_ "RExC_seen: ");                                       \
939                                                                             \
940             if (RExC_seen & REG_ZERO_LEN_SEEN)                              \
941                 Perl_re_printf( aTHX_ "REG_ZERO_LEN_SEEN ");                            \
942                                                                             \
943             if (RExC_seen & REG_LOOKBEHIND_SEEN)                            \
944                 Perl_re_printf( aTHX_ "REG_LOOKBEHIND_SEEN ");                          \
945                                                                             \
946             if (RExC_seen & REG_GPOS_SEEN)                                  \
947                 Perl_re_printf( aTHX_ "REG_GPOS_SEEN ");                                \
948                                                                             \
949             if (RExC_seen & REG_RECURSE_SEEN)                               \
950                 Perl_re_printf( aTHX_ "REG_RECURSE_SEEN ");                             \
951                                                                             \
952             if (RExC_seen & REG_TOP_LEVEL_BRANCHES_SEEN)                    \
953                 Perl_re_printf( aTHX_ "REG_TOP_LEVEL_BRANCHES_SEEN ");                  \
954                                                                             \
955             if (RExC_seen & REG_VERBARG_SEEN)                               \
956                 Perl_re_printf( aTHX_ "REG_VERBARG_SEEN ");                             \
957                                                                             \
958             if (RExC_seen & REG_CUTGROUP_SEEN)                              \
959                 Perl_re_printf( aTHX_ "REG_CUTGROUP_SEEN ");                            \
960                                                                             \
961             if (RExC_seen & REG_RUN_ON_COMMENT_SEEN)                        \
962                 Perl_re_printf( aTHX_ "REG_RUN_ON_COMMENT_SEEN ");                      \
963                                                                             \
964             if (RExC_seen & REG_UNFOLDED_MULTI_SEEN)                        \
965                 Perl_re_printf( aTHX_ "REG_UNFOLDED_MULTI_SEEN ");                      \
966                                                                             \
967             if (RExC_seen & REG_UNBOUNDED_QUANTIFIER_SEEN)                  \
968                 Perl_re_printf( aTHX_ "REG_UNBOUNDED_QUANTIFIER_SEEN ");                \
969                                                                             \
970             Perl_re_printf( aTHX_ "\n");                                                \
971         });
972
973 #define DEBUG_SHOW_STUDY_FLAG(flags,flag) \
974   if ((flags) & flag) Perl_re_printf( aTHX_  "%s ", #flag)
975
976 #define DEBUG_SHOW_STUDY_FLAGS(flags,open_str,close_str)                    \
977     if ( ( flags ) ) {                                                      \
978         Perl_re_printf( aTHX_  "%s", open_str);                                         \
979         DEBUG_SHOW_STUDY_FLAG(flags,SF_FL_BEFORE_SEOL);                     \
980         DEBUG_SHOW_STUDY_FLAG(flags,SF_FL_BEFORE_MEOL);                     \
981         DEBUG_SHOW_STUDY_FLAG(flags,SF_IS_INF);                             \
982         DEBUG_SHOW_STUDY_FLAG(flags,SF_HAS_PAR);                            \
983         DEBUG_SHOW_STUDY_FLAG(flags,SF_IN_PAR);                             \
984         DEBUG_SHOW_STUDY_FLAG(flags,SF_HAS_EVAL);                           \
985         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_SUBSTR);                         \
986         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_STCLASS_AND);                    \
987         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_STCLASS_OR);                     \
988         DEBUG_SHOW_STUDY_FLAG(flags,SCF_DO_STCLASS);                        \
989         DEBUG_SHOW_STUDY_FLAG(flags,SCF_WHILEM_VISITED_POS);                \
990         DEBUG_SHOW_STUDY_FLAG(flags,SCF_TRIE_RESTUDY);                      \
991         DEBUG_SHOW_STUDY_FLAG(flags,SCF_SEEN_ACCEPT);                       \
992         DEBUG_SHOW_STUDY_FLAG(flags,SCF_TRIE_DOING_RESTUDY);                \
993         DEBUG_SHOW_STUDY_FLAG(flags,SCF_IN_DEFINE);                         \
994         Perl_re_printf( aTHX_  "%s", close_str);                                        \
995     }
996
997
998 #define DEBUG_STUDYDATA(str,data,depth)                              \
999 DEBUG_OPTIMISE_MORE_r(if(data){                                      \
1000     Perl_re_indentf( aTHX_  "" str "Pos:%" IVdf "/%" IVdf            \
1001         " Flags: 0x%" UVXf,                                          \
1002         depth,                                                       \
1003         (IV)((data)->pos_min),                                       \
1004         (IV)((data)->pos_delta),                                     \
1005         (UV)((data)->flags)                                          \
1006     );                                                               \
1007     DEBUG_SHOW_STUDY_FLAGS((data)->flags," [ ","]");                 \
1008     Perl_re_printf( aTHX_                                            \
1009         " Whilem_c: %" IVdf " Lcp: %" IVdf " %s",                    \
1010         (IV)((data)->whilem_c),                                      \
1011         (IV)((data)->last_closep ? *((data)->last_closep) : -1),     \
1012         is_inf ? "INF " : ""                                         \
1013     );                                                               \
1014     if ((data)->last_found)                                          \
1015         Perl_re_printf( aTHX_                                        \
1016             "Last:'%s' %" IVdf ":%" IVdf "/%" IVdf                   \
1017             " %sFixed:'%s' @ %" IVdf                                 \
1018             " %sFloat: '%s' @ %" IVdf "/%" IVdf,                     \
1019             SvPVX_const((data)->last_found),                         \
1020             (IV)((data)->last_end),                                  \
1021             (IV)((data)->last_start_min),                            \
1022             (IV)((data)->last_start_max),                            \
1023             ((data)->longest &&                                      \
1024              (data)->longest==&((data)->longest_fixed)) ? "*" : "",  \
1025             SvPVX_const((data)->longest_fixed),                      \
1026             (IV)((data)->offset_fixed),                              \
1027             ((data)->longest &&                                      \
1028              (data)->longest==&((data)->longest_float)) ? "*" : "",  \
1029             SvPVX_const((data)->longest_float),                      \
1030             (IV)((data)->offset_float_min),                          \
1031             (IV)((data)->offset_float_max)                           \
1032         );                                                           \
1033     Perl_re_printf( aTHX_ "\n");                                                 \
1034 });
1035
1036
1037 /* =========================================================
1038  * BEGIN edit_distance stuff.
1039  *
1040  * This calculates how many single character changes of any type are needed to
1041  * transform a string into another one.  It is taken from version 3.1 of
1042  *
1043  * https://metacpan.org/pod/Text::Levenshtein::Damerau::XS
1044  */
1045
1046 /* Our unsorted dictionary linked list.   */
1047 /* Note we use UVs, not chars. */
1048
1049 struct dictionary{
1050   UV key;
1051   UV value;
1052   struct dictionary* next;
1053 };
1054 typedef struct dictionary item;
1055
1056
1057 PERL_STATIC_INLINE item*
1058 push(UV key,item* curr)
1059 {
1060     item* head;
1061     Newxz(head, 1, item);
1062     head->key = key;
1063     head->value = 0;
1064     head->next = curr;
1065     return head;
1066 }
1067
1068
1069 PERL_STATIC_INLINE item*
1070 find(item* head, UV key)
1071 {
1072     item* iterator = head;
1073     while (iterator){
1074         if (iterator->key == key){
1075             return iterator;
1076         }
1077         iterator = iterator->next;
1078     }
1079
1080     return NULL;
1081 }
1082
1083 PERL_STATIC_INLINE item*
1084 uniquePush(item* head,UV key)
1085 {
1086     item* iterator = head;
1087
1088     while (iterator){
1089         if (iterator->key == key) {
1090             return head;
1091         }
1092         iterator = iterator->next;
1093     }
1094
1095     return push(key,head);
1096 }
1097
1098 PERL_STATIC_INLINE void
1099 dict_free(item* head)
1100 {
1101     item* iterator = head;
1102
1103     while (iterator) {
1104         item* temp = iterator;
1105         iterator = iterator->next;
1106         Safefree(temp);
1107     }
1108
1109     head = NULL;
1110 }
1111
1112 /* End of Dictionary Stuff */
1113
1114 /* All calculations/work are done here */
1115 STATIC int
1116 S_edit_distance(const UV* src,
1117                 const UV* tgt,
1118                 const STRLEN x,             /* length of src[] */
1119                 const STRLEN y,             /* length of tgt[] */
1120                 const SSize_t maxDistance
1121 )
1122 {
1123     item *head = NULL;
1124     UV swapCount,swapScore,targetCharCount,i,j;
1125     UV *scores;
1126     UV score_ceil = x + y;
1127
1128     PERL_ARGS_ASSERT_EDIT_DISTANCE;
1129
1130     /* intialize matrix start values */
1131     Newxz(scores, ( (x + 2) * (y + 2)), UV);
1132     scores[0] = score_ceil;
1133     scores[1 * (y + 2) + 0] = score_ceil;
1134     scores[0 * (y + 2) + 1] = score_ceil;
1135     scores[1 * (y + 2) + 1] = 0;
1136     head = uniquePush(uniquePush(head,src[0]),tgt[0]);
1137
1138     /* work loops    */
1139     /* i = src index */
1140     /* j = tgt index */
1141     for (i=1;i<=x;i++) {
1142         if (i < x)
1143             head = uniquePush(head,src[i]);
1144         scores[(i+1) * (y + 2) + 1] = i;
1145         scores[(i+1) * (y + 2) + 0] = score_ceil;
1146         swapCount = 0;
1147
1148         for (j=1;j<=y;j++) {
1149             if (i == 1) {
1150                 if(j < y)
1151                 head = uniquePush(head,tgt[j]);
1152                 scores[1 * (y + 2) + (j + 1)] = j;
1153                 scores[0 * (y + 2) + (j + 1)] = score_ceil;
1154             }
1155
1156             targetCharCount = find(head,tgt[j-1])->value;
1157             swapScore = scores[targetCharCount * (y + 2) + swapCount] + i - targetCharCount - 1 + j - swapCount;
1158
1159             if (src[i-1] != tgt[j-1]){
1160                 scores[(i+1) * (y + 2) + (j + 1)] = MIN(swapScore,(MIN(scores[i * (y + 2) + j], MIN(scores[(i+1) * (y + 2) + j], scores[i * (y + 2) + (j + 1)])) + 1));
1161             }
1162             else {
1163                 swapCount = j;
1164                 scores[(i+1) * (y + 2) + (j + 1)] = MIN(scores[i * (y + 2) + j], swapScore);
1165             }
1166         }
1167
1168         find(head,src[i-1])->value = i;
1169     }
1170
1171     {
1172         IV score = scores[(x+1) * (y + 2) + (y + 1)];
1173         dict_free(head);
1174         Safefree(scores);
1175         return (maxDistance != 0 && maxDistance < score)?(-1):score;
1176     }
1177 }
1178
1179 /* END of edit_distance() stuff
1180  * ========================================================= */
1181
1182 /* is c a control character for which we have a mnemonic? */
1183 #define isMNEMONIC_CNTRL(c) _IS_MNEMONIC_CNTRL_ONLY_FOR_USE_BY_REGCOMP_DOT_C(c)
1184
1185 STATIC const char *
1186 S_cntrl_to_mnemonic(const U8 c)
1187 {
1188     /* Returns the mnemonic string that represents character 'c', if one
1189      * exists; NULL otherwise.  The only ones that exist for the purposes of
1190      * this routine are a few control characters */
1191
1192     switch (c) {
1193         case '\a':       return "\\a";
1194         case '\b':       return "\\b";
1195         case ESC_NATIVE: return "\\e";
1196         case '\f':       return "\\f";
1197         case '\n':       return "\\n";
1198         case '\r':       return "\\r";
1199         case '\t':       return "\\t";
1200     }
1201
1202     return NULL;
1203 }
1204
1205 /* Mark that we cannot extend a found fixed substring at this point.
1206    Update the longest found anchored substring and the longest found
1207    floating substrings if needed. */
1208
1209 STATIC void
1210 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data,
1211                     SSize_t *minlenp, int is_inf)
1212 {
1213     const STRLEN l = CHR_SVLEN(data->last_found);
1214     const STRLEN old_l = CHR_SVLEN(*data->longest);
1215     GET_RE_DEBUG_FLAGS_DECL;
1216
1217     PERL_ARGS_ASSERT_SCAN_COMMIT;
1218
1219     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
1220         SvSetMagicSV(*data->longest, data->last_found);
1221         if (*data->longest == data->longest_fixed) {
1222             data->offset_fixed = l ? data->last_start_min : data->pos_min;
1223             if (data->flags & SF_BEFORE_EOL)
1224                 data->flags
1225                     |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
1226             else
1227                 data->flags &= ~SF_FIX_BEFORE_EOL;
1228             data->minlen_fixed=minlenp;
1229             data->lookbehind_fixed=0;
1230         }
1231         else { /* *data->longest == data->longest_float */
1232             data->offset_float_min = l ? data->last_start_min : data->pos_min;
1233             data->offset_float_max = (l
1234                           ? data->last_start_max
1235                           : (data->pos_delta > SSize_t_MAX - data->pos_min
1236                                          ? SSize_t_MAX
1237                                          : data->pos_min + data->pos_delta));
1238             if (is_inf
1239                  || (STRLEN)data->offset_float_max > (STRLEN)SSize_t_MAX)
1240                 data->offset_float_max = SSize_t_MAX;
1241             if (data->flags & SF_BEFORE_EOL)
1242                 data->flags
1243                     |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
1244             else
1245                 data->flags &= ~SF_FL_BEFORE_EOL;
1246             data->minlen_float=minlenp;
1247             data->lookbehind_float=0;
1248         }
1249     }
1250     SvCUR_set(data->last_found, 0);
1251     {
1252         SV * const sv = data->last_found;
1253         if (SvUTF8(sv) && SvMAGICAL(sv)) {
1254             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
1255             if (mg)
1256                 mg->mg_len = 0;
1257         }
1258     }
1259     data->last_end = -1;
1260     data->flags &= ~SF_BEFORE_EOL;
1261     DEBUG_STUDYDATA("commit: ",data,0);
1262 }
1263
1264 /* An SSC is just a regnode_charclass_posix with an extra field: the inversion
1265  * list that describes which code points it matches */
1266
1267 STATIC void
1268 S_ssc_anything(pTHX_ regnode_ssc *ssc)
1269 {
1270     /* Set the SSC 'ssc' to match an empty string or any code point */
1271
1272     PERL_ARGS_ASSERT_SSC_ANYTHING;
1273
1274     assert(is_ANYOF_SYNTHETIC(ssc));
1275
1276     /* mortalize so won't leak */
1277     ssc->invlist = sv_2mortal(_add_range_to_invlist(NULL, 0, UV_MAX));
1278     ANYOF_FLAGS(ssc) |= SSC_MATCHES_EMPTY_STRING;  /* Plus matches empty */
1279 }
1280
1281 STATIC int
1282 S_ssc_is_anything(const regnode_ssc *ssc)
1283 {
1284     /* Returns TRUE if the SSC 'ssc' can match the empty string and any code
1285      * point; FALSE otherwise.  Thus, this is used to see if using 'ssc' buys
1286      * us anything: if the function returns TRUE, 'ssc' hasn't been restricted
1287      * in any way, so there's no point in using it */
1288
1289     UV start, end;
1290     bool ret;
1291
1292     PERL_ARGS_ASSERT_SSC_IS_ANYTHING;
1293
1294     assert(is_ANYOF_SYNTHETIC(ssc));
1295
1296     if (! (ANYOF_FLAGS(ssc) & SSC_MATCHES_EMPTY_STRING)) {
1297         return FALSE;
1298     }
1299
1300     /* See if the list consists solely of the range 0 - Infinity */
1301     invlist_iterinit(ssc->invlist);
1302     ret = invlist_iternext(ssc->invlist, &start, &end)
1303           && start == 0
1304           && end == UV_MAX;
1305
1306     invlist_iterfinish(ssc->invlist);
1307
1308     if (ret) {
1309         return TRUE;
1310     }
1311
1312     /* If e.g., both \w and \W are set, matches everything */
1313     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1314         int i;
1315         for (i = 0; i < ANYOF_POSIXL_MAX; i += 2) {
1316             if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i+1)) {
1317                 return TRUE;
1318             }
1319         }
1320     }
1321
1322     return FALSE;
1323 }
1324
1325 STATIC void
1326 S_ssc_init(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc)
1327 {
1328     /* Initializes the SSC 'ssc'.  This includes setting it to match an empty
1329      * string, any code point, or any posix class under locale */
1330
1331     PERL_ARGS_ASSERT_SSC_INIT;
1332
1333     Zero(ssc, 1, regnode_ssc);
1334     set_ANYOF_SYNTHETIC(ssc);
1335     ARG_SET(ssc, ANYOF_ONLY_HAS_BITMAP);
1336     ssc_anything(ssc);
1337
1338     /* If any portion of the regex is to operate under locale rules that aren't
1339      * fully known at compile time, initialization includes it.  The reason
1340      * this isn't done for all regexes is that the optimizer was written under
1341      * the assumption that locale was all-or-nothing.  Given the complexity and
1342      * lack of documentation in the optimizer, and that there are inadequate
1343      * test cases for locale, many parts of it may not work properly, it is
1344      * safest to avoid locale unless necessary. */
1345     if (RExC_contains_locale) {
1346         ANYOF_POSIXL_SETALL(ssc);
1347     }
1348     else {
1349         ANYOF_POSIXL_ZERO(ssc);
1350     }
1351 }
1352
1353 STATIC int
1354 S_ssc_is_cp_posixl_init(const RExC_state_t *pRExC_state,
1355                         const regnode_ssc *ssc)
1356 {
1357     /* Returns TRUE if the SSC 'ssc' is in its initial state with regard only
1358      * to the list of code points matched, and locale posix classes; hence does
1359      * not check its flags) */
1360
1361     UV start, end;
1362     bool ret;
1363
1364     PERL_ARGS_ASSERT_SSC_IS_CP_POSIXL_INIT;
1365
1366     assert(is_ANYOF_SYNTHETIC(ssc));
1367
1368     invlist_iterinit(ssc->invlist);
1369     ret = invlist_iternext(ssc->invlist, &start, &end)
1370           && start == 0
1371           && end == UV_MAX;
1372
1373     invlist_iterfinish(ssc->invlist);
1374
1375     if (! ret) {
1376         return FALSE;
1377     }
1378
1379     if (RExC_contains_locale && ! ANYOF_POSIXL_SSC_TEST_ALL_SET(ssc)) {
1380         return FALSE;
1381     }
1382
1383     return TRUE;
1384 }
1385
1386 STATIC SV*
1387 S_get_ANYOF_cp_list_for_ssc(pTHX_ const RExC_state_t *pRExC_state,
1388                                const regnode_charclass* const node)
1389 {
1390     /* Returns a mortal inversion list defining which code points are matched
1391      * by 'node', which is of type ANYOF.  Handles complementing the result if
1392      * appropriate.  If some code points aren't knowable at this time, the
1393      * returned list must, and will, contain every code point that is a
1394      * possibility. */
1395
1396     SV* invlist = NULL;
1397     SV* only_utf8_locale_invlist = NULL;
1398     unsigned int i;
1399     const U32 n = ARG(node);
1400     bool new_node_has_latin1 = FALSE;
1401
1402     PERL_ARGS_ASSERT_GET_ANYOF_CP_LIST_FOR_SSC;
1403
1404     /* Look at the data structure created by S_set_ANYOF_arg() */
1405     if (n != ANYOF_ONLY_HAS_BITMAP) {
1406         SV * const rv = MUTABLE_SV(RExC_rxi->data->data[n]);
1407         AV * const av = MUTABLE_AV(SvRV(rv));
1408         SV **const ary = AvARRAY(av);
1409         assert(RExC_rxi->data->what[n] == 's');
1410
1411         if (ary[1] && ary[1] != &PL_sv_undef) { /* Has compile-time swash */
1412             invlist = sv_2mortal(invlist_clone(_get_swash_invlist(ary[1])));
1413         }
1414         else if (ary[0] && ary[0] != &PL_sv_undef) {
1415
1416             /* Here, no compile-time swash, and there are things that won't be
1417              * known until runtime -- we have to assume it could be anything */
1418             invlist = sv_2mortal(_new_invlist(1));
1419             return _add_range_to_invlist(invlist, 0, UV_MAX);
1420         }
1421         else if (ary[3] && ary[3] != &PL_sv_undef) {
1422
1423             /* Here no compile-time swash, and no run-time only data.  Use the
1424              * node's inversion list */
1425             invlist = sv_2mortal(invlist_clone(ary[3]));
1426         }
1427
1428         /* Get the code points valid only under UTF-8 locales */
1429         if ((ANYOF_FLAGS(node) & ANYOFL_FOLD)
1430             && ary[2] && ary[2] != &PL_sv_undef)
1431         {
1432             only_utf8_locale_invlist = ary[2];
1433         }
1434     }
1435
1436     if (! invlist) {
1437         invlist = sv_2mortal(_new_invlist(0));
1438     }
1439
1440     /* An ANYOF node contains a bitmap for the first NUM_ANYOF_CODE_POINTS
1441      * code points, and an inversion list for the others, but if there are code
1442      * points that should match only conditionally on the target string being
1443      * UTF-8, those are placed in the inversion list, and not the bitmap.
1444      * Since there are circumstances under which they could match, they are
1445      * included in the SSC.  But if the ANYOF node is to be inverted, we have
1446      * to exclude them here, so that when we invert below, the end result
1447      * actually does include them.  (Think about "\xe0" =~ /[^\xc0]/di;).  We
1448      * have to do this here before we add the unconditionally matched code
1449      * points */
1450     if (ANYOF_FLAGS(node) & ANYOF_INVERT) {
1451         _invlist_intersection_complement_2nd(invlist,
1452                                              PL_UpperLatin1,
1453                                              &invlist);
1454     }
1455
1456     /* Add in the points from the bit map */
1457     for (i = 0; i < NUM_ANYOF_CODE_POINTS; i++) {
1458         if (ANYOF_BITMAP_TEST(node, i)) {
1459             unsigned int start = i++;
1460
1461             for (; i < NUM_ANYOF_CODE_POINTS && ANYOF_BITMAP_TEST(node, i); ++i) {
1462                 /* empty */
1463             }
1464             invlist = _add_range_to_invlist(invlist, start, i-1);
1465             new_node_has_latin1 = TRUE;
1466         }
1467     }
1468
1469     /* If this can match all upper Latin1 code points, have to add them
1470      * as well.  But don't add them if inverting, as when that gets done below,
1471      * it would exclude all these characters, including the ones it shouldn't
1472      * that were added just above */
1473     if (! (ANYOF_FLAGS(node) & ANYOF_INVERT) && OP(node) == ANYOFD
1474         && (ANYOF_FLAGS(node) & ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER))
1475     {
1476         _invlist_union(invlist, PL_UpperLatin1, &invlist);
1477     }
1478
1479     /* Similarly for these */
1480     if (ANYOF_FLAGS(node) & ANYOF_MATCHES_ALL_ABOVE_BITMAP) {
1481         _invlist_union_complement_2nd(invlist, PL_InBitmap, &invlist);
1482     }
1483
1484     if (ANYOF_FLAGS(node) & ANYOF_INVERT) {
1485         _invlist_invert(invlist);
1486     }
1487     else if (new_node_has_latin1 && ANYOF_FLAGS(node) & ANYOFL_FOLD) {
1488
1489         /* Under /li, any 0-255 could fold to any other 0-255, depending on the
1490          * locale.  We can skip this if there are no 0-255 at all. */
1491         _invlist_union(invlist, PL_Latin1, &invlist);
1492     }
1493
1494     /* Similarly add the UTF-8 locale possible matches.  These have to be
1495      * deferred until after the non-UTF-8 locale ones are taken care of just
1496      * above, or it leads to wrong results under ANYOF_INVERT */
1497     if (only_utf8_locale_invlist) {
1498         _invlist_union_maybe_complement_2nd(invlist,
1499                                             only_utf8_locale_invlist,
1500                                             ANYOF_FLAGS(node) & ANYOF_INVERT,
1501                                             &invlist);
1502     }
1503
1504     return invlist;
1505 }
1506
1507 /* These two functions currently do the exact same thing */
1508 #define ssc_init_zero           ssc_init
1509
1510 #define ssc_add_cp(ssc, cp)   ssc_add_range((ssc), (cp), (cp))
1511 #define ssc_match_all_cp(ssc) ssc_add_range(ssc, 0, UV_MAX)
1512
1513 /* 'AND' a given class with another one.  Can create false positives.  'ssc'
1514  * should not be inverted.  'and_with->flags & ANYOF_MATCHES_POSIXL' should be
1515  * 0 if 'and_with' is a regnode_charclass instead of a regnode_ssc. */
1516
1517 STATIC void
1518 S_ssc_and(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1519                 const regnode_charclass *and_with)
1520 {
1521     /* Accumulate into SSC 'ssc' its 'AND' with 'and_with', which is either
1522      * another SSC or a regular ANYOF class.  Can create false positives. */
1523
1524     SV* anded_cp_list;
1525     U8  anded_flags;
1526
1527     PERL_ARGS_ASSERT_SSC_AND;
1528
1529     assert(is_ANYOF_SYNTHETIC(ssc));
1530
1531     /* 'and_with' is used as-is if it too is an SSC; otherwise have to extract
1532      * the code point inversion list and just the relevant flags */
1533     if (is_ANYOF_SYNTHETIC(and_with)) {
1534         anded_cp_list = ((regnode_ssc *)and_with)->invlist;
1535         anded_flags = ANYOF_FLAGS(and_with);
1536
1537         /* XXX This is a kludge around what appears to be deficiencies in the
1538          * optimizer.  If we make S_ssc_anything() add in the WARN_SUPER flag,
1539          * there are paths through the optimizer where it doesn't get weeded
1540          * out when it should.  And if we don't make some extra provision for
1541          * it like the code just below, it doesn't get added when it should.
1542          * This solution is to add it only when AND'ing, which is here, and
1543          * only when what is being AND'ed is the pristine, original node
1544          * matching anything.  Thus it is like adding it to ssc_anything() but
1545          * only when the result is to be AND'ed.  Probably the same solution
1546          * could be adopted for the same problem we have with /l matching,
1547          * which is solved differently in S_ssc_init(), and that would lead to
1548          * fewer false positives than that solution has.  But if this solution
1549          * creates bugs, the consequences are only that a warning isn't raised
1550          * that should be; while the consequences for having /l bugs is
1551          * incorrect matches */
1552         if (ssc_is_anything((regnode_ssc *)and_with)) {
1553             anded_flags |= ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER;
1554         }
1555     }
1556     else {
1557         anded_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, and_with);
1558         if (OP(and_with) == ANYOFD) {
1559             anded_flags = ANYOF_FLAGS(and_with) & ANYOF_COMMON_FLAGS;
1560         }
1561         else {
1562             anded_flags = ANYOF_FLAGS(and_with)
1563             &( ANYOF_COMMON_FLAGS
1564               |ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1565               |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP);
1566             if (ANYOFL_UTF8_LOCALE_REQD(ANYOF_FLAGS(and_with))) {
1567                 anded_flags &=
1568                     ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
1569             }
1570         }
1571     }
1572
1573     ANYOF_FLAGS(ssc) &= anded_flags;
1574
1575     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1576      * C2 is the list of code points in 'and-with'; P2, its posix classes.
1577      * 'and_with' may be inverted.  When not inverted, we have the situation of
1578      * computing:
1579      *  (C1 | P1) & (C2 | P2)
1580      *                     =  (C1 & (C2 | P2)) | (P1 & (C2 | P2))
1581      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1582      *                    <=  ((C1 & C2) |       P2)) | ( P1       | (P1 & P2))
1583      *                    <=  ((C1 & C2) | P1 | P2)
1584      * Alternatively, the last few steps could be:
1585      *                     =  ((C1 & C2) | (C1 & P2)) | ((P1 & C2) | (P1 & P2))
1586      *                    <=  ((C1 & C2) |  C1      ) | (      C2  | (P1 & P2))
1587      *                    <=  (C1 | C2 | (P1 & P2))
1588      * We favor the second approach if either P1 or P2 is non-empty.  This is
1589      * because these components are a barrier to doing optimizations, as what
1590      * they match cannot be known until the moment of matching as they are
1591      * dependent on the current locale, 'AND"ing them likely will reduce or
1592      * eliminate them.
1593      * But we can do better if we know that C1,P1 are in their initial state (a
1594      * frequent occurrence), each matching everything:
1595      *  (<everything>) & (C2 | P2) =  C2 | P2
1596      * Similarly, if C2,P2 are in their initial state (again a frequent
1597      * occurrence), the result is a no-op
1598      *  (C1 | P1) & (<everything>) =  C1 | P1
1599      *
1600      * Inverted, we have
1601      *  (C1 | P1) & ~(C2 | P2)  =  (C1 | P1) & (~C2 & ~P2)
1602      *                          =  (C1 & (~C2 & ~P2)) | (P1 & (~C2 & ~P2))
1603      *                         <=  (C1 & ~C2) | (P1 & ~P2)
1604      * */
1605
1606     if ((ANYOF_FLAGS(and_with) & ANYOF_INVERT)
1607         && ! is_ANYOF_SYNTHETIC(and_with))
1608     {
1609         unsigned int i;
1610
1611         ssc_intersection(ssc,
1612                          anded_cp_list,
1613                          FALSE /* Has already been inverted */
1614                          );
1615
1616         /* If either P1 or P2 is empty, the intersection will be also; can skip
1617          * the loop */
1618         if (! (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL)) {
1619             ANYOF_POSIXL_ZERO(ssc);
1620         }
1621         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1622
1623             /* Note that the Posix class component P from 'and_with' actually
1624              * looks like:
1625              *      P = Pa | Pb | ... | Pn
1626              * where each component is one posix class, such as in [\w\s].
1627              * Thus
1628              *      ~P = ~(Pa | Pb | ... | Pn)
1629              *         = ~Pa & ~Pb & ... & ~Pn
1630              *        <= ~Pa | ~Pb | ... | ~Pn
1631              * The last is something we can easily calculate, but unfortunately
1632              * is likely to have many false positives.  We could do better
1633              * in some (but certainly not all) instances if two classes in
1634              * P have known relationships.  For example
1635              *      :lower: <= :alpha: <= :alnum: <= \w <= :graph: <= :print:
1636              * So
1637              *      :lower: & :print: = :lower:
1638              * And similarly for classes that must be disjoint.  For example,
1639              * since \s and \w can have no elements in common based on rules in
1640              * the POSIX standard,
1641              *      \w & ^\S = nothing
1642              * Unfortunately, some vendor locales do not meet the Posix
1643              * standard, in particular almost everything by Microsoft.
1644              * The loop below just changes e.g., \w into \W and vice versa */
1645
1646             regnode_charclass_posixl temp;
1647             int add = 1;    /* To calculate the index of the complement */
1648
1649             ANYOF_POSIXL_ZERO(&temp);
1650             for (i = 0; i < ANYOF_MAX; i++) {
1651                 assert(i % 2 != 0
1652                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)
1653                        || ! ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i + 1));
1654
1655                 if (ANYOF_POSIXL_TEST((regnode_charclass_posixl*) and_with, i)) {
1656                     ANYOF_POSIXL_SET(&temp, i + add);
1657                 }
1658                 add = 0 - add; /* 1 goes to -1; -1 goes to 1 */
1659             }
1660             ANYOF_POSIXL_AND(&temp, ssc);
1661
1662         } /* else ssc already has no posixes */
1663     } /* else: Not inverted.  This routine is a no-op if 'and_with' is an SSC
1664          in its initial state */
1665     else if (! is_ANYOF_SYNTHETIC(and_with)
1666              || ! ssc_is_cp_posixl_init(pRExC_state, (regnode_ssc *)and_with))
1667     {
1668         /* But if 'ssc' is in its initial state, the result is just 'and_with';
1669          * copy it over 'ssc' */
1670         if (ssc_is_cp_posixl_init(pRExC_state, ssc)) {
1671             if (is_ANYOF_SYNTHETIC(and_with)) {
1672                 StructCopy(and_with, ssc, regnode_ssc);
1673             }
1674             else {
1675                 ssc->invlist = anded_cp_list;
1676                 ANYOF_POSIXL_ZERO(ssc);
1677                 if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) {
1678                     ANYOF_POSIXL_OR((regnode_charclass_posixl*) and_with, ssc);
1679                 }
1680             }
1681         }
1682         else if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)
1683                  || (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL))
1684         {
1685             /* One or the other of P1, P2 is non-empty. */
1686             if (ANYOF_FLAGS(and_with) & ANYOF_MATCHES_POSIXL) {
1687                 ANYOF_POSIXL_AND((regnode_charclass_posixl*) and_with, ssc);
1688             }
1689             ssc_union(ssc, anded_cp_list, FALSE);
1690         }
1691         else { /* P1 = P2 = empty */
1692             ssc_intersection(ssc, anded_cp_list, FALSE);
1693         }
1694     }
1695 }
1696
1697 STATIC void
1698 S_ssc_or(pTHX_ const RExC_state_t *pRExC_state, regnode_ssc *ssc,
1699                const regnode_charclass *or_with)
1700 {
1701     /* Accumulate into SSC 'ssc' its 'OR' with 'or_with', which is either
1702      * another SSC or a regular ANYOF class.  Can create false positives if
1703      * 'or_with' is to be inverted. */
1704
1705     SV* ored_cp_list;
1706     U8 ored_flags;
1707
1708     PERL_ARGS_ASSERT_SSC_OR;
1709
1710     assert(is_ANYOF_SYNTHETIC(ssc));
1711
1712     /* 'or_with' is used as-is if it too is an SSC; otherwise have to extract
1713      * the code point inversion list and just the relevant flags */
1714     if (is_ANYOF_SYNTHETIC(or_with)) {
1715         ored_cp_list = ((regnode_ssc*) or_with)->invlist;
1716         ored_flags = ANYOF_FLAGS(or_with);
1717     }
1718     else {
1719         ored_cp_list = get_ANYOF_cp_list_for_ssc(pRExC_state, or_with);
1720         ored_flags = ANYOF_FLAGS(or_with) & ANYOF_COMMON_FLAGS;
1721         if (OP(or_with) != ANYOFD) {
1722             ored_flags
1723             |= ANYOF_FLAGS(or_with)
1724              & ( ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1725                 |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP);
1726             if (ANYOFL_UTF8_LOCALE_REQD(ANYOF_FLAGS(or_with))) {
1727                 ored_flags |=
1728                     ANYOFL_SHARED_UTF8_LOCALE_fold_HAS_MATCHES_nonfold_REQD;
1729             }
1730         }
1731     }
1732
1733     ANYOF_FLAGS(ssc) |= ored_flags;
1734
1735     /* Below, C1 is the list of code points in 'ssc'; P1, its posix classes.
1736      * C2 is the list of code points in 'or-with'; P2, its posix classes.
1737      * 'or_with' may be inverted.  When not inverted, we have the simple
1738      * situation of computing:
1739      *  (C1 | P1) | (C2 | P2)  =  (C1 | C2) | (P1 | P2)
1740      * If P1|P2 yields a situation with both a class and its complement are
1741      * set, like having both \w and \W, this matches all code points, and we
1742      * can delete these from the P component of the ssc going forward.  XXX We
1743      * might be able to delete all the P components, but I (khw) am not certain
1744      * about this, and it is better to be safe.
1745      *
1746      * Inverted, we have
1747      *  (C1 | P1) | ~(C2 | P2)  =  (C1 | P1) | (~C2 & ~P2)
1748      *                         <=  (C1 | P1) | ~C2
1749      *                         <=  (C1 | ~C2) | P1
1750      * (which results in actually simpler code than the non-inverted case)
1751      * */
1752
1753     if ((ANYOF_FLAGS(or_with) & ANYOF_INVERT)
1754         && ! is_ANYOF_SYNTHETIC(or_with))
1755     {
1756         /* We ignore P2, leaving P1 going forward */
1757     }   /* else  Not inverted */
1758     else if (ANYOF_FLAGS(or_with) & ANYOF_MATCHES_POSIXL) {
1759         ANYOF_POSIXL_OR((regnode_charclass_posixl*)or_with, ssc);
1760         if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1761             unsigned int i;
1762             for (i = 0; i < ANYOF_MAX; i += 2) {
1763                 if (ANYOF_POSIXL_TEST(ssc, i) && ANYOF_POSIXL_TEST(ssc, i + 1))
1764                 {
1765                     ssc_match_all_cp(ssc);
1766                     ANYOF_POSIXL_CLEAR(ssc, i);
1767                     ANYOF_POSIXL_CLEAR(ssc, i+1);
1768                 }
1769             }
1770         }
1771     }
1772
1773     ssc_union(ssc,
1774               ored_cp_list,
1775               FALSE /* Already has been inverted */
1776               );
1777 }
1778
1779 PERL_STATIC_INLINE void
1780 S_ssc_union(pTHX_ regnode_ssc *ssc, SV* const invlist, const bool invert2nd)
1781 {
1782     PERL_ARGS_ASSERT_SSC_UNION;
1783
1784     assert(is_ANYOF_SYNTHETIC(ssc));
1785
1786     _invlist_union_maybe_complement_2nd(ssc->invlist,
1787                                         invlist,
1788                                         invert2nd,
1789                                         &ssc->invlist);
1790 }
1791
1792 PERL_STATIC_INLINE void
1793 S_ssc_intersection(pTHX_ regnode_ssc *ssc,
1794                          SV* const invlist,
1795                          const bool invert2nd)
1796 {
1797     PERL_ARGS_ASSERT_SSC_INTERSECTION;
1798
1799     assert(is_ANYOF_SYNTHETIC(ssc));
1800
1801     _invlist_intersection_maybe_complement_2nd(ssc->invlist,
1802                                                invlist,
1803                                                invert2nd,
1804                                                &ssc->invlist);
1805 }
1806
1807 PERL_STATIC_INLINE void
1808 S_ssc_add_range(pTHX_ regnode_ssc *ssc, const UV start, const UV end)
1809 {
1810     PERL_ARGS_ASSERT_SSC_ADD_RANGE;
1811
1812     assert(is_ANYOF_SYNTHETIC(ssc));
1813
1814     ssc->invlist = _add_range_to_invlist(ssc->invlist, start, end);
1815 }
1816
1817 PERL_STATIC_INLINE void
1818 S_ssc_cp_and(pTHX_ regnode_ssc *ssc, const UV cp)
1819 {
1820     /* AND just the single code point 'cp' into the SSC 'ssc' */
1821
1822     SV* cp_list = _new_invlist(2);
1823
1824     PERL_ARGS_ASSERT_SSC_CP_AND;
1825
1826     assert(is_ANYOF_SYNTHETIC(ssc));
1827
1828     cp_list = add_cp_to_invlist(cp_list, cp);
1829     ssc_intersection(ssc, cp_list,
1830                      FALSE /* Not inverted */
1831                      );
1832     SvREFCNT_dec_NN(cp_list);
1833 }
1834
1835 PERL_STATIC_INLINE void
1836 S_ssc_clear_locale(regnode_ssc *ssc)
1837 {
1838     /* Set the SSC 'ssc' to not match any locale things */
1839     PERL_ARGS_ASSERT_SSC_CLEAR_LOCALE;
1840
1841     assert(is_ANYOF_SYNTHETIC(ssc));
1842
1843     ANYOF_POSIXL_ZERO(ssc);
1844     ANYOF_FLAGS(ssc) &= ~ANYOF_LOCALE_FLAGS;
1845 }
1846
1847 #define NON_OTHER_COUNT   NON_OTHER_COUNT_FOR_USE_ONLY_BY_REGCOMP_DOT_C
1848
1849 STATIC bool
1850 S_is_ssc_worth_it(const RExC_state_t * pRExC_state, const regnode_ssc * ssc)
1851 {
1852     /* The synthetic start class is used to hopefully quickly winnow down
1853      * places where a pattern could start a match in the target string.  If it
1854      * doesn't really narrow things down that much, there isn't much point to
1855      * having the overhead of using it.  This function uses some very crude
1856      * heuristics to decide if to use the ssc or not.
1857      *
1858      * It returns TRUE if 'ssc' rules out more than half what it considers to
1859      * be the "likely" possible matches, but of course it doesn't know what the
1860      * actual things being matched are going to be; these are only guesses
1861      *
1862      * For /l matches, it assumes that the only likely matches are going to be
1863      *      in the 0-255 range, uniformly distributed, so half of that is 127
1864      * For /a and /d matches, it assumes that the likely matches will be just
1865      *      the ASCII range, so half of that is 63
1866      * For /u and there isn't anything matching above the Latin1 range, it
1867      *      assumes that that is the only range likely to be matched, and uses
1868      *      half that as the cut-off: 127.  If anything matches above Latin1,
1869      *      it assumes that all of Unicode could match (uniformly), except for
1870      *      non-Unicode code points and things in the General Category "Other"
1871      *      (unassigned, private use, surrogates, controls and formats).  This
1872      *      is a much large number. */
1873
1874     U32 count = 0;      /* Running total of number of code points matched by
1875                            'ssc' */
1876     UV start, end;      /* Start and end points of current range in inversion
1877                            list */
1878     const U32 max_code_points = (LOC)
1879                                 ?  256
1880                                 : ((   ! UNI_SEMANTICS
1881                                      || invlist_highest(ssc->invlist) < 256)
1882                                   ? 128
1883                                   : NON_OTHER_COUNT);
1884     const U32 max_match = max_code_points / 2;
1885
1886     PERL_ARGS_ASSERT_IS_SSC_WORTH_IT;
1887
1888     invlist_iterinit(ssc->invlist);
1889     while (invlist_iternext(ssc->invlist, &start, &end)) {
1890         if (start >= max_code_points) {
1891             break;
1892         }
1893         end = MIN(end, max_code_points - 1);
1894         count += end - start + 1;
1895         if (count >= max_match) {
1896             invlist_iterfinish(ssc->invlist);
1897             return FALSE;
1898         }
1899     }
1900
1901     return TRUE;
1902 }
1903
1904
1905 STATIC void
1906 S_ssc_finalize(pTHX_ RExC_state_t *pRExC_state, regnode_ssc *ssc)
1907 {
1908     /* The inversion list in the SSC is marked mortal; now we need a more
1909      * permanent copy, which is stored the same way that is done in a regular
1910      * ANYOF node, with the first NUM_ANYOF_CODE_POINTS code points in a bit
1911      * map */
1912
1913     SV* invlist = invlist_clone(ssc->invlist);
1914
1915     PERL_ARGS_ASSERT_SSC_FINALIZE;
1916
1917     assert(is_ANYOF_SYNTHETIC(ssc));
1918
1919     /* The code in this file assumes that all but these flags aren't relevant
1920      * to the SSC, except SSC_MATCHES_EMPTY_STRING, which should be cleared
1921      * by the time we reach here */
1922     assert(! (ANYOF_FLAGS(ssc)
1923         & ~( ANYOF_COMMON_FLAGS
1924             |ANYOF_SHARED_d_MATCHES_ALL_NON_UTF8_NON_ASCII_non_d_WARN_SUPER
1925             |ANYOF_SHARED_d_UPPER_LATIN1_UTF8_STRING_MATCHES_non_d_RUNTIME_USER_PROP)));
1926
1927     populate_ANYOF_from_invlist( (regnode *) ssc, &invlist);
1928
1929     set_ANYOF_arg(pRExC_state, (regnode *) ssc, invlist,
1930                                 NULL, NULL, NULL, FALSE);
1931
1932     /* Make sure is clone-safe */
1933     ssc->invlist = NULL;
1934
1935     if (ANYOF_POSIXL_SSC_TEST_ANY_SET(ssc)) {
1936         ANYOF_FLAGS(ssc) |= ANYOF_MATCHES_POSIXL;
1937     }
1938
1939     if (RExC_contains_locale) {
1940         OP(ssc) = ANYOFL;
1941     }
1942
1943     assert(! (ANYOF_FLAGS(ssc) & ANYOF_LOCALE_FLAGS) || RExC_contains_locale);
1944 }
1945
1946 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
1947 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
1948 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
1949 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list         \
1950                                ? (TRIE_LIST_CUR( idx ) - 1)           \
1951                                : 0 )
1952
1953
1954 #ifdef DEBUGGING
1955 /*
1956    dump_trie(trie,widecharmap,revcharmap)
1957    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
1958    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
1959
1960    These routines dump out a trie in a somewhat readable format.
1961    The _interim_ variants are used for debugging the interim
1962    tables that are used to generate the final compressed
1963    representation which is what dump_trie expects.
1964
1965    Part of the reason for their existence is to provide a form
1966    of documentation as to how the different representations function.
1967
1968 */
1969
1970 /*
1971   Dumps the final compressed table form of the trie to Perl_debug_log.
1972   Used for debugging make_trie().
1973 */
1974
1975 STATIC void
1976 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
1977             AV *revcharmap, U32 depth)
1978 {
1979     U32 state;
1980     SV *sv=sv_newmortal();
1981     int colwidth= widecharmap ? 6 : 4;
1982     U16 word;
1983     GET_RE_DEBUG_FLAGS_DECL;
1984
1985     PERL_ARGS_ASSERT_DUMP_TRIE;
1986
1987     Perl_re_indentf( aTHX_  "Char : %-6s%-6s%-4s ",
1988         depth+1, "Match","Base","Ofs" );
1989
1990     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
1991         SV ** const tmp = av_fetch( revcharmap, state, 0);
1992         if ( tmp ) {
1993             Perl_re_printf( aTHX_  "%*s",
1994                 colwidth,
1995                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
1996                             PL_colors[0], PL_colors[1],
1997                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1998                             PERL_PV_ESCAPE_FIRSTCHAR
1999                 )
2000             );
2001         }
2002     }
2003     Perl_re_printf( aTHX_  "\n");
2004     Perl_re_indentf( aTHX_ "State|-----------------------", depth+1);
2005
2006     for( state = 0 ; state < trie->uniquecharcount ; state++ )
2007         Perl_re_printf( aTHX_  "%.*s", colwidth, "--------");
2008     Perl_re_printf( aTHX_  "\n");
2009
2010     for( state = 1 ; state < trie->statecount ; state++ ) {
2011         const U32 base = trie->states[ state ].trans.base;
2012
2013         Perl_re_indentf( aTHX_  "#%4" UVXf "|", depth+1, (UV)state);
2014
2015         if ( trie->states[ state ].wordnum ) {
2016             Perl_re_printf( aTHX_  " W%4X", trie->states[ state ].wordnum );
2017         } else {
2018             Perl_re_printf( aTHX_  "%6s", "" );
2019         }
2020
2021         Perl_re_printf( aTHX_  " @%4" UVXf " ", (UV)base );
2022
2023         if ( base ) {
2024             U32 ofs = 0;
2025
2026             while( ( base + ofs  < trie->uniquecharcount ) ||
2027                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
2028                      && trie->trans[ base + ofs - trie->uniquecharcount ].check
2029                                                                     != state))
2030                     ofs++;
2031
2032             Perl_re_printf( aTHX_  "+%2" UVXf "[ ", (UV)ofs);
2033
2034             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2035                 if ( ( base + ofs >= trie->uniquecharcount )
2036                         && ( base + ofs - trie->uniquecharcount
2037                                                         < trie->lasttrans )
2038                         && trie->trans[ base + ofs
2039                                     - trie->uniquecharcount ].check == state )
2040                 {
2041                    Perl_re_printf( aTHX_  "%*" UVXf, colwidth,
2042                     (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next
2043                    );
2044                 } else {
2045                     Perl_re_printf( aTHX_  "%*s",colwidth,"   ." );
2046                 }
2047             }
2048
2049             Perl_re_printf( aTHX_  "]");
2050
2051         }
2052         Perl_re_printf( aTHX_  "\n" );
2053     }
2054     Perl_re_indentf( aTHX_  "word_info N:(prev,len)=",
2055                                 depth);
2056     for (word=1; word <= trie->wordcount; word++) {
2057         Perl_re_printf( aTHX_  " %d:(%d,%d)",
2058             (int)word, (int)(trie->wordinfo[word].prev),
2059             (int)(trie->wordinfo[word].len));
2060     }
2061     Perl_re_printf( aTHX_  "\n" );
2062 }
2063 /*
2064   Dumps a fully constructed but uncompressed trie in list form.
2065   List tries normally only are used for construction when the number of
2066   possible chars (trie->uniquecharcount) is very high.
2067   Used for debugging make_trie().
2068 */
2069 STATIC void
2070 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
2071                          HV *widecharmap, AV *revcharmap, U32 next_alloc,
2072                          U32 depth)
2073 {
2074     U32 state;
2075     SV *sv=sv_newmortal();
2076     int colwidth= widecharmap ? 6 : 4;
2077     GET_RE_DEBUG_FLAGS_DECL;
2078
2079     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
2080
2081     /* print out the table precompression.  */
2082     Perl_re_indentf( aTHX_  "State :Word | Transition Data\n",
2083             depth+1 );
2084     Perl_re_indentf( aTHX_  "%s",
2085             depth+1, "------:-----+-----------------\n" );
2086
2087     for( state=1 ; state < next_alloc ; state ++ ) {
2088         U16 charid;
2089
2090         Perl_re_indentf( aTHX_  " %4" UVXf " :",
2091             depth+1, (UV)state  );
2092         if ( ! trie->states[ state ].wordnum ) {
2093             Perl_re_printf( aTHX_  "%5s| ","");
2094         } else {
2095             Perl_re_printf( aTHX_  "W%4x| ",
2096                 trie->states[ state ].wordnum
2097             );
2098         }
2099         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
2100             SV ** const tmp = av_fetch( revcharmap,
2101                                         TRIE_LIST_ITEM(state,charid).forid, 0);
2102             if ( tmp ) {
2103                 Perl_re_printf( aTHX_  "%*s:%3X=%4" UVXf " | ",
2104                     colwidth,
2105                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp),
2106                               colwidth,
2107                               PL_colors[0], PL_colors[1],
2108                               (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
2109                               | PERL_PV_ESCAPE_FIRSTCHAR
2110                     ) ,
2111                     TRIE_LIST_ITEM(state,charid).forid,
2112                     (UV)TRIE_LIST_ITEM(state,charid).newstate
2113                 );
2114                 if (!(charid % 10))
2115                     Perl_re_printf( aTHX_  "\n%*s| ",
2116                         (int)((depth * 2) + 14), "");
2117             }
2118         }
2119         Perl_re_printf( aTHX_  "\n");
2120     }
2121 }
2122
2123 /*
2124   Dumps a fully constructed but uncompressed trie in table form.
2125   This is the normal DFA style state transition table, with a few
2126   twists to facilitate compression later.
2127   Used for debugging make_trie().
2128 */
2129 STATIC void
2130 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
2131                           HV *widecharmap, AV *revcharmap, U32 next_alloc,
2132                           U32 depth)
2133 {
2134     U32 state;
2135     U16 charid;
2136     SV *sv=sv_newmortal();
2137     int colwidth= widecharmap ? 6 : 4;
2138     GET_RE_DEBUG_FLAGS_DECL;
2139
2140     PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
2141
2142     /*
2143        print out the table precompression so that we can do a visual check
2144        that they are identical.
2145      */
2146
2147     Perl_re_indentf( aTHX_  "Char : ", depth+1 );
2148
2149     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
2150         SV ** const tmp = av_fetch( revcharmap, charid, 0);
2151         if ( tmp ) {
2152             Perl_re_printf( aTHX_  "%*s",
2153                 colwidth,
2154                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
2155                             PL_colors[0], PL_colors[1],
2156                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2157                             PERL_PV_ESCAPE_FIRSTCHAR
2158                 )
2159             );
2160         }
2161     }
2162
2163     Perl_re_printf( aTHX_ "\n");
2164     Perl_re_indentf( aTHX_  "State+-", depth+1 );
2165
2166     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
2167         Perl_re_printf( aTHX_  "%.*s", colwidth,"--------");
2168     }
2169
2170     Perl_re_printf( aTHX_  "\n" );
2171
2172     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
2173
2174         Perl_re_indentf( aTHX_  "%4" UVXf " : ",
2175             depth+1,
2176             (UV)TRIE_NODENUM( state ) );
2177
2178         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
2179             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
2180             if (v)
2181                 Perl_re_printf( aTHX_  "%*" UVXf, colwidth, v );
2182             else
2183                 Perl_re_printf( aTHX_  "%*s", colwidth, "." );
2184         }
2185         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
2186             Perl_re_printf( aTHX_  " (%4" UVXf ")\n",
2187                                             (UV)trie->trans[ state ].check );
2188         } else {
2189             Perl_re_printf( aTHX_  " (%4" UVXf ") W%4X\n",
2190                                             (UV)trie->trans[ state ].check,
2191             trie->states[ TRIE_NODENUM( state ) ].wordnum );
2192         }
2193     }
2194 }
2195
2196 #endif
2197
2198
2199 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
2200   startbranch: the first branch in the whole branch sequence
2201   first      : start branch of sequence of branch-exact nodes.
2202                May be the same as startbranch
2203   last       : Thing following the last branch.
2204                May be the same as tail.
2205   tail       : item following the branch sequence
2206   count      : words in the sequence
2207   flags      : currently the OP() type we will be building one of /EXACT(|F|FA|FU|FU_SS|L|FLU8)/
2208   depth      : indent depth
2209
2210 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
2211
2212 A trie is an N'ary tree where the branches are determined by digital
2213 decomposition of the key. IE, at the root node you look up the 1st character and
2214 follow that branch repeat until you find the end of the branches. Nodes can be
2215 marked as "accepting" meaning they represent a complete word. Eg:
2216
2217   /he|she|his|hers/
2218
2219 would convert into the following structure. Numbers represent states, letters
2220 following numbers represent valid transitions on the letter from that state, if
2221 the number is in square brackets it represents an accepting state, otherwise it
2222 will be in parenthesis.
2223
2224       +-h->+-e->[3]-+-r->(8)-+-s->[9]
2225       |    |
2226       |   (2)
2227       |    |
2228      (1)   +-i->(6)-+-s->[7]
2229       |
2230       +-s->(3)-+-h->(4)-+-e->[5]
2231
2232       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
2233
2234 This shows that when matching against the string 'hers' we will begin at state 1
2235 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
2236 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
2237 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
2238 single traverse. We store a mapping from accepting to state to which word was
2239 matched, and then when we have multiple possibilities we try to complete the
2240 rest of the regex in the order in which they occurred in the alternation.
2241
2242 The only prior NFA like behaviour that would be changed by the TRIE support is
2243 the silent ignoring of duplicate alternations which are of the form:
2244
2245  / (DUPE|DUPE) X? (?{ ... }) Y /x
2246
2247 Thus EVAL blocks following a trie may be called a different number of times with
2248 and without the optimisation. With the optimisations dupes will be silently
2249 ignored. This inconsistent behaviour of EVAL type nodes is well established as
2250 the following demonstrates:
2251
2252  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
2253
2254 which prints out 'word' three times, but
2255
2256  'words'=~/(word|word|word)(?{ print $1 })S/
2257
2258 which doesnt print it out at all. This is due to other optimisations kicking in.
2259
2260 Example of what happens on a structural level:
2261
2262 The regexp /(ac|ad|ab)+/ will produce the following debug output:
2263
2264    1: CURLYM[1] {1,32767}(18)
2265    5:   BRANCH(8)
2266    6:     EXACT <ac>(16)
2267    8:   BRANCH(11)
2268    9:     EXACT <ad>(16)
2269   11:   BRANCH(14)
2270   12:     EXACT <ab>(16)
2271   16:   SUCCEED(0)
2272   17:   NOTHING(18)
2273   18: END(0)
2274
2275 This would be optimizable with startbranch=5, first=5, last=16, tail=16
2276 and should turn into:
2277
2278    1: CURLYM[1] {1,32767}(18)
2279    5:   TRIE(16)
2280         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
2281           <ac>
2282           <ad>
2283           <ab>
2284   16:   SUCCEED(0)
2285   17:   NOTHING(18)
2286   18: END(0)
2287
2288 Cases where tail != last would be like /(?foo|bar)baz/:
2289
2290    1: BRANCH(4)
2291    2:   EXACT <foo>(8)
2292    4: BRANCH(7)
2293    5:   EXACT <bar>(8)
2294    7: TAIL(8)
2295    8: EXACT <baz>(10)
2296   10: END(0)
2297
2298 which would be optimizable with startbranch=1, first=1, last=7, tail=8
2299 and would end up looking like:
2300
2301     1: TRIE(8)
2302       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
2303         <foo>
2304         <bar>
2305    7: TAIL(8)
2306    8: EXACT <baz>(10)
2307   10: END(0)
2308
2309     d = uvchr_to_utf8_flags(d, uv, 0);
2310
2311 is the recommended Unicode-aware way of saying
2312
2313     *(d++) = uv;
2314 */
2315
2316 #define TRIE_STORE_REVCHAR(val)                                            \
2317     STMT_START {                                                           \
2318         if (UTF) {                                                         \
2319             SV *zlopp = newSV(UTF8_MAXBYTES);                              \
2320             unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp);      \
2321             unsigned const char *const kapow = uvchr_to_utf8(flrbbbbb, val); \
2322             SvCUR_set(zlopp, kapow - flrbbbbb);                            \
2323             SvPOK_on(zlopp);                                               \
2324             SvUTF8_on(zlopp);                                              \
2325             av_push(revcharmap, zlopp);                                    \
2326         } else {                                                           \
2327             char ooooff = (char)val;                                           \
2328             av_push(revcharmap, newSVpvn(&ooooff, 1));                     \
2329         }                                                                  \
2330         } STMT_END
2331
2332 /* This gets the next character from the input, folding it if not already
2333  * folded. */
2334 #define TRIE_READ_CHAR STMT_START {                                           \
2335     wordlen++;                                                                \
2336     if ( UTF ) {                                                              \
2337         /* if it is UTF then it is either already folded, or does not need    \
2338          * folding */                                                         \
2339         uvc = valid_utf8_to_uvchr( (const U8*) uc, &len);                     \
2340     }                                                                         \
2341     else if (folder == PL_fold_latin1) {                                      \
2342         /* This folder implies Unicode rules, which in the range expressible  \
2343          *  by not UTF is the lower case, with the two exceptions, one of     \
2344          *  which should have been taken care of before calling this */       \
2345         assert(*uc != LATIN_SMALL_LETTER_SHARP_S);                            \
2346         uvc = toLOWER_L1(*uc);                                                \
2347         if (UNLIKELY(uvc == MICRO_SIGN)) uvc = GREEK_SMALL_LETTER_MU;         \
2348         len = 1;                                                              \
2349     } else {                                                                  \
2350         /* raw data, will be folded later if needed */                        \
2351         uvc = (U32)*uc;                                                       \
2352         len = 1;                                                              \
2353     }                                                                         \
2354 } STMT_END
2355
2356
2357
2358 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
2359     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
2360         U32 ging = TRIE_LIST_LEN( state ) *= 2;                 \
2361         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
2362     }                                                           \
2363     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
2364     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
2365     TRIE_LIST_CUR( state )++;                                   \
2366 } STMT_END
2367
2368 #define TRIE_LIST_NEW(state) STMT_START {                       \
2369     Newxz( trie->states[ state ].trans.list,               \
2370         4, reg_trie_trans_le );                                 \
2371      TRIE_LIST_CUR( state ) = 1;                                \
2372      TRIE_LIST_LEN( state ) = 4;                                \
2373 } STMT_END
2374
2375 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
2376     U16 dupe= trie->states[ state ].wordnum;                    \
2377     regnode * const noper_next = regnext( noper );              \
2378                                                                 \
2379     DEBUG_r({                                                   \
2380         /* store the word for dumping */                        \
2381         SV* tmp;                                                \
2382         if (OP(noper) != NOTHING)                               \
2383             tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF);    \
2384         else                                                    \
2385             tmp = newSVpvn_utf8( "", 0, UTF );                  \
2386         av_push( trie_words, tmp );                             \
2387     });                                                         \
2388                                                                 \
2389     curword++;                                                  \
2390     trie->wordinfo[curword].prev   = 0;                         \
2391     trie->wordinfo[curword].len    = wordlen;                   \
2392     trie->wordinfo[curword].accept = state;                     \
2393                                                                 \
2394     if ( noper_next < tail ) {                                  \
2395         if (!trie->jump)                                        \
2396             trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, \
2397                                                  sizeof(U16) ); \
2398         trie->jump[curword] = (U16)(noper_next - convert);      \
2399         if (!jumper)                                            \
2400             jumper = noper_next;                                \
2401         if (!nextbranch)                                        \
2402             nextbranch= regnext(cur);                           \
2403     }                                                           \
2404                                                                 \
2405     if ( dupe ) {                                               \
2406         /* It's a dupe. Pre-insert into the wordinfo[].prev   */\
2407         /* chain, so that when the bits of chain are later    */\
2408         /* linked together, the dups appear in the chain      */\
2409         trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
2410         trie->wordinfo[dupe].prev = curword;                    \
2411     } else {                                                    \
2412         /* we haven't inserted this word yet.                */ \
2413         trie->states[ state ].wordnum = curword;                \
2414     }                                                           \
2415 } STMT_END
2416
2417
2418 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
2419      ( ( base + charid >=  ucharcount                                   \
2420          && base + charid < ubound                                      \
2421          && state == trie->trans[ base - ucharcount + charid ].check    \
2422          && trie->trans[ base - ucharcount + charid ].next )            \
2423            ? trie->trans[ base - ucharcount + charid ].next             \
2424            : ( state==1 ? special : 0 )                                 \
2425       )
2426
2427 #define TRIE_BITMAP_SET_FOLDED(trie, uvc, folder)           \
2428 STMT_START {                                                \
2429     TRIE_BITMAP_SET(trie, uvc);                             \
2430     /* store the folded codepoint */                        \
2431     if ( folder )                                           \
2432         TRIE_BITMAP_SET(trie, folder[(U8) uvc ]);           \
2433                                                             \
2434     if ( !UTF ) {                                           \
2435         /* store first byte of utf8 representation of */    \
2436         /* variant codepoints */                            \
2437         if (! UVCHR_IS_INVARIANT(uvc)) {                    \
2438             TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));   \
2439         }                                                   \
2440     }                                                       \
2441 } STMT_END
2442 #define MADE_TRIE       1
2443 #define MADE_JUMP_TRIE  2
2444 #define MADE_EXACT_TRIE 4
2445
2446 STATIC I32
2447 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch,
2448                   regnode *first, regnode *last, regnode *tail,
2449                   U32 word_count, U32 flags, U32 depth)
2450 {
2451     /* first pass, loop through and scan words */
2452     reg_trie_data *trie;
2453     HV *widecharmap = NULL;
2454     AV *revcharmap = newAV();
2455     regnode *cur;
2456     STRLEN len = 0;
2457     UV uvc = 0;
2458     U16 curword = 0;
2459     U32 next_alloc = 0;
2460     regnode *jumper = NULL;
2461     regnode *nextbranch = NULL;
2462     regnode *convert = NULL;
2463     U32 *prev_states; /* temp array mapping each state to previous one */
2464     /* we just use folder as a flag in utf8 */
2465     const U8 * folder = NULL;
2466
2467 #ifdef DEBUGGING
2468     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tuuu"));
2469     AV *trie_words = NULL;
2470     /* along with revcharmap, this only used during construction but both are
2471      * useful during debugging so we store them in the struct when debugging.
2472      */
2473 #else
2474     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("tu"));
2475     STRLEN trie_charcount=0;
2476 #endif
2477     SV *re_trie_maxbuff;
2478     GET_RE_DEBUG_FLAGS_DECL;
2479
2480     PERL_ARGS_ASSERT_MAKE_TRIE;
2481 #ifndef DEBUGGING
2482     PERL_UNUSED_ARG(depth);
2483 #endif
2484
2485     switch (flags) {
2486         case EXACT: case EXACTL: break;
2487         case EXACTFA:
2488         case EXACTFU_SS:
2489         case EXACTFU:
2490         case EXACTFLU8: folder = PL_fold_latin1; break;
2491         case EXACTF:  folder = PL_fold; break;
2492         default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] );
2493     }
2494
2495     trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
2496     trie->refcount = 1;
2497     trie->startstate = 1;
2498     trie->wordcount = word_count;
2499     RExC_rxi->data->data[ data_slot ] = (void*)trie;
2500     trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
2501     if (flags == EXACT || flags == EXACTL)
2502         trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
2503     trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
2504                        trie->wordcount+1, sizeof(reg_trie_wordinfo));
2505
2506     DEBUG_r({
2507         trie_words = newAV();
2508     });
2509
2510     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
2511     assert(re_trie_maxbuff);
2512     if (!SvIOK(re_trie_maxbuff)) {
2513         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
2514     }
2515     DEBUG_TRIE_COMPILE_r({
2516         Perl_re_indentf( aTHX_
2517           "make_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
2518           depth+1,
2519           REG_NODE_NUM(startbranch),REG_NODE_NUM(first),
2520           REG_NODE_NUM(last), REG_NODE_NUM(tail), (int)depth);
2521     });
2522
2523    /* Find the node we are going to overwrite */
2524     if ( first == startbranch && OP( last ) != BRANCH ) {
2525         /* whole branch chain */
2526         convert = first;
2527     } else {
2528         /* branch sub-chain */
2529         convert = NEXTOPER( first );
2530     }
2531
2532     /*  -- First loop and Setup --
2533
2534        We first traverse the branches and scan each word to determine if it
2535        contains widechars, and how many unique chars there are, this is
2536        important as we have to build a table with at least as many columns as we
2537        have unique chars.
2538
2539        We use an array of integers to represent the character codes 0..255
2540        (trie->charmap) and we use a an HV* to store Unicode characters. We use
2541        the native representation of the character value as the key and IV's for
2542        the coded index.
2543
2544        *TODO* If we keep track of how many times each character is used we can
2545        remap the columns so that the table compression later on is more
2546        efficient in terms of memory by ensuring the most common value is in the
2547        middle and the least common are on the outside.  IMO this would be better
2548        than a most to least common mapping as theres a decent chance the most
2549        common letter will share a node with the least common, meaning the node
2550        will not be compressible. With a middle is most common approach the worst
2551        case is when we have the least common nodes twice.
2552
2553      */
2554
2555     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2556         regnode *noper = NEXTOPER( cur );
2557         const U8 *uc;
2558         const U8 *e;
2559         int foldlen = 0;
2560         U32 wordlen      = 0;         /* required init */
2561         STRLEN minchars = 0;
2562         STRLEN maxchars = 0;
2563         bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the
2564                                                bitmap?*/
2565
2566         if (OP(noper) == NOTHING) {
2567             /* skip past a NOTHING at the start of an alternation
2568              * eg, /(?:)a|(?:b)/ should be the same as /a|b/
2569              */
2570             regnode *noper_next= regnext(noper);
2571             if (noper_next < tail)
2572                 noper= noper_next;
2573         }
2574
2575         if ( noper < tail &&
2576                 (
2577                     OP(noper) == flags ||
2578                     (
2579                         flags == EXACTFU &&
2580                         OP(noper) == EXACTFU_SS
2581                     )
2582                 )
2583         ) {
2584             uc= (U8*)STRING(noper);
2585             e= uc + STR_LEN(noper);
2586         } else {
2587             trie->minlen= 0;
2588             continue;
2589         }
2590
2591
2592         if ( set_bit ) { /* bitmap only alloced when !(UTF&&Folding) */
2593             TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
2594                                           regardless of encoding */
2595             if (OP( noper ) == EXACTFU_SS) {
2596                 /* false positives are ok, so just set this */
2597                 TRIE_BITMAP_SET(trie, LATIN_SMALL_LETTER_SHARP_S);
2598             }
2599         }
2600
2601         for ( ; uc < e ; uc += len ) {  /* Look at each char in the current
2602                                            branch */
2603             TRIE_CHARCOUNT(trie)++;
2604             TRIE_READ_CHAR;
2605
2606             /* TRIE_READ_CHAR returns the current character, or its fold if /i
2607              * is in effect.  Under /i, this character can match itself, or
2608              * anything that folds to it.  If not under /i, it can match just
2609              * itself.  Most folds are 1-1, for example k, K, and KELVIN SIGN
2610              * all fold to k, and all are single characters.   But some folds
2611              * expand to more than one character, so for example LATIN SMALL
2612              * LIGATURE FFI folds to the three character sequence 'ffi'.  If
2613              * the string beginning at 'uc' is 'ffi', it could be matched by
2614              * three characters, or just by the one ligature character. (It
2615              * could also be matched by two characters: LATIN SMALL LIGATURE FF
2616              * followed by 'i', or by 'f' followed by LATIN SMALL LIGATURE FI).
2617              * (Of course 'I' and/or 'F' instead of 'i' and 'f' can also
2618              * match.)  The trie needs to know the minimum and maximum number
2619              * of characters that could match so that it can use size alone to
2620              * quickly reject many match attempts.  The max is simple: it is
2621              * the number of folded characters in this branch (since a fold is
2622              * never shorter than what folds to it. */
2623
2624             maxchars++;
2625
2626             /* And the min is equal to the max if not under /i (indicated by
2627              * 'folder' being NULL), or there are no multi-character folds.  If
2628              * there is a multi-character fold, the min is incremented just
2629              * once, for the character that folds to the sequence.  Each
2630              * character in the sequence needs to be added to the list below of
2631              * characters in the trie, but we count only the first towards the
2632              * min number of characters needed.  This is done through the
2633              * variable 'foldlen', which is returned by the macros that look
2634              * for these sequences as the number of bytes the sequence
2635              * occupies.  Each time through the loop, we decrement 'foldlen' by
2636              * how many bytes the current char occupies.  Only when it reaches
2637              * 0 do we increment 'minchars' or look for another multi-character
2638              * sequence. */
2639             if (folder == NULL) {
2640                 minchars++;
2641             }
2642             else if (foldlen > 0) {
2643                 foldlen -= (UTF) ? UTF8SKIP(uc) : 1;
2644             }
2645             else {
2646                 minchars++;
2647
2648                 /* See if *uc is the beginning of a multi-character fold.  If
2649                  * so, we decrement the length remaining to look at, to account
2650                  * for the current character this iteration.  (We can use 'uc'
2651                  * instead of the fold returned by TRIE_READ_CHAR because for
2652                  * non-UTF, the latin1_safe macro is smart enough to account
2653                  * for all the unfolded characters, and because for UTF, the
2654                  * string will already have been folded earlier in the
2655                  * compilation process */
2656                 if (UTF) {
2657                     if ((foldlen = is_MULTI_CHAR_FOLD_utf8_safe(uc, e))) {
2658                         foldlen -= UTF8SKIP(uc);
2659                     }
2660                 }
2661                 else if ((foldlen = is_MULTI_CHAR_FOLD_latin1_safe(uc, e))) {
2662                     foldlen--;
2663                 }
2664             }
2665
2666             /* The current character (and any potential folds) should be added
2667              * to the possible matching characters for this position in this
2668              * branch */
2669             if ( uvc < 256 ) {
2670                 if ( folder ) {
2671                     U8 folded= folder[ (U8) uvc ];
2672                     if ( !trie->charmap[ folded ] ) {
2673                         trie->charmap[ folded ]=( ++trie->uniquecharcount );
2674                         TRIE_STORE_REVCHAR( folded );
2675                     }
2676                 }
2677                 if ( !trie->charmap[ uvc ] ) {
2678                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
2679                     TRIE_STORE_REVCHAR( uvc );
2680                 }
2681                 if ( set_bit ) {
2682                     /* store the codepoint in the bitmap, and its folded
2683                      * equivalent. */
2684                     TRIE_BITMAP_SET_FOLDED(trie, uvc, folder);
2685                     set_bit = 0; /* We've done our bit :-) */
2686                 }
2687             } else {
2688
2689                 /* XXX We could come up with the list of code points that fold
2690                  * to this using PL_utf8_foldclosures, except not for
2691                  * multi-char folds, as there may be multiple combinations
2692                  * there that could work, which needs to wait until runtime to
2693                  * resolve (The comment about LIGATURE FFI above is such an
2694                  * example */
2695
2696                 SV** svpp;
2697                 if ( !widecharmap )
2698                     widecharmap = newHV();
2699
2700                 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
2701
2702                 if ( !svpp )
2703                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%" UVXf, uvc );
2704
2705                 if ( !SvTRUE( *svpp ) ) {
2706                     sv_setiv( *svpp, ++trie->uniquecharcount );
2707                     TRIE_STORE_REVCHAR(uvc);
2708                 }
2709             }
2710         } /* end loop through characters in this branch of the trie */
2711
2712         /* We take the min and max for this branch and combine to find the min
2713          * and max for all branches processed so far */
2714         if( cur == first ) {
2715             trie->minlen = minchars;
2716             trie->maxlen = maxchars;
2717         } else if (minchars < trie->minlen) {
2718             trie->minlen = minchars;
2719         } else if (maxchars > trie->maxlen) {
2720             trie->maxlen = maxchars;
2721         }
2722     } /* end first pass */
2723     DEBUG_TRIE_COMPILE_r(
2724         Perl_re_indentf( aTHX_
2725                 "TRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
2726                 depth+1,
2727                 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
2728                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
2729                 (int)trie->minlen, (int)trie->maxlen )
2730     );
2731
2732     /*
2733         We now know what we are dealing with in terms of unique chars and
2734         string sizes so we can calculate how much memory a naive
2735         representation using a flat table  will take. If it's over a reasonable
2736         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
2737         conservative but potentially much slower representation using an array
2738         of lists.
2739
2740         At the end we convert both representations into the same compressed
2741         form that will be used in regexec.c for matching with. The latter
2742         is a form that cannot be used to construct with but has memory
2743         properties similar to the list form and access properties similar
2744         to the table form making it both suitable for fast searches and
2745         small enough that its feasable to store for the duration of a program.
2746
2747         See the comment in the code where the compressed table is produced
2748         inplace from the flat tabe representation for an explanation of how
2749         the compression works.
2750
2751     */
2752
2753
2754     Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
2755     prev_states[1] = 0;
2756
2757     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1)
2758                                                     > SvIV(re_trie_maxbuff) )
2759     {
2760         /*
2761             Second Pass -- Array Of Lists Representation
2762
2763             Each state will be represented by a list of charid:state records
2764             (reg_trie_trans_le) the first such element holds the CUR and LEN
2765             points of the allocated array. (See defines above).
2766
2767             We build the initial structure using the lists, and then convert
2768             it into the compressed table form which allows faster lookups
2769             (but cant be modified once converted).
2770         */
2771
2772         STRLEN transcount = 1;
2773
2774         DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_  "Compiling trie using list compiler\n",
2775             depth+1));
2776
2777         trie->states = (reg_trie_state *)
2778             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
2779                                   sizeof(reg_trie_state) );
2780         TRIE_LIST_NEW(1);
2781         next_alloc = 2;
2782
2783         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
2784
2785             regnode *noper   = NEXTOPER( cur );
2786             U32 state        = 1;         /* required init */
2787             U16 charid       = 0;         /* sanity init */
2788             U32 wordlen      = 0;         /* required init */
2789
2790             if (OP(noper) == NOTHING) {
2791                 regnode *noper_next= regnext(noper);
2792                 if (noper_next < tail)
2793                     noper= noper_next;
2794             }
2795
2796             if ( noper < tail && ( OP(noper) == flags || ( flags == EXACTFU && OP(noper) == EXACTFU_SS ) ) ) {
2797                 const U8 *uc= (U8*)STRING(noper);
2798                 const U8 *e= uc + STR_LEN(noper);
2799
2800                 for ( ; uc < e ; uc += len ) {
2801
2802                     TRIE_READ_CHAR;
2803
2804                     if ( uvc < 256 ) {
2805                         charid = trie->charmap[ uvc ];
2806                     } else {
2807                         SV** const svpp = hv_fetch( widecharmap,
2808                                                     (char*)&uvc,
2809                                                     sizeof( UV ),
2810                                                     0);
2811                         if ( !svpp ) {
2812                             charid = 0;
2813                         } else {
2814                             charid=(U16)SvIV( *svpp );
2815                         }
2816                     }
2817                     /* charid is now 0 if we dont know the char read, or
2818                      * nonzero if we do */
2819                     if ( charid ) {
2820
2821                         U16 check;
2822                         U32 newstate = 0;
2823
2824                         charid--;
2825                         if ( !trie->states[ state ].trans.list ) {
2826                             TRIE_LIST_NEW( state );
2827                         }
2828                         for ( check = 1;
2829                               check <= TRIE_LIST_USED( state );
2830                               check++ )
2831                         {
2832                             if ( TRIE_LIST_ITEM( state, check ).forid
2833                                                                     == charid )
2834                             {
2835                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
2836                                 break;
2837                             }
2838                         }
2839                         if ( ! newstate ) {
2840                             newstate = next_alloc++;
2841                             prev_states[newstate] = state;
2842                             TRIE_LIST_PUSH( state, charid, newstate );
2843                             transcount++;
2844                         }
2845                         state = newstate;
2846                     } else {
2847                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %" IVdf, uvc );
2848                     }
2849                 }
2850             }
2851             TRIE_HANDLE_WORD(state);
2852
2853         } /* end second pass */
2854
2855         /* next alloc is the NEXT state to be allocated */
2856         trie->statecount = next_alloc;
2857         trie->states = (reg_trie_state *)
2858             PerlMemShared_realloc( trie->states,
2859                                    next_alloc
2860                                    * sizeof(reg_trie_state) );
2861
2862         /* and now dump it out before we compress it */
2863         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
2864                                                          revcharmap, next_alloc,
2865                                                          depth+1)
2866         );
2867
2868         trie->trans = (reg_trie_trans *)
2869             PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
2870         {
2871             U32 state;
2872             U32 tp = 0;
2873             U32 zp = 0;
2874
2875
2876             for( state=1 ; state < next_alloc ; state ++ ) {
2877                 U32 base=0;
2878
2879                 /*
2880                 DEBUG_TRIE_COMPILE_MORE_r(
2881                     Perl_re_printf( aTHX_  "tp: %d zp: %d ",tp,zp)
2882                 );
2883                 */
2884
2885                 if (trie->states[state].trans.list) {
2886                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
2887                     U16 maxid=minid;
2888                     U16 idx;
2889
2890                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
2891                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
2892                         if ( forid < minid ) {
2893                             minid=forid;
2894                         } else if ( forid > maxid ) {
2895                             maxid=forid;
2896                         }
2897                     }
2898                     if ( transcount < tp + maxid - minid + 1) {
2899                         transcount *= 2;
2900                         trie->trans = (reg_trie_trans *)
2901                             PerlMemShared_realloc( trie->trans,
2902                                                      transcount
2903                                                      * sizeof(reg_trie_trans) );
2904                         Zero( trie->trans + (transcount / 2),
2905                               transcount / 2,
2906                               reg_trie_trans );
2907                     }
2908                     base = trie->uniquecharcount + tp - minid;
2909                     if ( maxid == minid ) {
2910                         U32 set = 0;
2911                         for ( ; zp < tp ; zp++ ) {
2912                             if ( ! trie->trans[ zp ].next ) {
2913                                 base = trie->uniquecharcount + zp - minid;
2914                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state,
2915                                                                    1).newstate;
2916                                 trie->trans[ zp ].check = state;
2917                                 set = 1;
2918                                 break;
2919                             }
2920                         }
2921                         if ( !set ) {
2922                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state,
2923                                                                    1).newstate;
2924                             trie->trans[ tp ].check = state;
2925                             tp++;
2926                             zp = tp;
2927                         }
2928                     } else {
2929                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
2930                             const U32 tid = base
2931                                            - trie->uniquecharcount
2932                                            + TRIE_LIST_ITEM( state, idx ).forid;
2933                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state,
2934                                                                 idx ).newstate;
2935                             trie->trans[ tid ].check = state;
2936                         }
2937                         tp += ( maxid - minid + 1 );
2938                     }
2939                     Safefree(trie->states[ state ].trans.list);
2940                 }
2941                 /*
2942                 DEBUG_TRIE_COMPILE_MORE_r(
2943                     Perl_re_printf( aTHX_  " base: %d\n",base);
2944                 );
2945                 */
2946                 trie->states[ state ].trans.base=base;
2947             }
2948             trie->lasttrans = tp + 1;
2949         }
2950     } else {
2951         /*
2952            Second Pass -- Flat Table Representation.
2953
2954            we dont use the 0 slot of either trans[] or states[] so we add 1 to
2955            each.  We know that we will need Charcount+1 trans at most to store
2956            the data (one row per char at worst case) So we preallocate both
2957            structures assuming worst case.
2958
2959            We then construct the trie using only the .next slots of the entry
2960            structs.
2961
2962            We use the .check field of the first entry of the node temporarily
2963            to make compression both faster and easier by keeping track of how
2964            many non zero fields are in the node.
2965
2966            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
2967            transition.
2968
2969            There are two terms at use here: state as a TRIE_NODEIDX() which is
2970            a number representing the first entry of the node, and state as a
2971            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1)
2972            and TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3)
2973            if there are 2 entrys per node. eg:
2974
2975              A B       A B
2976           1. 2 4    1. 3 7
2977           2. 0 3    3. 0 5
2978           3. 0 0    5. 0 0
2979           4. 0 0    7. 0 0
2980
2981            The table is internally in the right hand, idx form. However as we
2982            also have to deal with the states array which is indexed by nodenum
2983            we have to use TRIE_NODENUM() to convert.
2984
2985         */
2986         DEBUG_TRIE_COMPILE_MORE_r( Perl_re_indentf( aTHX_  "Compiling trie using table compiler\n",
2987             depth+1));
2988
2989         trie->trans = (reg_trie_trans *)
2990             PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
2991                                   * trie->uniquecharcount + 1,
2992                                   sizeof(reg_trie_trans) );
2993         trie->states = (reg_trie_state *)
2994             PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
2995                                   sizeof(reg_trie_state) );
2996         next_alloc = trie->uniquecharcount + 1;
2997
2998
2999         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
3000
3001             regnode *noper   = NEXTOPER( cur );
3002
3003             U32 state        = 1;         /* required init */
3004
3005             U16 charid       = 0;         /* sanity init */
3006             U32 accept_state = 0;         /* sanity init */
3007
3008             U32 wordlen      = 0;         /* required init */
3009
3010             if (OP(noper) == NOTHING) {
3011                 regnode *noper_next= regnext(noper);
3012                 if (noper_next < tail)
3013                     noper= noper_next;
3014             }
3015
3016             if ( noper < tail && ( OP(noper) == flags || ( flags == EXACTFU && OP(noper) == EXACTFU_SS ) ) ) {
3017                 const U8 *uc= (U8*)STRING(noper);
3018                 const U8 *e= uc + STR_LEN(noper);
3019
3020                 for ( ; uc < e ; uc += len ) {
3021
3022                     TRIE_READ_CHAR;
3023
3024                     if ( uvc < 256 ) {
3025                         charid = trie->charmap[ uvc ];
3026                     } else {
3027                         SV* const * const svpp = hv_fetch( widecharmap,
3028                                                            (char*)&uvc,
3029                                                            sizeof( UV ),
3030                                                            0);
3031                         charid = svpp ? (U16)SvIV(*svpp) : 0;
3032                     }
3033                     if ( charid ) {
3034                         charid--;
3035                         if ( !trie->trans[ state + charid ].next ) {
3036                             trie->trans[ state + charid ].next = next_alloc;
3037                             trie->trans[ state ].check++;
3038                             prev_states[TRIE_NODENUM(next_alloc)]
3039                                     = TRIE_NODENUM(state);
3040                             next_alloc += trie->uniquecharcount;
3041                         }
3042                         state = trie->trans[ state + charid ].next;
3043                     } else {
3044                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %" IVdf, uvc );
3045                     }
3046                     /* charid is now 0 if we dont know the char read, or
3047                      * nonzero if we do */
3048                 }
3049             }
3050             accept_state = TRIE_NODENUM( state );
3051             TRIE_HANDLE_WORD(accept_state);
3052
3053         } /* end second pass */
3054
3055         /* and now dump it out before we compress it */
3056         DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
3057                                                           revcharmap,
3058                                                           next_alloc, depth+1));
3059
3060         {
3061         /*
3062            * Inplace compress the table.*
3063
3064            For sparse data sets the table constructed by the trie algorithm will
3065            be mostly 0/FAIL transitions or to put it another way mostly empty.
3066            (Note that leaf nodes will not contain any transitions.)
3067
3068            This algorithm compresses the tables by eliminating most such
3069            transitions, at the cost of a modest bit of extra work during lookup:
3070
3071            - Each states[] entry contains a .base field which indicates the
3072            index in the state[] array wheres its transition data is stored.
3073
3074            - If .base is 0 there are no valid transitions from that node.
3075
3076            - If .base is nonzero then charid is added to it to find an entry in
3077            the trans array.
3078
3079            -If trans[states[state].base+charid].check!=state then the
3080            transition is taken to be a 0/Fail transition. Thus if there are fail
3081            transitions at the front of the node then the .base offset will point
3082            somewhere inside the previous nodes data (or maybe even into a node
3083            even earlier), but the .check field determines if the transition is
3084            valid.
3085
3086            XXX - wrong maybe?
3087            The following process inplace converts the table to the compressed
3088            table: We first do not compress the root node 1,and mark all its
3089            .check pointers as 1 and set its .base pointer as 1 as well. This
3090            allows us to do a DFA construction from the compressed table later,
3091            and ensures that any .base pointers we calculate later are greater
3092            than 0.
3093
3094            - We set 'pos' to indicate the first entry of the second node.
3095
3096            - We then iterate over the columns of the node, finding the first and
3097            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
3098            and set the .check pointers accordingly, and advance pos
3099            appropriately and repreat for the next node. Note that when we copy
3100            the next pointers we have to convert them from the original
3101            NODEIDX form to NODENUM form as the former is not valid post
3102            compression.
3103
3104            - If a node has no transitions used we mark its base as 0 and do not
3105            advance the pos pointer.
3106
3107            - If a node only has one transition we use a second pointer into the
3108            structure to fill in allocated fail transitions from other states.
3109            This pointer is independent of the main pointer and scans forward
3110            looking for null transitions that are allocated to a state. When it
3111            finds one it writes the single transition into the "hole".  If the
3112            pointer doesnt find one the single transition is appended as normal.
3113
3114            - Once compressed we can Renew/realloc the structures to release the
3115            excess space.
3116
3117            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
3118            specifically Fig 3.47 and the associated pseudocode.
3119
3120            demq
3121         */
3122         const U32 laststate = TRIE_NODENUM( next_alloc );
3123         U32 state, charid;
3124         U32 pos = 0, zp=0;
3125         trie->statecount = laststate;
3126
3127         for ( state = 1 ; state < laststate ; state++ ) {
3128             U8 flag = 0;
3129             const U32 stateidx = TRIE_NODEIDX( state );
3130             const U32 o_used = trie->trans[ stateidx ].check;
3131             U32 used = trie->trans[ stateidx ].check;
3132             trie->trans[ stateidx ].check = 0;
3133
3134             for ( charid = 0;
3135                   used && charid < trie->uniquecharcount;
3136                   charid++ )
3137             {
3138                 if ( flag || trie->trans[ stateidx + charid ].next ) {
3139                     if ( trie->trans[ stateidx + charid ].next ) {
3140                         if (o_used == 1) {
3141                             for ( ; zp < pos ; zp++ ) {
3142                                 if ( ! trie->trans[ zp ].next ) {
3143                                     break;
3144                                 }
3145                             }
3146                             trie->states[ state ].trans.base
3147                                                     = zp
3148                                                       + trie->uniquecharcount
3149                                                       - charid ;
3150                             trie->trans[ zp ].next
3151                                 = SAFE_TRIE_NODENUM( trie->trans[ stateidx
3152                                                              + charid ].next );
3153                             trie->trans[ zp ].check = state;
3154                             if ( ++zp > pos ) pos = zp;
3155                             break;
3156                         }
3157                         used--;
3158                     }
3159                     if ( !flag ) {
3160                         flag = 1;
3161                         trie->states[ state ].trans.base
3162                                        = pos + trie->uniquecharcount - charid ;
3163                     }
3164                     trie->trans[ pos ].next
3165                         = SAFE_TRIE_NODENUM(
3166                                        trie->trans[ stateidx + charid ].next );
3167                     trie->trans[ pos ].check = state;
3168                     pos++;
3169                 }
3170             }
3171         }
3172         trie->lasttrans = pos + 1;
3173         trie->states = (reg_trie_state *)
3174             PerlMemShared_realloc( trie->states, laststate
3175                                    * sizeof(reg_trie_state) );
3176         DEBUG_TRIE_COMPILE_MORE_r(
3177             Perl_re_indentf( aTHX_  "Alloc: %d Orig: %" IVdf " elements, Final:%" IVdf ". Savings of %%%5.2f\n",
3178                 depth+1,
3179                 (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount
3180                        + 1 ),
3181                 (IV)next_alloc,
3182                 (IV)pos,
3183                 ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
3184             );
3185
3186         } /* end table compress */
3187     }
3188     DEBUG_TRIE_COMPILE_MORE_r(
3189             Perl_re_indentf( aTHX_  "Statecount:%" UVxf " Lasttrans:%" UVxf "\n",
3190                 depth+1,
3191                 (UV)trie->statecount,
3192                 (UV)trie->lasttrans)
3193     );
3194     /* resize the trans array to remove unused space */
3195     trie->trans = (reg_trie_trans *)
3196         PerlMemShared_realloc( trie->trans, trie->lasttrans
3197                                * sizeof(reg_trie_trans) );
3198
3199     {   /* Modify the program and insert the new TRIE node */
3200         U8 nodetype =(U8)(flags & 0xFF);
3201         char *str=NULL;
3202
3203 #ifdef DEBUGGING
3204         regnode *optimize = NULL;
3205 #ifdef RE_TRACK_PATTERN_OFFSETS
3206
3207         U32 mjd_offset = 0;
3208         U32 mjd_nodelen = 0;
3209 #endif /* RE_TRACK_PATTERN_OFFSETS */
3210 #endif /* DEBUGGING */
3211         /*
3212            This means we convert either the first branch or the first Exact,
3213            depending on whether the thing following (in 'last') is a branch
3214            or not and whther first is the startbranch (ie is it a sub part of
3215            the alternation or is it the whole thing.)
3216            Assuming its a sub part we convert the EXACT otherwise we convert
3217            the whole branch sequence, including the first.
3218          */
3219         /* Find the node we are going to overwrite */
3220         if ( first != startbranch || OP( last ) == BRANCH ) {
3221             /* branch sub-chain */
3222             NEXT_OFF( first ) = (U16)(last - first);
3223 #ifdef RE_TRACK_PATTERN_OFFSETS
3224             DEBUG_r({
3225                 mjd_offset= Node_Offset((convert));
3226                 mjd_nodelen= Node_Length((convert));
3227             });
3228 #endif
3229             /* whole branch chain */
3230         }
3231 #ifdef RE_TRACK_PATTERN_OFFSETS
3232         else {
3233             DEBUG_r({
3234                 const  regnode *nop = NEXTOPER( convert );
3235                 mjd_offset= Node_Offset((nop));
3236                 mjd_nodelen= Node_Length((nop));
3237             });
3238         }
3239         DEBUG_OPTIMISE_r(
3240             Perl_re_indentf( aTHX_  "MJD offset:%" UVuf " MJD length:%" UVuf "\n",
3241                 depth+1,
3242                 (UV)mjd_offset, (UV)mjd_nodelen)
3243         );
3244 #endif
3245         /* But first we check to see if there is a common prefix we can
3246            split out as an EXACT and put in front of the TRIE node.  */
3247         trie->startstate= 1;
3248         if ( trie->bitmap && !widecharmap && !trie->jump  ) {
3249             /* we want to find the first state that has more than
3250              * one transition, if that state is not the first state
3251              * then we have a common prefix which we can remove.
3252              */
3253             U32 state;
3254             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
3255                 U32 ofs = 0;
3256                 I32 first_ofs = -1; /* keeps track of the ofs of the first
3257                                        transition, -1 means none */
3258                 U32 count = 0;
3259                 const U32 base = trie->states[ state ].trans.base;
3260
3261                 /* does this state terminate an alternation? */
3262                 if ( trie->states[state].wordnum )
3263                         count = 1;
3264
3265                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
3266                     if ( ( base + ofs >= trie->uniquecharcount ) &&
3267                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
3268                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
3269                     {
3270                         if ( ++count > 1 ) {
3271                             /* we have more than one transition */
3272                             SV **tmp;
3273                             U8 *ch;
3274                             /* if this is the first state there is no common prefix
3275                              * to extract, so we can exit */
3276                             if ( state == 1 ) break;
3277                             tmp = av_fetch( revcharmap, ofs, 0);
3278                             ch = (U8*)SvPV_nolen_const( *tmp );
3279
3280                             /* if we are on count 2 then we need to initialize the
3281                              * bitmap, and store the previous char if there was one
3282                              * in it*/
3283                             if ( count == 2 ) {
3284                                 /* clear the bitmap */
3285                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
3286                                 DEBUG_OPTIMISE_r(
3287                                     Perl_re_indentf( aTHX_  "New Start State=%" UVuf " Class: [",
3288                                         depth+1,
3289                                         (UV)state));
3290                                 if (first_ofs >= 0) {
3291                                     SV ** const tmp = av_fetch( revcharmap, first_ofs, 0);
3292                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
3293
3294                                     TRIE_BITMAP_SET_FOLDED(trie,*ch,folder);
3295                                     DEBUG_OPTIMISE_r(
3296                                         Perl_re_printf( aTHX_  "%s", (char*)ch)
3297                                     );
3298                                 }
3299                             }
3300                             /* store the current firstchar in the bitmap */
3301                             TRIE_BITMAP_SET_FOLDED(trie,*ch,folder);
3302                             DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "%s", ch));
3303                         }
3304                         first_ofs = ofs;
3305                     }
3306                 }
3307                 if ( count == 1 ) {
3308                     /* This state has only one transition, its transition is part
3309                      * of a common prefix - we need to concatenate the char it
3310                      * represents to what we have so far. */
3311                     SV **tmp = av_fetch( revcharmap, first_ofs, 0);
3312                     STRLEN len;
3313                     char *ch = SvPV( *tmp, len );
3314                     DEBUG_OPTIMISE_r({
3315                         SV *sv=sv_newmortal();
3316                         Perl_re_indentf( aTHX_  "Prefix State: %" UVuf " Ofs:%" UVuf " Char='%s'\n",
3317                             depth+1,
3318                             (UV)state, (UV)first_ofs,
3319                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6,
3320                                 PL_colors[0], PL_colors[1],
3321                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
3322                                 PERL_PV_ESCAPE_FIRSTCHAR
3323                             )
3324                         );
3325                     });
3326                     if ( state==1 ) {
3327                         OP( convert ) = nodetype;
3328                         str=STRING(convert);
3329                         STR_LEN(convert)=0;
3330                     }
3331                     STR_LEN(convert) += len;
3332                     while (len--)
3333                         *str++ = *ch++;
3334                 } else {
3335 #ifdef DEBUGGING
3336                     if (state>1)
3337                         DEBUG_OPTIMISE_r(Perl_re_printf( aTHX_ "]\n"));
3338 #endif
3339                     break;
3340                 }
3341             }
3342             trie->prefixlen = (state-1);
3343             if (str) {
3344                 regnode *n = convert+NODE_SZ_STR(convert);
3345                 NEXT_OFF(convert) = NODE_SZ_STR(convert);
3346                 trie->startstate = state;
3347                 trie->minlen -= (state - 1);
3348                 trie->maxlen -= (state - 1);
3349 #ifdef DEBUGGING
3350                /* At least the UNICOS C compiler choked on this
3351                 * being argument to DEBUG_r(), so let's just have
3352                 * it right here. */
3353                if (
3354 #ifdef PERL_EXT_RE_BUILD
3355                    1
3356 #else
3357                    DEBUG_r_TEST
3358 #endif
3359                    ) {
3360                    regnode *fix = convert;
3361                    U32 word = trie->wordcount;
3362                    mjd_nodelen++;
3363                    Set_Node_Offset_Length(convert, mjd_offset, state - 1);
3364                    while( ++fix < n ) {
3365                        Set_Node_Offset_Length(fix, 0, 0);
3366                    }
3367                    while (word--) {
3368                        SV ** const tmp = av_fetch( trie_words, word, 0 );
3369                        if (tmp) {
3370                            if ( STR_LEN(convert) <= SvCUR(*tmp) )
3371                                sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
3372                            else
3373                                sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
3374                        }
3375                    }
3376                }
3377 #endif
3378                 if (trie->maxlen) {
3379                     convert = n;
3380                 } else {
3381                     NEXT_OFF(convert) = (U16)(tail - convert);
3382                     DEBUG_r(optimize= n);
3383                 }
3384             }
3385         }
3386         if (!jumper)
3387             jumper = last;
3388         if ( trie->maxlen ) {
3389             NEXT_OFF( convert ) = (U16)(tail - convert);
3390             ARG_SET( convert, data_slot );
3391             /* Store the offset to the first unabsorbed branch in
3392                jump[0], which is otherwise unused by the jump logic.
3393                We use this when dumping a trie and during optimisation. */
3394             if (trie->jump)
3395                 trie->jump[0] = (U16)(nextbranch - convert);
3396
3397             /* If the start state is not accepting (meaning there is no empty string/NOTHING)
3398              *   and there is a bitmap
3399              *   and the first "jump target" node we found leaves enough room
3400              * then convert the TRIE node into a TRIEC node, with the bitmap
3401              * embedded inline in the opcode - this is hypothetically faster.
3402              */
3403             if ( !trie->states[trie->startstate].wordnum
3404                  && trie->bitmap
3405                  && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
3406             {
3407                 OP( convert ) = TRIEC;
3408                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
3409                 PerlMemShared_free(trie->bitmap);
3410                 trie->bitmap= NULL;
3411             } else
3412                 OP( convert ) = TRIE;
3413
3414             /* store the type in the flags */
3415             convert->flags = nodetype;
3416             DEBUG_r({
3417             optimize = convert
3418                       + NODE_STEP_REGNODE
3419                       + regarglen[ OP( convert ) ];
3420             });
3421             /* XXX We really should free up the resource in trie now,
3422                    as we won't use them - (which resources?) dmq */
3423         }
3424         /* needed for dumping*/
3425         DEBUG_r(if (optimize) {
3426             regnode *opt = convert;
3427
3428             while ( ++opt < optimize) {
3429                 Set_Node_Offset_Length(opt,0,0);
3430             }
3431             /*
3432                 Try to clean up some of the debris left after the
3433                 optimisation.
3434              */
3435             while( optimize < jumper ) {
3436                 mjd_nodelen += Node_Length((optimize));
3437                 OP( optimize ) = OPTIMIZED;
3438                 Set_Node_Offset_Length(optimize,0,0);
3439                 optimize++;
3440             }
3441             Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
3442         });
3443     } /* end node insert */
3444
3445     /*  Finish populating the prev field of the wordinfo array.  Walk back
3446      *  from each accept state until we find another accept state, and if
3447      *  so, point the first word's .prev field at the second word. If the
3448      *  second already has a .prev field set, stop now. This will be the
3449      *  case either if we've already processed that word's accept state,
3450      *  or that state had multiple words, and the overspill words were
3451      *  already linked up earlier.
3452      */
3453     {
3454         U16 word;
3455         U32 state;
3456         U16 prev;
3457
3458         for (word=1; word <= trie->wordcount; word++) {
3459             prev = 0;
3460             if (trie->wordinfo[word].prev)
3461                 continue;
3462             state = trie->wordinfo[word].accept;
3463             while (state) {
3464                 state = prev_states[state];
3465                 if (!state)
3466                     break;
3467                 prev = trie->states[state].wordnum;
3468                 if (prev)
3469                     break;
3470             }
3471             trie->wordinfo[word].prev = prev;
3472         }
3473         Safefree(prev_states);
3474     }
3475
3476
3477     /* and now dump out the compressed format */
3478     DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
3479
3480     RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
3481 #ifdef DEBUGGING
3482     RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
3483     RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
3484 #else
3485     SvREFCNT_dec_NN(revcharmap);
3486 #endif
3487     return trie->jump
3488            ? MADE_JUMP_TRIE
3489            : trie->startstate>1
3490              ? MADE_EXACT_TRIE
3491              : MADE_TRIE;
3492 }
3493
3494 STATIC regnode *
3495 S_construct_ahocorasick_from_trie(pTHX_ RExC_state_t *pRExC_state, regnode *source, U32 depth)
3496 {
3497 /* The Trie is constructed and compressed now so we can build a fail array if
3498  * it's needed
3499
3500    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and
3501    3.32 in the
3502    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi,
3503    Ullman 1985/88
3504    ISBN 0-201-10088-6
3505
3506    We find the fail state for each state in the trie, this state is the longest
3507    proper suffix of the current state's 'word' that is also a proper prefix of
3508    another word in our trie. State 1 represents the word '' and is thus the
3509    default fail state. This allows the DFA not to have to restart after its
3510    tried and failed a word at a given point, it simply continues as though it
3511    had been matching the other word in the first place.
3512    Consider
3513       'abcdgu'=~/abcdefg|cdgu/
3514    When we get to 'd' we are still matching the first word, we would encounter
3515    'g' which would fail, which would bring us to the state representing 'd' in
3516    the second word where we would try 'g' and succeed, proceeding to match
3517    'cdgu'.
3518  */
3519  /* add a fail transition */
3520     const U32 trie_offset = ARG(source);
3521     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
3522     U32 *q;
3523     const U32 ucharcount = trie->uniquecharcount;
3524     const U32 numstates = trie->statecount;
3525     const U32 ubound = trie->lasttrans + ucharcount;
3526     U32 q_read = 0;
3527     U32 q_write = 0;
3528     U32 charid;
3529     U32 base = trie->states[ 1 ].trans.base;
3530     U32 *fail;
3531     reg_ac_data *aho;
3532     const U32 data_slot = add_data( pRExC_state, STR_WITH_LEN("T"));
3533     regnode *stclass;
3534     GET_RE_DEBUG_FLAGS_DECL;
3535
3536     PERL_ARGS_ASSERT_CONSTRUCT_AHOCORASICK_FROM_TRIE;
3537     PERL_UNUSED_CONTEXT;
3538 #ifndef DEBUGGING
3539     PERL_UNUSED_ARG(depth);
3540 #endif
3541
3542     if ( OP(source) == TRIE ) {
3543         struct regnode_1 *op = (struct regnode_1 *)
3544             PerlMemShared_calloc(1, sizeof(struct regnode_1));
3545         StructCopy(source,op,struct regnode_1);
3546         stclass = (regnode *)op;
3547     } else {
3548         struct regnode_charclass *op = (struct regnode_charclass *)
3549             PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
3550         StructCopy(source,op,struct regnode_charclass);
3551         stclass = (regnode *)op;
3552     }
3553     OP(stclass)+=2; /* convert the TRIE type to its AHO-CORASICK equivalent */
3554
3555     ARG_SET( stclass, data_slot );
3556     aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
3557     RExC_rxi->data->data[ data_slot ] = (void*)aho;
3558     aho->trie=trie_offset;
3559     aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
3560     Copy( trie->states, aho->states, numstates, reg_trie_state );
3561     Newxz( q, numstates, U32);
3562     aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
3563     aho->refcount = 1;
3564     fail = aho->fail;
3565     /* initialize fail[0..1] to be 1 so that we always have
3566        a valid final fail state */
3567     fail[ 0 ] = fail[ 1 ] = 1;
3568
3569     for ( charid = 0; charid < ucharcount ; charid++ ) {
3570         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
3571         if ( newstate ) {
3572             q[ q_write ] = newstate;
3573             /* set to point at the root */
3574             fail[ q[ q_write++ ] ]=1;
3575         }
3576     }
3577     while ( q_read < q_write) {
3578         const U32 cur = q[ q_read++ % numstates ];
3579         base = trie->states[ cur ].trans.base;
3580
3581         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
3582             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
3583             if (ch_state) {
3584                 U32 fail_state = cur;
3585                 U32 fail_base;
3586                 do {
3587                     fail_state = fail[ fail_state ];
3588                     fail_base = aho->states[ fail_state ].trans.base;
3589                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
3590
3591                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
3592                 fail[ ch_state ] = fail_state;
3593                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
3594                 {
3595                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
3596                 }
3597                 q[ q_write++ % numstates] = ch_state;
3598             }
3599         }
3600     }
3601     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
3602        when we fail in state 1, this allows us to use the
3603        charclass scan to find a valid start char. This is based on the principle
3604        that theres a good chance the string being searched contains lots of stuff
3605        that cant be a start char.
3606      */
3607     fail[ 0 ] = fail[ 1 ] = 0;
3608     DEBUG_TRIE_COMPILE_r({
3609         Perl_re_indentf( aTHX_  "Stclass Failtable (%" UVuf " states): 0",
3610                       depth, (UV)numstates
3611         );
3612         for( q_read=1; q_read<numstates; q_read++ ) {
3613             Perl_re_printf( aTHX_  ", %" UVuf, (UV)fail[q_read]);
3614         }
3615         Perl_re_printf( aTHX_  "\n");
3616     });
3617     Safefree(q);
3618     /*RExC_seen |= REG_TRIEDFA_SEEN;*/
3619     return stclass;
3620 }
3621
3622
3623 #define DEBUG_PEEP(str,scan,depth)         \
3624     DEBUG_OPTIMISE_r({if (scan){           \
3625        regnode *Next = regnext(scan);      \
3626        regprop(RExC_rx, RExC_mysv, scan, NULL, pRExC_state);\
3627        Perl_re_indentf( aTHX_  "" str ">%3d: %s (%d)", \
3628            depth, REG_NODE_NUM(scan), SvPV_nolen_const(RExC_mysv),\
3629            Next ? (REG_NODE_NUM(Next)) : 0 );\
3630        DEBUG_SHOW_STUDY_FLAGS(flags," [ ","]");\
3631        Perl_re_printf( aTHX_  "\n");                   \
3632    }});
3633
3634 /* The below joins as many adjacent EXACTish nodes as possible into a single
3635  * one.  The regop may be changed if the node(s) contain certain sequences that
3636  * require special handling.  The joining is only done if:
3637  * 1) there is room in the current conglomerated node to entirely contain the
3638  *    next one.
3639  * 2) they are the exact same node type
3640  *
3641  * The adjacent nodes actually may be separated by NOTHING-kind nodes, and
3642  * these get optimized out
3643  *
3644  * XXX khw thinks this should be enhanced to fill EXACT (at least) nodes as full
3645  * as possible, even if that means splitting an existing node so that its first
3646  * part is moved to the preceeding node.  This would maximise the efficiency of
3647  * memEQ during matching.  Elsewhere in this file, khw proposes splitting
3648  * EXACTFish nodes into portions that don't change under folding vs those that
3649  * do.  Those portions that don't change may be the only things in the pattern that
3650  * could be used to find fixed and floating strings.
3651  *
3652  * If a node is to match under /i (folded), the number of characters it matches
3653  * can be different than its character length if it contains a multi-character
3654  * fold.  *min_subtract is set to the total delta number of characters of the
3655  * input nodes.
3656  *
3657  * And *unfolded_multi_char is set to indicate whether or not the node contains
3658  * an unfolded multi-char fold.  This happens when whether the fold is valid or
3659  * not won't be known until runtime; namely for EXACTF nodes that contain LATIN
3660  * SMALL LETTER SHARP S, as only if the target string being matched against
3661  * turns out to be UTF-8 is that fold valid; and also for EXACTFL nodes whose
3662  * folding rules depend on the locale in force at runtime.  (Multi-char folds
3663  * whose components are all above the Latin1 range are not run-time locale
3664  * dependent, and have already been folded by the time this function is
3665  * called.)
3666  *
3667  * This is as good a place as any to discuss the design of handling these
3668  * multi-character fold sequences.  It's been wrong in Perl for a very long
3669  * time.  There are three code points in Unicode whose multi-character folds
3670  * were long ago discovered to mess things up.  The previous designs for
3671  * dealing with these involved assigning a special node for them.  This
3672  * approach doesn't always work, as evidenced by this example:
3673  *      "\xDFs" =~ /s\xDF/ui    # Used to fail before these patches
3674  * Both sides fold to "sss", but if the pattern is parsed to create a node that
3675  * would match just the \xDF, it won't be able to handle the case where a
3676  * successful match would have to cross the node's boundary.  The new approach
3677  * that hopefully generally solves the problem generates an EXACTFU_SS node
3678  * that is "sss" in this case.
3679  *
3680  * It turns out that there are problems with all multi-character folds, and not
3681  * just these three.  Now the code is general, for all such cases.  The
3682  * approach taken is:
3683  * 1)   This routine examines each EXACTFish node that could contain multi-
3684  *      character folded sequences.  Since a single character can fold into
3685  *      such a sequence, the minimum match length for this node is less than
3686  *      the number of characters in the node.  This routine returns in
3687  *      *min_subtract how many characters to subtract from the the actual
3688  *      length of the string to get a real minimum match length; it is 0 if
3689  *      there are no multi-char foldeds.  This delta is used by the caller to
3690  *      adjust the min length of the match, and the delta between min and max,
3691  *      so that the optimizer doesn't reject these possibilities based on size
3692  *      constraints.
3693  * 2)   For the sequence involving the Sharp s (\xDF), the node type EXACTFU_SS
3694  *      is used for an EXACTFU node that contains at least one "ss" sequence in
3695  *      it.  For non-UTF-8 patterns and strings, this is the only case where
3696  *      there is a possible fold length change.  That means that a regular
3697  *      EXACTFU node without UTF-8 involvement doesn't have to concern itself
3698  *      with length changes, and so can be processed faster.  regexec.c takes
3699  *      advantage of this.  Generally, an EXACTFish node that is in UTF-8 is
3700  *      pre-folded by regcomp.c (except EXACTFL, some of whose folds aren't
3701  *      known until runtime).  This saves effort in regex matching.  However,
3702  *      the pre-folding isn't done for non-UTF8 patterns because the fold of
3703  *      the MICRO SIGN requires UTF-8, and we don't want to slow things down by
3704  *      forcing the pattern into UTF8 unless necessary.  Also what EXACTF (and,
3705  *      again, EXACTFL) nodes fold to isn't known until runtime.  The fold
3706  *      possibilities for the non-UTF8 patterns are quite simple, except for
3707  *      the sharp s.  All the ones that don't involve a UTF-8 target string are
3708  *      members of a fold-pair, and arrays are set up for all of them so that
3709  *      the other member of the pair can be found quickly.  Code elsewhere in
3710  *      this file makes sure that in EXACTFU nodes, the sharp s gets folded to
3711  *      'ss', even if the pattern isn't UTF-8.  This avoids the issues
3712  *      described in the next item.
3713  * 3)   A problem remains for unfolded multi-char folds. (These occur when the
3714  *      validity of the fold won't be known until runtime, and so must remain
3715  *      unfolded for now.  This happens for the sharp s in EXACTF and EXACTFA
3716  *      nodes when the pattern isn't in UTF-8.  (Note, BTW, that there cannot
3717  *      be an EXACTF node with a UTF-8 pattern.)  They also occur for various
3718  *      folds in EXACTFL nodes, regardless of the UTF-ness of the pattern.)
3719  *      The reason this is a problem is that the optimizer part of regexec.c
3720  *      (probably unwittingly, in Perl_regexec_flags()) makes an assumption
3721  *      that a character in the pattern corresponds to at most a single
3722  *      character in the target string.  (And I do mean character, and not byte
3723  *      here, unlike other parts of the documentation that have never been
3724  *      updated to account for multibyte Unicode.)  sharp s in EXACTF and
3725  *      EXACTFL nodes can match the two character string 'ss'; in EXACTFA nodes
3726  *      it can match "\x{17F}\x{17F}".  These, along with other ones in EXACTFL
3727  *      nodes, violate the assumption, and they are the only instances where it
3728  *      is violated.  I'm reluctant to try to change the assumption, as the
3729  *      code involved is impenetrable to me (khw), so instead the code here
3730  *      punts.  This routine examines EXACTFL nodes, and (when the pattern
3731  *      isn't UTF-8) EXACTF and EXACTFA for such unfolded folds, and returns a
3732  *      boolean indicating whether or not the node contains such a fold.  When
3733  *      it is true, the caller sets a flag that later causes the optimizer in
3734  *      this file to not set values for the floating and fixed string lengths,
3735  *      and thus avoids the optimizer code in regexec.c that makes the invalid
3736  *      assumption.  Thus, there is no optimization based on string lengths for
3737  *      EXACTFL nodes that contain these few folds, nor for non-UTF8-pattern
3738  *      EXACTF and EXACTFA nodes that contain the sharp s.  (The reason the
3739  *      assumption is wrong only in these cases is that all other non-UTF-8
3740  *      folds are 1-1; and, for UTF-8 patterns, we pre-fold all other folds to
3741  *      their expanded versions.  (Again, we can't prefold sharp s to 'ss' in
3742  *      EXACTF nodes because we don't know at compile time if it actually
3743  *      matches 'ss' or not.  For EXACTF nodes it will match iff the target
3744  *      string is in UTF-8.  This is in contrast to EXACTFU nodes, where it
3745  *      always matches; and EXACTFA where it never does.  In an EXACTFA node in
3746  *      a UTF-8 pattern, sharp s is folded to "\x{17F}\x{17F}, avoiding the
3747  *      problem; but in a non-UTF8 pattern, folding it to that above-Latin1
3748  *      string would require the pattern to be forced into UTF-8, the overhead
3749  *      of which we want to avoid.  Similarly the unfolded multi-char folds in
3750  *      EXACTFL nodes will match iff the locale at the time of match is a UTF-8
3751  *      locale.)
3752  *
3753  *      Similarly, the code that generates tries doesn't currently handle
3754  *      not-already-folded multi-char folds, and it looks like a pain to change
3755  *      that.  Therefore, trie generation of EXACTFA nodes with the sharp s
3756  *      doesn't work.  Instead, such an EXACTFA is turned into a new regnode,
3757  *      EXACTFA_NO_TRIE, which the trie code knows not to handle.  Most people
3758  *      using /iaa matching will be doing so almost entirely with ASCII
3759  *      strings, so this should rarely be encountered in practice */
3760
3761 #define JOIN_EXACT(scan,min_subtract,unfolded_multi_char, flags) \
3762     if (PL_regkind[OP(scan)] == EXACT) \
3763         join_exact(pRExC_state,(scan),(min_subtract),unfolded_multi_char, (flags),NULL,depth+1)
3764
3765 STATIC U32
3766 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan,
3767                    UV *min_subtract, bool *unfolded_multi_char,
3768                    U32 flags,regnode *val, U32 depth)
3769 {
3770     /* Merge several consecutive EXACTish nodes into one. */
3771     regnode *n = regnext(scan);
3772     U32 stringok = 1;
3773     regnode *next = scan + NODE_SZ_STR(scan);
3774     U32 merged = 0;
3775     U32 stopnow = 0;
3776 #ifdef DEBUGGING
3777     regnode *stop = scan;
3778     GET_RE_DEBUG_FLAGS_DECL;
3779 #else
3780     PERL_UNUSED_ARG(depth);
3781 #endif
3782
3783     PERL_ARGS_ASSERT_JOIN_EXACT;
3784 #ifndef EXPERIMENTAL_INPLACESCAN
3785     PERL_UNUSED_ARG(flags);
3786     PERL_UNUSED_ARG(val);
3787 #endif
3788     DEBUG_PEEP("join",scan,depth);
3789
3790     /* Look through the subsequent nodes in the chain.  Skip NOTHING, merge
3791      * EXACT ones that are mergeable to the current one. */
3792     while (n
3793            && (PL_regkind[OP(n)] == NOTHING
3794                || (stringok && OP(n) == OP(scan)))
3795            && NEXT_OFF(n)
3796            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
3797     {
3798
3799         if (OP(n) == TAIL || n > next)
3800             stringok = 0;
3801         if (PL_regkind[OP(n)] == NOTHING) {
3802             DEBUG_PEEP("skip:",n,depth);
3803             NEXT_OFF(scan) += NEXT_OFF(n);
3804             next = n + NODE_STEP_REGNODE;
3805 #ifdef DEBUGGING
3806             if (stringok)
3807                 stop = n;
3808 #endif
3809             n = regnext(n);
3810         }
3811         else if (stringok) {
3812             const unsigned int oldl = STR_LEN(scan);
3813             regnode * const nnext = regnext(n);
3814
3815             /* XXX I (khw) kind of doubt that this works on platforms (should
3816              * Perl ever run on one) where U8_MAX is above 255 because of lots
3817              * of other assumptions */
3818             /* Don't join if the sum can't fit into a single node */
3819             if (oldl + STR_LEN(n) > U8_MAX)
3820                 break;
3821
3822             DEBUG_PEEP("merg",n,depth);
3823             merged++;
3824
3825             NEXT_OFF(scan) += NEXT_OFF(n);
3826             STR_LEN(scan) += STR_LEN(n);
3827             next = n + NODE_SZ_STR(n);
3828             /* Now we can overwrite *n : */
3829             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
3830 #ifdef DEBUGGING
3831             stop = next - 1;
3832 #endif
3833             n = nnext;
3834             if (stopnow) break;
3835         }
3836
3837 #ifdef EXPERIMENTAL_INPLACESCAN
3838         if (flags && !NEXT_OFF(n)) {
3839             DEBUG_PEEP("atch", val, depth);
3840             if (reg_off_by_arg[OP(n)]) {
3841                 ARG_SET(n, val - n);
3842             }
3843             else {
3844                 NEXT_OFF(n) = val - n;
3845             }
3846             stopnow = 1;
3847         }
3848 #endif
3849     }
3850
3851     *min_subtract = 0;
3852     *unfolded_multi_char = FALSE;
3853
3854     /* Here, all the adjacent mergeable EXACTish nodes have been merged.  We
3855      * can now analyze for sequences of problematic code points.  (Prior to
3856      * this final joining, sequences could have been split over boundaries, and
3857      * hence missed).  The sequences only happen in folding, hence for any
3858      * non-EXACT EXACTish node */
3859     if (OP(scan) != EXACT && OP(scan) != EXACTL) {
3860         U8* s0 = (U8*) STRING(scan);
3861         U8* s = s0;
3862         U8* s_end = s0 + STR_LEN(scan);
3863
3864         int total_count_delta = 0;  /* Total delta number of characters that
3865                                        multi-char folds expand to */
3866
3867         /* One pass is made over the node's string looking for all the
3868          * possibilities.  To avoid some tests in the loop, there are two main
3869          * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
3870          * non-UTF-8 */
3871         if (UTF) {
3872             U8* folded = NULL;
3873
3874             if (OP(scan) == EXACTFL) {
3875                 U8 *d;
3876
3877                 /* An EXACTFL node would already have been changed to another
3878                  * node type unless there is at least one character in it that
3879                  * is problematic; likely a character whose fold definition
3880                  * won't be known until runtime, and so has yet to be folded.
3881                  * For all but the UTF-8 locale, folds are 1-1 in length, but
3882                  * to handle the UTF-8 case, we need to create a temporary
3883                  * folded copy using UTF-8 locale rules in order to analyze it.
3884                  * This is because our macros that look to see if a sequence is
3885                  * a multi-char fold assume everything is folded (otherwise the
3886                  * tests in those macros would be too complicated and slow).
3887                  * Note that here, the non-problematic folds will have already
3888                  * been done, so we can just copy such characters.  We actually
3889                  * don't completely fold the EXACTFL string.  We skip the
3890                  * unfolded multi-char folds, as that would just create work
3891                  * below to figure out the size they already are */
3892
3893                 Newx(folded, UTF8_MAX_FOLD_CHAR_EXPAND * STR_LEN(scan) + 1, U8);
3894                 d = folded;
3895                 while (s < s_end) {
3896                     STRLEN s_len = UTF8SKIP(s);
3897                     if (! is_PROBLEMATIC_LOCALE_FOLD_utf8(s)) {
3898                         Copy(s, d, s_len, U8);
3899                         d += s_len;
3900                     }
3901                     else if (is_FOLDS_TO_MULTI_utf8(s)) {
3902                         *unfolded_multi_char = TRUE;
3903                         Copy(s, d, s_len, U8);
3904                         d += s_len;
3905                     }
3906                     else if (isASCII(*s)) {
3907                         *(d++) = toFOLD(*s);
3908                     }
3909                     else {
3910                         STRLEN len;
3911                         _toFOLD_utf8_flags(s, s_end, d, &len, FOLD_FLAGS_FULL);
3912                         d += len;
3913                     }
3914                     s += s_len;
3915                 }
3916
3917                 /* Point the remainder of the routine to look at our temporary
3918                  * folded copy */
3919                 s = folded;
3920                 s_end = d;
3921             } /* End of creating folded copy of EXACTFL string */
3922
3923             /* Examine the string for a multi-character fold sequence.  UTF-8
3924              * patterns have all characters pre-folded by the time this code is
3925              * executed */
3926             while (s < s_end - 1) /* Can stop 1 before the end, as minimum
3927                                      length sequence we are looking for is 2 */
3928             {
3929                 int count = 0;  /* How many characters in a multi-char fold */
3930                 int len = is_MULTI_CHAR_FOLD_utf8_safe(s, s_end);
3931                 if (! len) {    /* Not a multi-char fold: get next char */
3932                     s += UTF8SKIP(s);
3933                     continue;
3934                 }
3935
3936                 /* Nodes with 'ss' require special handling, except for
3937                  * EXACTFA-ish for which there is no multi-char fold to this */
3938                 if (len == 2 && *s == 's' && *(s+1) == 's'
3939                     && OP(scan) != EXACTFA
3940                     && OP(scan) != EXACTFA_NO_TRIE)
3941                 {
3942                     count = 2;
3943                     if (OP(scan) != EXACTFL) {
3944                         OP(scan) = EXACTFU_SS;
3945                     }
3946                     s += 2;
3947                 }
3948                 else { /* Here is a generic multi-char fold. */
3949                     U8* multi_end  = s + len;
3950
3951                     /* Count how many characters are in it.  In the case of
3952                      * /aa, no folds which contain ASCII code points are
3953                      * allowed, so check for those, and skip if found. */
3954                     if (OP(scan) != EXACTFA && OP(scan) != EXACTFA_NO_TRIE) {
3955                         count = utf8_length(s, multi_end);
3956                         s = multi_end;
3957                     }
3958                     else {
3959                         while (s < multi_end) {
3960                             if (isASCII(*s)) {
3961                                 s++;
3962                                 goto next_iteration;
3963                             }
3964                             else {
3965                                 s += UTF8SKIP(s);
3966                             }
3967                             count++;
3968                         }
3969                     }
3970                 }
3971
3972                 /* The delta is how long the sequence is minus 1 (1 is how long
3973                  * the character that folds to the sequence is) */
3974                 total_count_delta += count - 1;
3975               next_iteration: ;
3976             }
3977
3978             /* We created a temporary folded copy of the string in EXACTFL
3979              * nodes.  Therefore we need to be sure&nbs