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