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