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