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