]> git.vpit.fr Git - perl/modules/re-engine-Hooks.git/blob - src/5016003/regcomp.c
Remove obsolete kwalitee workarounds
[perl/modules/re-engine-Hooks.git] / src / 5016003 / regcomp.c
1 /*    regcomp.c
2  */
3
4 /*
5  * 'A fair jaw-cracker dwarf-language must be.'            --Samwise Gamgee
6  *
7  *     [p.285 of _The Lord of the Rings_, II/iii: "The Ring Goes South"]
8  */
9
10 /* This file contains functions for compiling a regular expression.  See
11  * also regexec.c which funnily enough, contains functions for executing
12  * a regular expression.
13  *
14  * This file is also copied at build time to ext/re/re_comp.c, where
15  * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
16  * This causes the main functions to be compiled under new names and with
17  * debugging support added, which makes "use re 'debug'" work.
18  */
19
20 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
21  * confused with the original package (see point 3 below).  Thanks, Henry!
22  */
23
24 /* Additional note: this code is very heavily munged from Henry's version
25  * in places.  In some spots I've traded clarity for efficiency, so don't
26  * blame Henry for some of the lack of readability.
27  */
28
29 /* The names of the functions have been changed from regcomp and
30  * regexec to pregcomp and pregexec in order to avoid conflicts
31  * with the POSIX routines of the same names.
32 */
33
34 #ifdef PERL_EXT_RE_BUILD
35 #include "re_top.h"
36 #endif
37
38 /*
39  * pregcomp and pregexec -- regsub and regerror are not used in perl
40  *
41  * Copyright (c) 1986 by University of Toronto.
42  * Written by Henry Spencer.  Not derived from licensed software.
43  *
44  * Permission is granted to anyone to use this software for any
45  * purpose on any computer system, and to redistribute it freely,
46  * subject to the following restrictions:
47  *
48  * 1. The author is not responsible for the consequences of use of
49  *  this software, no matter how awful, even if they arise
50  *  from defects in it.
51  *
52  * 2. The origin of this software must not be misrepresented, either
53  *  by explicit claim or by omission.
54  *
55  * 3. Altered versions must be plainly marked as such, and must not
56  *  be misrepresented as being the original software.
57  *
58  *
59  ****    Alterations to Henry's code are...
60  ****
61  ****    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
62  ****    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
63  ****    by Larry Wall and others
64  ****
65  ****    You may distribute under the terms of either the GNU General Public
66  ****    License or the Artistic License, as specified in the README file.
67
68  *
69  * Beware that some of this code is subtly aware of the way operator
70  * precedence is structured in regular expressions.  Serious changes in
71  * regular-expression syntax might require a total rethink.
72  */
73 #include "EXTERN.h"
74 #define PERL_IN_REGCOMP_C
75 #include "perl.h"
76
77 #ifndef PERL_IN_XSUB_RE
78 #include "re_defs.h"
79 #endif
80
81 #define REG_COMP_C
82 #ifdef PERL_IN_XSUB_RE
83 #  include "re_comp.h"
84 #else
85 #  include "regcomp.h"
86 #endif
87
88 #include "dquote_static.c"
89 #ifndef PERL_IN_XSUB_RE
90 #  include "charclass_invlists.h"
91 #endif
92
93 #ifdef op
94 #undef op
95 #endif /* op */
96
97 #ifdef MSDOS
98 #  if defined(BUGGY_MSC6)
99  /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
100 #    pragma optimize("a",off)
101  /* But MSC 6.00A is happy with 'w', for aliases only across function calls*/
102 #    pragma optimize("w",on )
103 #  endif /* BUGGY_MSC6 */
104 #endif /* MSDOS */
105
106 #ifndef STATIC
107 #define STATIC static
108 #endif
109
110 typedef struct RExC_state_t {
111  U32  flags;   /* are we folding, multilining? */
112  char *precomp;  /* uncompiled string. */
113  REGEXP *rx_sv;   /* The SV that is the regexp. */
114  regexp *rx;                    /* perl core regexp structure */
115  regexp_internal *rxi;           /* internal data for regexp object pprivate field */
116  char *start;   /* Start of input for compile */
117  char *end;   /* End of input for compile */
118  char *parse;   /* Input-scan pointer. */
119  I32  whilem_seen;  /* number of WHILEM in this expr */
120  regnode *emit_start;  /* Start of emitted-code area */
121  regnode *emit_bound;  /* First regnode outside of the allocated space */
122  regnode *emit;   /* Code-emit pointer; &regdummy = don't = compiling */
123  I32  naughty;  /* How bad is this pattern? */
124  I32  sawback;  /* Did we see \1, ...? */
125  U32  seen;
126  I32  size;   /* Code size. */
127  I32  npar;   /* Capture buffer count, (OPEN). */
128  I32  cpar;   /* Capture buffer count, (CLOSE). */
129  I32  nestroot;  /* root parens we are in - used by accept */
130  I32  extralen;
131  I32  seen_zerolen;
132  I32  seen_evals;
133  regnode **open_parens;  /* pointers to open parens */
134  regnode **close_parens;  /* pointers to close parens */
135  regnode *opend;   /* END node in program */
136  I32  utf8;  /* whether the pattern is utf8 or not */
137  I32  orig_utf8; /* whether the pattern was originally in utf8 */
138         /* XXX use this for future optimisation of case
139         * where pattern must be upgraded to utf8. */
140  I32  uni_semantics; /* If a d charset modifier should use unicode
141         rules, even if the pattern is not in
142         utf8 */
143  HV  *paren_names;  /* Paren names */
144
145  regnode **recurse;  /* Recurse regops */
146  I32  recurse_count;  /* Number of recurse regops */
147  I32  in_lookbehind;
148  I32  contains_locale;
149  I32  override_recoding;
150 #if ADD_TO_REGEXEC
151  char  *starttry;  /* -Dr: where regtry was called. */
152 #define RExC_starttry (pRExC_state->starttry)
153 #endif
154 #ifdef DEBUGGING
155  const char  *lastparse;
156  I32         lastnum;
157  AV          *paren_name_list;       /* idx -> name */
158 #define RExC_lastparse (pRExC_state->lastparse)
159 #define RExC_lastnum (pRExC_state->lastnum)
160 #define RExC_paren_name_list    (pRExC_state->paren_name_list)
161 #endif
162 } RExC_state_t;
163
164 #define RExC_flags (pRExC_state->flags)
165 #define RExC_precomp (pRExC_state->precomp)
166 #define RExC_rx_sv (pRExC_state->rx_sv)
167 #define RExC_rx  (pRExC_state->rx)
168 #define RExC_rxi (pRExC_state->rxi)
169 #define RExC_start (pRExC_state->start)
170 #define RExC_end (pRExC_state->end)
171 #define RExC_parse (pRExC_state->parse)
172 #define RExC_whilem_seen (pRExC_state->whilem_seen)
173 #ifdef RE_TRACK_PATTERN_OFFSETS
174 #define RExC_offsets (pRExC_state->rxi->u.offsets) /* I am not like the others */
175 #endif
176 #define RExC_emit (pRExC_state->emit)
177 #define RExC_emit_start (pRExC_state->emit_start)
178 #define RExC_emit_bound (pRExC_state->emit_bound)
179 #define RExC_naughty (pRExC_state->naughty)
180 #define RExC_sawback (pRExC_state->sawback)
181 #define RExC_seen (pRExC_state->seen)
182 #define RExC_size (pRExC_state->size)
183 #define RExC_npar (pRExC_state->npar)
184 #define RExC_nestroot   (pRExC_state->nestroot)
185 #define RExC_extralen (pRExC_state->extralen)
186 #define RExC_seen_zerolen (pRExC_state->seen_zerolen)
187 #define RExC_seen_evals (pRExC_state->seen_evals)
188 #define RExC_utf8 (pRExC_state->utf8)
189 #define RExC_uni_semantics (pRExC_state->uni_semantics)
190 #define RExC_orig_utf8 (pRExC_state->orig_utf8)
191 #define RExC_open_parens (pRExC_state->open_parens)
192 #define RExC_close_parens (pRExC_state->close_parens)
193 #define RExC_opend (pRExC_state->opend)
194 #define RExC_paren_names (pRExC_state->paren_names)
195 #define RExC_recurse (pRExC_state->recurse)
196 #define RExC_recurse_count (pRExC_state->recurse_count)
197 #define RExC_in_lookbehind (pRExC_state->in_lookbehind)
198 #define RExC_contains_locale (pRExC_state->contains_locale)
199 #define RExC_override_recoding (pRExC_state->override_recoding)
200
201
202 #define ISMULT1(c) ((c) == '*' || (c) == '+' || (c) == '?')
203 #define ISMULT2(s) ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
204   ((*s) == '{' && regcurly(s)))
205
206 #ifdef SPSTART
207 #undef SPSTART  /* dratted cpp namespace... */
208 #endif
209 /*
210  * Flags to be passed up and down.
211  */
212 #define WORST  0 /* Worst case. */
213 #define HASWIDTH 0x01 /* Known to match non-null strings. */
214
215 /* Simple enough to be STAR/PLUS operand, in an EXACT node must be a single
216  * character, and if utf8, must be invariant.  Note that this is not the same thing as REGNODE_SIMPLE */
217 #define SIMPLE  0x02
218 #define SPSTART  0x04 /* Starts with * or +. */
219 #define TRYAGAIN 0x08 /* Weeded out a declaration. */
220 #define POSTPONED 0x10    /* (?1),(?&name), (??{...}) or similar */
221
222 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
223
224 /* whether trie related optimizations are enabled */
225 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
226 #define TRIE_STUDY_OPT
227 #define FULL_TRIE_STUDY
228 #define TRIE_STCLASS
229 #endif
230
231
232
233 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
234 #define PBITVAL(paren) (1 << ((paren) & 7))
235 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
236 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
237 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
238
239 /* If not already in utf8, do a longjmp back to the beginning */
240 #define UTF8_LONGJMP 42 /* Choose a value not likely to ever conflict */
241 #define REQUIRE_UTF8 STMT_START {                                       \
242          if (! UTF) JMPENV_JUMP(UTF8_LONGJMP); \
243       } STMT_END
244
245 /* About scan_data_t.
246
247   During optimisation we recurse through the regexp program performing
248   various inplace (keyhole style) optimisations. In addition study_chunk
249   and scan_commit populate this data structure with information about
250   what strings MUST appear in the pattern. We look for the longest
251   string that must appear at a fixed location, and we look for the
252   longest string that may appear at a floating location. So for instance
253   in the pattern:
254
255  /FOO[xX]A.*B[xX]BAR/
256
257   Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
258   strings (because they follow a .* construct). study_chunk will identify
259   both FOO and BAR as being the longest fixed and floating strings respectively.
260
261   The strings can be composites, for instance
262
263  /(f)(o)(o)/
264
265   will result in a composite fixed substring 'foo'.
266
267   For each string some basic information is maintained:
268
269   - offset or min_offset
270  This is the position the string must appear at, or not before.
271  It also implicitly (when combined with minlenp) tells us how many
272  characters must match before the string we are searching for.
273  Likewise when combined with minlenp and the length of the string it
274  tells us how many characters must appear after the string we have
275  found.
276
277   - max_offset
278  Only used for floating strings. This is the rightmost point that
279  the string can appear at. If set to I32 max it indicates that the
280  string can occur infinitely far to the right.
281
282   - minlenp
283  A pointer to the minimum length of the pattern that the string
284  was found inside. This is important as in the case of positive
285  lookahead or positive lookbehind we can have multiple patterns
286  involved. Consider
287
288  /(?=FOO).*F/
289
290  The minimum length of the pattern overall is 3, the minimum length
291  of the lookahead part is 3, but the minimum length of the part that
292  will actually match is 1. So 'FOO's minimum length is 3, but the
293  minimum length for the F is 1. This is important as the minimum length
294  is used to determine offsets in front of and behind the string being
295  looked for.  Since strings can be composites this is the length of the
296  pattern at the time it was committed with a scan_commit. Note that
297  the length is calculated by study_chunk, so that the minimum lengths
298  are not known until the full pattern has been compiled, thus the
299  pointer to the value.
300
301   - lookbehind
302
303  In the case of lookbehind the string being searched for can be
304  offset past the start point of the final matching string.
305  If this value was just blithely removed from the min_offset it would
306  invalidate some of the calculations for how many chars must match
307  before or after (as they are derived from min_offset and minlen and
308  the length of the string being searched for).
309  When the final pattern is compiled and the data is moved from the
310  scan_data_t structure into the regexp structure the information
311  about lookbehind is factored in, with the information that would
312  have been lost precalculated in the end_shift field for the
313  associated string.
314
315   The fields pos_min and pos_delta are used to store the minimum offset
316   and the delta to the maximum offset at the current point in the pattern.
317
318 */
319
320 typedef struct scan_data_t {
321  /*I32 len_min;      unused */
322  /*I32 len_delta;    unused */
323  I32 pos_min;
324  I32 pos_delta;
325  SV *last_found;
326  I32 last_end;     /* min value, <0 unless valid. */
327  I32 last_start_min;
328  I32 last_start_max;
329  SV **longest;     /* Either &l_fixed, or &l_float. */
330  SV *longest_fixed;      /* longest fixed string found in pattern */
331  I32 offset_fixed;       /* offset where it starts */
332  I32 *minlen_fixed;      /* pointer to the minlen relevant to the string */
333  I32 lookbehind_fixed;   /* is the position of the string modfied by LB */
334  SV *longest_float;      /* longest floating string found in pattern */
335  I32 offset_float_min;   /* earliest point in string it can appear */
336  I32 offset_float_max;   /* latest point in string it can appear */
337  I32 *minlen_float;      /* pointer to the minlen relevant to the string */
338  I32 lookbehind_float;   /* is the position of the string modified by LB */
339  I32 flags;
340  I32 whilem_c;
341  I32 *last_closep;
342  struct regnode_charclass_class *start_class;
343 } scan_data_t;
344
345 /*
346  * Forward declarations for pregcomp()'s friends.
347  */
348
349 static const scan_data_t zero_scan_data =
350   { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,0};
351
352 #define SF_BEFORE_EOL  (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
353 #define SF_BEFORE_SEOL  0x0001
354 #define SF_BEFORE_MEOL  0x0002
355 #define SF_FIX_BEFORE_EOL (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
356 #define SF_FL_BEFORE_EOL (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
357
358 #ifdef NO_UNARY_PLUS
359 #  define SF_FIX_SHIFT_EOL (0+2)
360 #  define SF_FL_SHIFT_EOL  (0+4)
361 #else
362 #  define SF_FIX_SHIFT_EOL (+2)
363 #  define SF_FL_SHIFT_EOL  (+4)
364 #endif
365
366 #define SF_FIX_BEFORE_SEOL (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
367 #define SF_FIX_BEFORE_MEOL (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
368
369 #define SF_FL_BEFORE_SEOL (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
370 #define SF_FL_BEFORE_MEOL (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
371 #define SF_IS_INF  0x0040
372 #define SF_HAS_PAR  0x0080
373 #define SF_IN_PAR  0x0100
374 #define SF_HAS_EVAL  0x0200
375 #define SCF_DO_SUBSTR  0x0400
376 #define SCF_DO_STCLASS_AND 0x0800
377 #define SCF_DO_STCLASS_OR 0x1000
378 #define SCF_DO_STCLASS  (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
379 #define SCF_WHILEM_VISITED_POS 0x2000
380
381 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
382 #define SCF_SEEN_ACCEPT         0x8000
383
384 #define UTF cBOOL(RExC_utf8)
385
386 /* The enums for all these are ordered so things work out correctly */
387 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
388 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_DEPENDS_CHARSET)
389 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
390 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags) >= REGEX_UNICODE_CHARSET)
391 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_RESTRICTED_CHARSET)
392 #define MORE_ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
393 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags) >= REGEX_ASCII_RESTRICTED_CHARSET)
394
395 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
396
397 #define OOB_UNICODE  12345678
398 #define OOB_NAMEDCLASS  -1
399
400 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
401 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
402
403
404 /* length of regex to show in messages that don't mark a position within */
405 #define RegexLengthToShowInErrorMessages 127
406
407 /*
408  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
409  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
410  * op/pragma/warn/regcomp.
411  */
412 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
413 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
414
415 #define REPORT_LOCATION " in regex; marked by " MARKER1 " in m/%.*s" MARKER2 "%s/"
416
417 /*
418  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
419  * arg. Show regex, up to a maximum length. If it's too long, chop and add
420  * "...".
421  */
422 #define _FAIL(code) STMT_START {     \
423  const char *ellipses = "";      \
424  IV len = RExC_end - RExC_precomp;     \
425                   \
426  if (!SIZE_ONLY)       \
427   SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv);   \
428  if (len > RegexLengthToShowInErrorMessages) {   \
429   /* chop 10 shorter than the max, to ensure meaning of "..." */ \
430   len = RegexLengthToShowInErrorMessages - 10;   \
431   ellipses = "...";      \
432  }         \
433  code;                                                               \
434 } STMT_END
435
436 #define FAIL(msg) _FAIL(       \
437  Perl_croak(aTHX_ "%s in regex m/%.*s%s/",     \
438    msg, (int)len, RExC_precomp, ellipses))
439
440 #define FAIL2(msg,arg) _FAIL(       \
441  Perl_croak(aTHX_ msg " in regex m/%.*s%s/",     \
442    arg, (int)len, RExC_precomp, ellipses))
443
444 /*
445  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
446  */
447 #define Simple_vFAIL(m) STMT_START {     \
448  const IV offset = RExC_parse - RExC_precomp;   \
449  Perl_croak(aTHX_ "%s" REPORT_LOCATION,    \
450    m, (int)offset, RExC_precomp, RExC_precomp + offset); \
451 } STMT_END
452
453 /*
454  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
455  */
456 #define vFAIL(m) STMT_START {    \
457  if (!SIZE_ONLY)     \
458   SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \
459  Simple_vFAIL(m);     \
460 } STMT_END
461
462 /*
463  * Like Simple_vFAIL(), but accepts two arguments.
464  */
465 #define Simple_vFAIL2(m,a1) STMT_START {   \
466  const IV offset = RExC_parse - RExC_precomp;   \
467  S_re_croak2(aTHX_ m, REPORT_LOCATION, a1,   \
468    (int)offset, RExC_precomp, RExC_precomp + offset); \
469 } STMT_END
470
471 /*
472  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
473  */
474 #define vFAIL2(m,a1) STMT_START {   \
475  if (!SIZE_ONLY)     \
476   SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \
477  Simple_vFAIL2(m, a1);    \
478 } STMT_END
479
480
481 /*
482  * Like Simple_vFAIL(), but accepts three arguments.
483  */
484 #define Simple_vFAIL3(m, a1, a2) STMT_START {   \
485  const IV offset = RExC_parse - RExC_precomp;  \
486  S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2,  \
487    (int)offset, RExC_precomp, RExC_precomp + offset); \
488 } STMT_END
489
490 /*
491  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
492  */
493 #define vFAIL3(m,a1,a2) STMT_START {   \
494  if (!SIZE_ONLY)     \
495   SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \
496  Simple_vFAIL3(m, a1, a2);    \
497 } STMT_END
498
499 /*
500  * Like Simple_vFAIL(), but accepts four arguments.
501  */
502 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {  \
503  const IV offset = RExC_parse - RExC_precomp;  \
504  S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3,  \
505    (int)offset, RExC_precomp, RExC_precomp + offset); \
506 } STMT_END
507
508 #define ckWARNreg(loc,m) STMT_START {     \
509  const IV offset = loc - RExC_precomp;    \
510  Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
511    (int)offset, RExC_precomp, RExC_precomp + offset);  \
512 } STMT_END
513
514 #define ckWARNregdep(loc,m) STMT_START {    \
515  const IV offset = loc - RExC_precomp;    \
516  Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP), \
517    m REPORT_LOCATION,      \
518    (int)offset, RExC_precomp, RExC_precomp + offset);  \
519 } STMT_END
520
521 #define ckWARN2regdep(loc,m, a1) STMT_START {    \
522  const IV offset = loc - RExC_precomp;    \
523  Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP), \
524    m REPORT_LOCATION,      \
525    a1, (int)offset, RExC_precomp, RExC_precomp + offset); \
526 } STMT_END
527
528 #define ckWARN2reg(loc, m, a1) STMT_START {    \
529  const IV offset = loc - RExC_precomp;    \
530  Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
531    a1, (int)offset, RExC_precomp, RExC_precomp + offset); \
532 } STMT_END
533
534 #define vWARN3(loc, m, a1, a2) STMT_START {    \
535  const IV offset = loc - RExC_precomp;    \
536  Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,  \
537    a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset); \
538 } STMT_END
539
540 #define ckWARN3reg(loc, m, a1, a2) STMT_START {    \
541  const IV offset = loc - RExC_precomp;    \
542  Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
543    a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset); \
544 } STMT_END
545
546 #define vWARN4(loc, m, a1, a2, a3) STMT_START {    \
547  const IV offset = loc - RExC_precomp;    \
548  Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,  \
549    a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
550 } STMT_END
551
552 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START {   \
553  const IV offset = loc - RExC_precomp;    \
554  Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
555    a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
556 } STMT_END
557
558 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {   \
559  const IV offset = loc - RExC_precomp;    \
560  Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,  \
561    a1, a2, a3, a4, (int)offset, RExC_precomp, RExC_precomp + offset); \
562 } STMT_END
563
564
565 /* Allow for side effects in s */
566 #define REGC(c,s) STMT_START {   \
567  if (!SIZE_ONLY) *(s) = (c); else (void)(s); \
568 } STMT_END
569
570 /* Macros for recording node offsets.   20001227 mjd@plover.com
571  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
572  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
573  * Element 0 holds the number n.
574  * Position is 1 indexed.
575  */
576 #ifndef RE_TRACK_PATTERN_OFFSETS
577 #define Set_Node_Offset_To_R(node,byte)
578 #define Set_Node_Offset(node,byte)
579 #define Set_Cur_Node_Offset
580 #define Set_Node_Length_To_R(node,len)
581 #define Set_Node_Length(node,len)
582 #define Set_Node_Cur_Length(node)
583 #define Node_Offset(n)
584 #define Node_Length(n)
585 #define Set_Node_Offset_Length(node,offset,len)
586 #define ProgLen(ri) ri->u.proglen
587 #define SetProgLen(ri,x) ri->u.proglen = x
588 #else
589 #define ProgLen(ri) ri->u.offsets[0]
590 #define SetProgLen(ri,x) ri->u.offsets[0] = x
591 #define Set_Node_Offset_To_R(node,byte) STMT_START {   \
592  if (! SIZE_ONLY) {       \
593   MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",  \
594      __LINE__, (int)(node), (int)(byte)));  \
595   if((node) < 0) {      \
596    Perl_croak(aTHX_ "value of node is %d in Offset macro", (int)(node)); \
597   } else {       \
598    RExC_offsets[2*(node)-1] = (byte);    \
599   }        \
600  }         \
601 } STMT_END
602
603 #define Set_Node_Offset(node,byte) \
604  Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
605 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
606
607 #define Set_Node_Length_To_R(node,len) STMT_START {   \
608  if (! SIZE_ONLY) {       \
609   MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",  \
610     __LINE__, (int)(node), (int)(len)));   \
611   if((node) < 0) {      \
612    Perl_croak(aTHX_ "value of node is %d in Length macro", (int)(node)); \
613   } else {       \
614    RExC_offsets[2*(node)] = (len);    \
615   }        \
616  }         \
617 } STMT_END
618
619 #define Set_Node_Length(node,len) \
620  Set_Node_Length_To_R((node)-RExC_emit_start, len)
621 #define Set_Cur_Node_Length(len) Set_Node_Length(RExC_emit, len)
622 #define Set_Node_Cur_Length(node) \
623  Set_Node_Length(node, RExC_parse - parse_start)
624
625 /* Get offsets and lengths */
626 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
627 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
628
629 #define Set_Node_Offset_Length(node,offset,len) STMT_START { \
630  Set_Node_Offset_To_R((node)-RExC_emit_start, (offset)); \
631  Set_Node_Length_To_R((node)-RExC_emit_start, (len)); \
632 } STMT_END
633 #endif
634
635 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
636 #define EXPERIMENTAL_INPLACESCAN
637 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
638
639 #define DEBUG_STUDYDATA(str,data,depth)                              \
640 DEBUG_OPTIMISE_MORE_r(if(data){                                      \
641  PerlIO_printf(Perl_debug_log,                                    \
642   "%*s" str "Pos:%"IVdf"/%"IVdf                                \
643   " Flags: 0x%"UVXf" Whilem_c: %"IVdf" Lcp: %"IVdf" %s",       \
644   (int)(depth)*2, "",                                          \
645   (IV)((data)->pos_min),                                       \
646   (IV)((data)->pos_delta),                                     \
647   (UV)((data)->flags),                                         \
648   (IV)((data)->whilem_c),                                      \
649   (IV)((data)->last_closep ? *((data)->last_closep) : -1),     \
650   is_inf ? "INF " : ""                                         \
651  );                                                               \
652  if ((data)->last_found)                                          \
653   PerlIO_printf(Perl_debug_log,                                \
654    "Last:'%s' %"IVdf":%"IVdf"/%"IVdf" %sFixed:'%s' @ %"IVdf \
655    " %sFloat: '%s' @ %"IVdf"/%"IVdf"",                      \
656    SvPVX_const((data)->last_found),                         \
657    (IV)((data)->last_end),                                  \
658    (IV)((data)->last_start_min),                            \
659    (IV)((data)->last_start_max),                            \
660    ((data)->longest &&                                      \
661    (data)->longest==&((data)->longest_fixed)) ? "*" : "",  \
662    SvPVX_const((data)->longest_fixed),                      \
663    (IV)((data)->offset_fixed),                              \
664    ((data)->longest &&                                      \
665    (data)->longest==&((data)->longest_float)) ? "*" : "",  \
666    SvPVX_const((data)->longest_float),                      \
667    (IV)((data)->offset_float_min),                          \
668    (IV)((data)->offset_float_max)                           \
669   );                                                           \
670  PerlIO_printf(Perl_debug_log,"\n");                              \
671 });
672
673 static void clear_re(pTHX_ void *r);
674
675 /* Mark that we cannot extend a found fixed substring at this point.
676    Update the longest found anchored substring and the longest found
677    floating substrings if needed. */
678
679 STATIC void
680 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, I32 *minlenp, int is_inf)
681 {
682  const STRLEN l = CHR_SVLEN(data->last_found);
683  const STRLEN old_l = CHR_SVLEN(*data->longest);
684  GET_RE_DEBUG_FLAGS_DECL;
685
686  PERL_ARGS_ASSERT_SCAN_COMMIT;
687
688  if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
689   SvSetMagicSV(*data->longest, data->last_found);
690   if (*data->longest == data->longest_fixed) {
691    data->offset_fixed = l ? data->last_start_min : data->pos_min;
692    if (data->flags & SF_BEFORE_EOL)
693     data->flags
694      |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
695    else
696     data->flags &= ~SF_FIX_BEFORE_EOL;
697    data->minlen_fixed=minlenp;
698    data->lookbehind_fixed=0;
699   }
700   else { /* *data->longest == data->longest_float */
701    data->offset_float_min = l ? data->last_start_min : data->pos_min;
702    data->offset_float_max = (l
703          ? data->last_start_max
704          : data->pos_min + data->pos_delta);
705    if (is_inf || (U32)data->offset_float_max > (U32)I32_MAX)
706     data->offset_float_max = I32_MAX;
707    if (data->flags & SF_BEFORE_EOL)
708     data->flags
709      |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
710    else
711     data->flags &= ~SF_FL_BEFORE_EOL;
712    data->minlen_float=minlenp;
713    data->lookbehind_float=0;
714   }
715  }
716  SvCUR_set(data->last_found, 0);
717  {
718   SV * const sv = data->last_found;
719   if (SvUTF8(sv) && SvMAGICAL(sv)) {
720    MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
721    if (mg)
722     mg->mg_len = 0;
723   }
724  }
725  data->last_end = -1;
726  data->flags &= ~SF_BEFORE_EOL;
727  DEBUG_STUDYDATA("commit: ",data,0);
728 }
729
730 /* Can match anything (initialization) */
731 STATIC void
732 S_cl_anything(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
733 {
734  PERL_ARGS_ASSERT_CL_ANYTHING;
735
736  ANYOF_BITMAP_SETALL(cl);
737  cl->flags = ANYOF_CLASS|ANYOF_EOS|ANYOF_UNICODE_ALL
738     |ANYOF_LOC_NONBITMAP_FOLD|ANYOF_NON_UTF8_LATIN1_ALL;
739
740  /* If any portion of the regex is to operate under locale rules,
741  * initialization includes it.  The reason this isn't done for all regexes
742  * is that the optimizer was written under the assumption that locale was
743  * all-or-nothing.  Given the complexity and lack of documentation in the
744  * optimizer, and that there are inadequate test cases for locale, so many
745  * parts of it may not work properly, it is safest to avoid locale unless
746  * necessary. */
747  if (RExC_contains_locale) {
748   ANYOF_CLASS_SETALL(cl);     /* /l uses class */
749   cl->flags |= ANYOF_LOCALE;
750  }
751  else {
752   ANYOF_CLASS_ZERO(cl);     /* Only /l uses class now */
753  }
754 }
755
756 /* Can match anything (initialization) */
757 STATIC int
758 S_cl_is_anything(const struct regnode_charclass_class *cl)
759 {
760  int value;
761
762  PERL_ARGS_ASSERT_CL_IS_ANYTHING;
763
764  for (value = 0; value <= ANYOF_MAX; value += 2)
765   if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
766    return 1;
767  if (!(cl->flags & ANYOF_UNICODE_ALL))
768   return 0;
769  if (!ANYOF_BITMAP_TESTALLSET((const void*)cl))
770   return 0;
771  return 1;
772 }
773
774 /* Can match anything (initialization) */
775 STATIC void
776 S_cl_init(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
777 {
778  PERL_ARGS_ASSERT_CL_INIT;
779
780  Zero(cl, 1, struct regnode_charclass_class);
781  cl->type = ANYOF;
782  cl_anything(pRExC_state, cl);
783  ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
784 }
785
786 /* These two functions currently do the exact same thing */
787 #define cl_init_zero  S_cl_init
788
789 /* 'AND' a given class with another one.  Can create false positives.  'cl'
790  * should not be inverted.  'and_with->flags & ANYOF_CLASS' should be 0 if
791  * 'and_with' is a regnode_charclass instead of a regnode_charclass_class. */
792 STATIC void
793 S_cl_and(struct regnode_charclass_class *cl,
794   const struct regnode_charclass_class *and_with)
795 {
796  PERL_ARGS_ASSERT_CL_AND;
797
798  assert(and_with->type == ANYOF);
799
800  /* I (khw) am not sure all these restrictions are necessary XXX */
801  if (!(ANYOF_CLASS_TEST_ANY_SET(and_with))
802   && !(ANYOF_CLASS_TEST_ANY_SET(cl))
803   && (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
804   && !(and_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
805   && !(cl->flags & ANYOF_LOC_NONBITMAP_FOLD)) {
806   int i;
807
808   if (and_with->flags & ANYOF_INVERT)
809    for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
810     cl->bitmap[i] &= ~and_with->bitmap[i];
811   else
812    for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
813     cl->bitmap[i] &= and_with->bitmap[i];
814  } /* XXXX: logic is complicated otherwise, leave it along for a moment. */
815
816  if (and_with->flags & ANYOF_INVERT) {
817
818   /* Here, the and'ed node is inverted.  Get the AND of the flags that
819   * aren't affected by the inversion.  Those that are affected are
820   * handled individually below */
821   U8 affected_flags = cl->flags & ~INVERSION_UNAFFECTED_FLAGS;
822   cl->flags &= (and_with->flags & INVERSION_UNAFFECTED_FLAGS);
823   cl->flags |= affected_flags;
824
825   /* We currently don't know how to deal with things that aren't in the
826   * bitmap, but we know that the intersection is no greater than what
827   * is already in cl, so let there be false positives that get sorted
828   * out after the synthetic start class succeeds, and the node is
829   * matched for real. */
830
831   /* The inversion of these two flags indicate that the resulting
832   * intersection doesn't have them */
833   if (and_with->flags & ANYOF_UNICODE_ALL) {
834    cl->flags &= ~ANYOF_UNICODE_ALL;
835   }
836   if (and_with->flags & ANYOF_NON_UTF8_LATIN1_ALL) {
837    cl->flags &= ~ANYOF_NON_UTF8_LATIN1_ALL;
838   }
839  }
840  else {   /* and'd node is not inverted */
841   U8 outside_bitmap_but_not_utf8; /* Temp variable */
842
843   if (! ANYOF_NONBITMAP(and_with)) {
844
845    /* Here 'and_with' doesn't match anything outside the bitmap
846    * (except possibly ANYOF_UNICODE_ALL), which means the
847    * intersection can't either, except for ANYOF_UNICODE_ALL, in
848    * which case we don't know what the intersection is, but it's no
849    * greater than what cl already has, so can just leave it alone,
850    * with possible false positives */
851    if (! (and_with->flags & ANYOF_UNICODE_ALL)) {
852     ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
853     cl->flags &= ~ANYOF_NONBITMAP_NON_UTF8;
854    }
855   }
856   else if (! ANYOF_NONBITMAP(cl)) {
857
858    /* Here, 'and_with' does match something outside the bitmap, and cl
859    * doesn't have a list of things to match outside the bitmap.  If
860    * cl can match all code points above 255, the intersection will
861    * be those above-255 code points that 'and_with' matches.  If cl
862    * can't match all Unicode code points, it means that it can't
863    * match anything outside the bitmap (since the 'if' that got us
864    * into this block tested for that), so we leave the bitmap empty.
865    */
866    if (cl->flags & ANYOF_UNICODE_ALL) {
867     ARG_SET(cl, ARG(and_with));
868
869     /* and_with's ARG may match things that don't require UTF8.
870     * And now cl's will too, in spite of this being an 'and'.  See
871     * the comments below about the kludge */
872     cl->flags |= and_with->flags & ANYOF_NONBITMAP_NON_UTF8;
873    }
874   }
875   else {
876    /* Here, both 'and_with' and cl match something outside the
877    * bitmap.  Currently we do not do the intersection, so just match
878    * whatever cl had at the beginning.  */
879   }
880
881
882   /* Take the intersection of the two sets of flags.  However, the
883   * ANYOF_NONBITMAP_NON_UTF8 flag is treated as an 'or'.  This is a
884   * kludge around the fact that this flag is not treated like the others
885   * which are initialized in cl_anything().  The way the optimizer works
886   * is that the synthetic start class (SSC) is initialized to match
887   * anything, and then the first time a real node is encountered, its
888   * values are AND'd with the SSC's with the result being the values of
889   * the real node.  However, there are paths through the optimizer where
890   * the AND never gets called, so those initialized bits are set
891   * inappropriately, which is not usually a big deal, as they just cause
892   * false positives in the SSC, which will just mean a probably
893   * imperceptible slow down in execution.  However this bit has a
894   * higher false positive consequence in that it can cause utf8.pm,
895   * utf8_heavy.pl ... to be loaded when not necessary, which is a much
896   * bigger slowdown and also causes significant extra memory to be used.
897   * In order to prevent this, the code now takes a different tack.  The
898   * bit isn't set unless some part of the regular expression needs it,
899   * but once set it won't get cleared.  This means that these extra
900   * modules won't get loaded unless there was some path through the
901   * pattern that would have required them anyway, and  so any false
902   * positives that occur by not ANDing them out when they could be
903   * aren't as severe as they would be if we treated this bit like all
904   * the others */
905   outside_bitmap_but_not_utf8 = (cl->flags | and_with->flags)
906          & ANYOF_NONBITMAP_NON_UTF8;
907   cl->flags &= and_with->flags;
908   cl->flags |= outside_bitmap_but_not_utf8;
909  }
910 }
911
912 /* 'OR' a given class with another one.  Can create false positives.  'cl'
913  * should not be inverted.  'or_with->flags & ANYOF_CLASS' should be 0 if
914  * 'or_with' is a regnode_charclass instead of a regnode_charclass_class. */
915 STATIC void
916 S_cl_or(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, const struct regnode_charclass_class *or_with)
917 {
918  PERL_ARGS_ASSERT_CL_OR;
919
920  if (or_with->flags & ANYOF_INVERT) {
921
922   /* Here, the or'd node is to be inverted.  This means we take the
923   * complement of everything not in the bitmap, but currently we don't
924   * know what that is, so give up and match anything */
925   if (ANYOF_NONBITMAP(or_with)) {
926    cl_anything(pRExC_state, cl);
927   }
928   /* We do not use
929   * (B1 | CL1) | (!B2 & !CL2) = (B1 | !B2 & !CL2) | (CL1 | (!B2 & !CL2))
930   *   <= (B1 | !B2) | (CL1 | !CL2)
931   * which is wasteful if CL2 is small, but we ignore CL2:
932   *   (B1 | CL1) | (!B2 & !CL2) <= (B1 | CL1) | !B2 = (B1 | !B2) | CL1
933   * XXXX Can we handle case-fold?  Unclear:
934   *   (OK1(i) | OK1(i')) | !(OK1(i) | OK1(i')) =
935   *   (OK1(i) | OK1(i')) | (!OK1(i) & !OK1(i'))
936   */
937   else if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
938    && !(or_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
939    && !(cl->flags & ANYOF_LOC_NONBITMAP_FOLD) ) {
940    int i;
941
942    for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
943     cl->bitmap[i] |= ~or_with->bitmap[i];
944   } /* XXXX: logic is complicated otherwise */
945   else {
946    cl_anything(pRExC_state, cl);
947   }
948
949   /* And, we can just take the union of the flags that aren't affected
950   * by the inversion */
951   cl->flags |= or_with->flags & INVERSION_UNAFFECTED_FLAGS;
952
953   /* For the remaining flags:
954    ANYOF_UNICODE_ALL and inverted means to not match anything above
955      255, which means that the union with cl should just be
956      what cl has in it, so can ignore this flag
957    ANYOF_NON_UTF8_LATIN1_ALL and inverted means if not utf8 and ord
958      is 127-255 to match them, but then invert that, so the
959      union with cl should just be what cl has in it, so can
960      ignore this flag
961   */
962  } else {    /* 'or_with' is not inverted */
963   /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
964   if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
965    && (!(or_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
966     || (cl->flags & ANYOF_LOC_NONBITMAP_FOLD)) ) {
967    int i;
968
969    /* OR char bitmap and class bitmap separately */
970    for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
971     cl->bitmap[i] |= or_with->bitmap[i];
972    if (ANYOF_CLASS_TEST_ANY_SET(or_with)) {
973     for (i = 0; i < ANYOF_CLASSBITMAP_SIZE; i++)
974      cl->classflags[i] |= or_with->classflags[i];
975     cl->flags |= ANYOF_CLASS;
976    }
977   }
978   else { /* XXXX: logic is complicated, leave it along for a moment. */
979    cl_anything(pRExC_state, cl);
980   }
981
982   if (ANYOF_NONBITMAP(or_with)) {
983
984    /* Use the added node's outside-the-bit-map match if there isn't a
985    * conflict.  If there is a conflict (both nodes match something
986    * outside the bitmap, but what they match outside is not the same
987    * pointer, and hence not easily compared until XXX we extend
988    * inversion lists this far), give up and allow the start class to
989    * match everything outside the bitmap.  If that stuff is all above
990    * 255, can just set UNICODE_ALL, otherwise caould be anything. */
991    if (! ANYOF_NONBITMAP(cl)) {
992     ARG_SET(cl, ARG(or_with));
993    }
994    else if (ARG(cl) != ARG(or_with)) {
995
996     if ((or_with->flags & ANYOF_NONBITMAP_NON_UTF8)) {
997      cl_anything(pRExC_state, cl);
998     }
999     else {
1000      cl->flags |= ANYOF_UNICODE_ALL;
1001     }
1002    }
1003   }
1004
1005   /* Take the union */
1006   cl->flags |= or_with->flags;
1007  }
1008 }
1009
1010 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
1011 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
1012 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
1013 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list ? (TRIE_LIST_CUR( idx ) - 1) : 0 )
1014
1015
1016 #ifdef DEBUGGING
1017 /*
1018    dump_trie(trie,widecharmap,revcharmap)
1019    dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
1020    dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
1021
1022    These routines dump out a trie in a somewhat readable format.
1023    The _interim_ variants are used for debugging the interim
1024    tables that are used to generate the final compressed
1025    representation which is what dump_trie expects.
1026
1027    Part of the reason for their existence is to provide a form
1028    of documentation as to how the different representations function.
1029
1030 */
1031
1032 /*
1033   Dumps the final compressed table form of the trie to Perl_debug_log.
1034   Used for debugging make_trie().
1035 */
1036
1037 STATIC void
1038 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
1039    AV *revcharmap, U32 depth)
1040 {
1041  U32 state;
1042  SV *sv=sv_newmortal();
1043  int colwidth= widecharmap ? 6 : 4;
1044  U16 word;
1045  GET_RE_DEBUG_FLAGS_DECL;
1046
1047  PERL_ARGS_ASSERT_DUMP_TRIE;
1048
1049  PerlIO_printf( Perl_debug_log, "%*sChar : %-6s%-6s%-4s ",
1050   (int)depth * 2 + 2,"",
1051   "Match","Base","Ofs" );
1052
1053  for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
1054   SV ** const tmp = av_fetch( revcharmap, state, 0);
1055   if ( tmp ) {
1056    PerlIO_printf( Perl_debug_log, "%*s",
1057     colwidth,
1058     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
1059        PL_colors[0], PL_colors[1],
1060        (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1061        PERL_PV_ESCAPE_FIRSTCHAR
1062     )
1063    );
1064   }
1065  }
1066  PerlIO_printf( Perl_debug_log, "\n%*sState|-----------------------",
1067   (int)depth * 2 + 2,"");
1068
1069  for( state = 0 ; state < trie->uniquecharcount ; state++ )
1070   PerlIO_printf( Perl_debug_log, "%.*s", colwidth, "--------");
1071  PerlIO_printf( Perl_debug_log, "\n");
1072
1073  for( state = 1 ; state < trie->statecount ; state++ ) {
1074   const U32 base = trie->states[ state ].trans.base;
1075
1076   PerlIO_printf( Perl_debug_log, "%*s#%4"UVXf"|", (int)depth * 2 + 2,"", (UV)state);
1077
1078   if ( trie->states[ state ].wordnum ) {
1079    PerlIO_printf( Perl_debug_log, " W%4X", trie->states[ state ].wordnum );
1080   } else {
1081    PerlIO_printf( Perl_debug_log, "%6s", "" );
1082   }
1083
1084   PerlIO_printf( Perl_debug_log, " @%4"UVXf" ", (UV)base );
1085
1086   if ( base ) {
1087    U32 ofs = 0;
1088
1089    while( ( base + ofs  < trie->uniquecharcount ) ||
1090     ( base + ofs - trie->uniquecharcount < trie->lasttrans
1091      && trie->trans[ base + ofs - trie->uniquecharcount ].check != state))
1092      ofs++;
1093
1094    PerlIO_printf( Perl_debug_log, "+%2"UVXf"[ ", (UV)ofs);
1095
1096    for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
1097     if ( ( base + ofs >= trie->uniquecharcount ) &&
1098      ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
1099      trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
1100     {
1101     PerlIO_printf( Perl_debug_log, "%*"UVXf,
1102      colwidth,
1103      (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next );
1104     } else {
1105      PerlIO_printf( Perl_debug_log, "%*s",colwidth,"   ." );
1106     }
1107    }
1108
1109    PerlIO_printf( Perl_debug_log, "]");
1110
1111   }
1112   PerlIO_printf( Perl_debug_log, "\n" );
1113  }
1114  PerlIO_printf(Perl_debug_log, "%*sword_info N:(prev,len)=", (int)depth*2, "");
1115  for (word=1; word <= trie->wordcount; word++) {
1116   PerlIO_printf(Perl_debug_log, " %d:(%d,%d)",
1117    (int)word, (int)(trie->wordinfo[word].prev),
1118    (int)(trie->wordinfo[word].len));
1119  }
1120  PerlIO_printf(Perl_debug_log, "\n" );
1121 }
1122 /*
1123   Dumps a fully constructed but uncompressed trie in list form.
1124   List tries normally only are used for construction when the number of
1125   possible chars (trie->uniquecharcount) is very high.
1126   Used for debugging make_trie().
1127 */
1128 STATIC void
1129 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
1130       HV *widecharmap, AV *revcharmap, U32 next_alloc,
1131       U32 depth)
1132 {
1133  U32 state;
1134  SV *sv=sv_newmortal();
1135  int colwidth= widecharmap ? 6 : 4;
1136  GET_RE_DEBUG_FLAGS_DECL;
1137
1138  PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
1139
1140  /* print out the table precompression.  */
1141  PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s%s",
1142   (int)depth * 2 + 2,"", (int)depth * 2 + 2,"",
1143   "------:-----+-----------------\n" );
1144
1145  for( state=1 ; state < next_alloc ; state ++ ) {
1146   U16 charid;
1147
1148   PerlIO_printf( Perl_debug_log, "%*s %4"UVXf" :",
1149    (int)depth * 2 + 2,"", (UV)state  );
1150   if ( ! trie->states[ state ].wordnum ) {
1151    PerlIO_printf( Perl_debug_log, "%5s| ","");
1152   } else {
1153    PerlIO_printf( Perl_debug_log, "W%4x| ",
1154     trie->states[ state ].wordnum
1155    );
1156   }
1157   for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
1158    SV ** const tmp = av_fetch( revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0);
1159    if ( tmp ) {
1160     PerlIO_printf( Perl_debug_log, "%*s:%3X=%4"UVXf" | ",
1161      colwidth,
1162      pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
1163        PL_colors[0], PL_colors[1],
1164        (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1165        PERL_PV_ESCAPE_FIRSTCHAR
1166      ) ,
1167      TRIE_LIST_ITEM(state,charid).forid,
1168      (UV)TRIE_LIST_ITEM(state,charid).newstate
1169     );
1170     if (!(charid % 10))
1171      PerlIO_printf(Perl_debug_log, "\n%*s| ",
1172       (int)((depth * 2) + 14), "");
1173    }
1174   }
1175   PerlIO_printf( Perl_debug_log, "\n");
1176  }
1177 }
1178
1179 /*
1180   Dumps a fully constructed but uncompressed trie in table form.
1181   This is the normal DFA style state transition table, with a few
1182   twists to facilitate compression later.
1183   Used for debugging make_trie().
1184 */
1185 STATIC void
1186 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
1187       HV *widecharmap, AV *revcharmap, U32 next_alloc,
1188       U32 depth)
1189 {
1190  U32 state;
1191  U16 charid;
1192  SV *sv=sv_newmortal();
1193  int colwidth= widecharmap ? 6 : 4;
1194  GET_RE_DEBUG_FLAGS_DECL;
1195
1196  PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
1197
1198  /*
1199  print out the table precompression so that we can do a visual check
1200  that they are identical.
1201  */
1202
1203  PerlIO_printf( Perl_debug_log, "%*sChar : ",(int)depth * 2 + 2,"" );
1204
1205  for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1206   SV ** const tmp = av_fetch( revcharmap, charid, 0);
1207   if ( tmp ) {
1208    PerlIO_printf( Perl_debug_log, "%*s",
1209     colwidth,
1210     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
1211        PL_colors[0], PL_colors[1],
1212        (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1213        PERL_PV_ESCAPE_FIRSTCHAR
1214     )
1215    );
1216   }
1217  }
1218
1219  PerlIO_printf( Perl_debug_log, "\n%*sState+-",(int)depth * 2 + 2,"" );
1220
1221  for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
1222   PerlIO_printf( Perl_debug_log, "%.*s", colwidth,"--------");
1223  }
1224
1225  PerlIO_printf( Perl_debug_log, "\n" );
1226
1227  for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
1228
1229   PerlIO_printf( Perl_debug_log, "%*s%4"UVXf" : ",
1230    (int)depth * 2 + 2,"",
1231    (UV)TRIE_NODENUM( state ) );
1232
1233   for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1234    UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
1235    if (v)
1236     PerlIO_printf( Perl_debug_log, "%*"UVXf, colwidth, v );
1237    else
1238     PerlIO_printf( Perl_debug_log, "%*s", colwidth, "." );
1239   }
1240   if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
1241    PerlIO_printf( Perl_debug_log, " (%4"UVXf")\n", (UV)trie->trans[ state ].check );
1242   } else {
1243    PerlIO_printf( Perl_debug_log, " (%4"UVXf") W%4X\n", (UV)trie->trans[ state ].check,
1244    trie->states[ TRIE_NODENUM( state ) ].wordnum );
1245   }
1246  }
1247 }
1248
1249 #endif
1250
1251
1252 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
1253   startbranch: the first branch in the whole branch sequence
1254   first      : start branch of sequence of branch-exact nodes.
1255    May be the same as startbranch
1256   last       : Thing following the last branch.
1257    May be the same as tail.
1258   tail       : item following the branch sequence
1259   count      : words in the sequence
1260   flags      : currently the OP() type we will be building one of /EXACT(|F|Fl)/
1261   depth      : indent depth
1262
1263 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
1264
1265 A trie is an N'ary tree where the branches are determined by digital
1266 decomposition of the key. IE, at the root node you look up the 1st character and
1267 follow that branch repeat until you find the end of the branches. Nodes can be
1268 marked as "accepting" meaning they represent a complete word. Eg:
1269
1270   /he|she|his|hers/
1271
1272 would convert into the following structure. Numbers represent states, letters
1273 following numbers represent valid transitions on the letter from that state, if
1274 the number is in square brackets it represents an accepting state, otherwise it
1275 will be in parenthesis.
1276
1277  +-h->+-e->[3]-+-r->(8)-+-s->[9]
1278  |    |
1279  |   (2)
1280  |    |
1281  (1)   +-i->(6)-+-s->[7]
1282  |
1283  +-s->(3)-+-h->(4)-+-e->[5]
1284
1285  Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
1286
1287 This shows that when matching against the string 'hers' we will begin at state 1
1288 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
1289 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
1290 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
1291 single traverse. We store a mapping from accepting to state to which word was
1292 matched, and then when we have multiple possibilities we try to complete the
1293 rest of the regex in the order in which they occured in the alternation.
1294
1295 The only prior NFA like behaviour that would be changed by the TRIE support is
1296 the silent ignoring of duplicate alternations which are of the form:
1297
1298  / (DUPE|DUPE) X? (?{ ... }) Y /x
1299
1300 Thus EVAL blocks following a trie may be called a different number of times with
1301 and without the optimisation. With the optimisations dupes will be silently
1302 ignored. This inconsistent behaviour of EVAL type nodes is well established as
1303 the following demonstrates:
1304
1305  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
1306
1307 which prints out 'word' three times, but
1308
1309  'words'=~/(word|word|word)(?{ print $1 })S/
1310
1311 which doesnt print it out at all. This is due to other optimisations kicking in.
1312
1313 Example of what happens on a structural level:
1314
1315 The regexp /(ac|ad|ab)+/ will produce the following debug output:
1316
1317    1: CURLYM[1] {1,32767}(18)
1318    5:   BRANCH(8)
1319    6:     EXACT <ac>(16)
1320    8:   BRANCH(11)
1321    9:     EXACT <ad>(16)
1322   11:   BRANCH(14)
1323   12:     EXACT <ab>(16)
1324   16:   SUCCEED(0)
1325   17:   NOTHING(18)
1326   18: END(0)
1327
1328 This would be optimizable with startbranch=5, first=5, last=16, tail=16
1329 and should turn into:
1330
1331    1: CURLYM[1] {1,32767}(18)
1332    5:   TRIE(16)
1333   [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
1334   <ac>
1335   <ad>
1336   <ab>
1337   16:   SUCCEED(0)
1338   17:   NOTHING(18)
1339   18: END(0)
1340
1341 Cases where tail != last would be like /(?foo|bar)baz/:
1342
1343    1: BRANCH(4)
1344    2:   EXACT <foo>(8)
1345    4: BRANCH(7)
1346    5:   EXACT <bar>(8)
1347    7: TAIL(8)
1348    8: EXACT <baz>(10)
1349   10: END(0)
1350
1351 which would be optimizable with startbranch=1, first=1, last=7, tail=8
1352 and would end up looking like:
1353
1354  1: TRIE(8)
1355  [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
1356   <foo>
1357   <bar>
1358    7: TAIL(8)
1359    8: EXACT <baz>(10)
1360   10: END(0)
1361
1362  d = uvuni_to_utf8_flags(d, uv, 0);
1363
1364 is the recommended Unicode-aware way of saying
1365
1366  *(d++) = uv;
1367 */
1368
1369 #define TRIE_STORE_REVCHAR(val)                                            \
1370  STMT_START {                                                           \
1371   if (UTF) {          \
1372    SV *zlopp = newSV(7); /* XXX: optimize me */                   \
1373    unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp);    \
1374    unsigned const char *const kapow = uvuni_to_utf8(flrbbbbb, val); \
1375    SvCUR_set(zlopp, kapow - flrbbbbb);       \
1376    SvPOK_on(zlopp);         \
1377    SvUTF8_on(zlopp);         \
1378    av_push(revcharmap, zlopp);        \
1379   } else {          \
1380    char ooooff = (char)val;                                           \
1381    av_push(revcharmap, newSVpvn(&ooooff, 1));      \
1382   }           \
1383   } STMT_END
1384
1385 #define TRIE_READ_CHAR STMT_START {                                                     \
1386  wordlen++;                                                                          \
1387  if ( UTF ) {                                                                        \
1388   /* if it is UTF then it is either already folded, or does not need folding */   \
1389   uvc = utf8n_to_uvuni( (const U8*) uc, UTF8_MAXLEN, &len, uniflags);             \
1390  }                                                                                   \
1391  else if (folder == PL_fold_latin1) {                                                \
1392   /* if we use this folder we have to obey unicode rules on latin-1 data */       \
1393   if ( foldlen > 0 ) {                                                            \
1394   uvc = utf8n_to_uvuni( (const U8*) scan, UTF8_MAXLEN, &len, uniflags );       \
1395   foldlen -= len;                                                              \
1396   scan += len;                                                                 \
1397   len = 0;                                                                     \
1398   } else {                                                                        \
1399    len = 1;                                                                    \
1400    uvc = _to_fold_latin1( (U8) *uc, foldbuf, &foldlen, 1);                     \
1401    skiplen = UNISKIP(uvc);                                                     \
1402    foldlen -= skiplen;                                                         \
1403    scan = foldbuf + skiplen;                                                   \
1404   }                                                                               \
1405  } else {                                                                            \
1406   /* raw data, will be folded later if needed */                                  \
1407   uvc = (U32)*uc;                                                                 \
1408   len = 1;                                                                        \
1409  }                                                                                   \
1410 } STMT_END
1411
1412
1413
1414 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
1415  if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
1416   U32 ging = TRIE_LIST_LEN( state ) *= 2;                 \
1417   Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
1418  }                                                           \
1419  TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
1420  TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
1421  TRIE_LIST_CUR( state )++;                                   \
1422 } STMT_END
1423
1424 #define TRIE_LIST_NEW(state) STMT_START {                       \
1425  Newxz( trie->states[ state ].trans.list,               \
1426   4, reg_trie_trans_le );                                 \
1427  TRIE_LIST_CUR( state ) = 1;                                \
1428  TRIE_LIST_LEN( state ) = 4;                                \
1429 } STMT_END
1430
1431 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
1432  U16 dupe= trie->states[ state ].wordnum;                    \
1433  regnode * const noper_next = regnext( noper );              \
1434                 \
1435  DEBUG_r({                                                   \
1436   /* store the word for dumping */                        \
1437   SV* tmp;                                                \
1438   if (OP(noper) != NOTHING)                               \
1439    tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF); \
1440   else                                                    \
1441    tmp = newSVpvn_utf8( "", 0, UTF );   \
1442   av_push( trie_words, tmp );                             \
1443  });                                                         \
1444                 \
1445  curword++;                                                  \
1446  trie->wordinfo[curword].prev   = 0;                         \
1447  trie->wordinfo[curword].len    = wordlen;                   \
1448  trie->wordinfo[curword].accept = state;                     \
1449                 \
1450  if ( noper_next < tail ) {                                  \
1451   if (!trie->jump)                                        \
1452    trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, sizeof(U16) ); \
1453   trie->jump[curword] = (U16)(noper_next - convert);      \
1454   if (!jumper)                                            \
1455    jumper = noper_next;                                \
1456   if (!nextbranch)                                        \
1457    nextbranch= regnext(cur);                           \
1458  }                                                           \
1459                 \
1460  if ( dupe ) {                                               \
1461   /* It's a dupe. Pre-insert into the wordinfo[].prev   */\
1462   /* chain, so that when the bits of chain are later    */\
1463   /* linked together, the dups appear in the chain      */\
1464   trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
1465   trie->wordinfo[dupe].prev = curword;                    \
1466  } else {                                                    \
1467   /* we haven't inserted this word yet.                */ \
1468   trie->states[ state ].wordnum = curword;                \
1469  }                                                           \
1470 } STMT_END
1471
1472
1473 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)  \
1474  ( ( base + charid >=  ucharcount     \
1475   && base + charid < ubound     \
1476   && state == trie->trans[ base - ucharcount + charid ].check \
1477   && trie->trans[ base - ucharcount + charid ].next )  \
1478   ? trie->trans[ base - ucharcount + charid ].next  \
1479   : ( state==1 ? special : 0 )     \
1480  )
1481
1482 #define MADE_TRIE       1
1483 #define MADE_JUMP_TRIE  2
1484 #define MADE_EXACT_TRIE 4
1485
1486 STATIC I32
1487 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *first, regnode *last, regnode *tail, U32 word_count, U32 flags, U32 depth)
1488 {
1489  dVAR;
1490  /* first pass, loop through and scan words */
1491  reg_trie_data *trie;
1492  HV *widecharmap = NULL;
1493  AV *revcharmap = newAV();
1494  regnode *cur;
1495  const U32 uniflags = UTF8_ALLOW_DEFAULT;
1496  STRLEN len = 0;
1497  UV uvc = 0;
1498  U16 curword = 0;
1499  U32 next_alloc = 0;
1500  regnode *jumper = NULL;
1501  regnode *nextbranch = NULL;
1502  regnode *convert = NULL;
1503  U32 *prev_states; /* temp array mapping each state to previous one */
1504  /* we just use folder as a flag in utf8 */
1505  const U8 * folder = NULL;
1506
1507 #ifdef DEBUGGING
1508  const U32 data_slot = add_data( pRExC_state, 4, "tuuu" );
1509  AV *trie_words = NULL;
1510  /* along with revcharmap, this only used during construction but both are
1511  * useful during debugging so we store them in the struct when debugging.
1512  */
1513 #else
1514  const U32 data_slot = add_data( pRExC_state, 2, "tu" );
1515  STRLEN trie_charcount=0;
1516 #endif
1517  SV *re_trie_maxbuff;
1518  GET_RE_DEBUG_FLAGS_DECL;
1519
1520  PERL_ARGS_ASSERT_MAKE_TRIE;
1521 #ifndef DEBUGGING
1522  PERL_UNUSED_ARG(depth);
1523 #endif
1524
1525  switch (flags) {
1526   case EXACT: break;
1527   case EXACTFA:
1528   case EXACTFU_SS:
1529   case EXACTFU_TRICKYFOLD:
1530   case EXACTFU: folder = PL_fold_latin1; break;
1531   case EXACTF:  folder = PL_fold; break;
1532   case EXACTFL: folder = PL_fold_locale; break;
1533   default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] );
1534  }
1535
1536  trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
1537  trie->refcount = 1;
1538  trie->startstate = 1;
1539  trie->wordcount = word_count;
1540  RExC_rxi->data->data[ data_slot ] = (void*)trie;
1541  trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
1542  if (flags == EXACT)
1543   trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
1544  trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
1545      trie->wordcount+1, sizeof(reg_trie_wordinfo));
1546
1547  DEBUG_r({
1548   trie_words = newAV();
1549  });
1550
1551  re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
1552  if (!SvIOK(re_trie_maxbuff)) {
1553   sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
1554  }
1555  DEBUG_OPTIMISE_r({
1556     PerlIO_printf( Perl_debug_log,
1557     "%*smake_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
1558     (int)depth * 2 + 2, "",
1559     REG_NODE_NUM(startbranch),REG_NODE_NUM(first),
1560     REG_NODE_NUM(last), REG_NODE_NUM(tail),
1561     (int)depth);
1562  });
1563
1564    /* Find the node we are going to overwrite */
1565  if ( first == startbranch && OP( last ) != BRANCH ) {
1566   /* whole branch chain */
1567   convert = first;
1568  } else {
1569   /* branch sub-chain */
1570   convert = NEXTOPER( first );
1571  }
1572
1573  /*  -- First loop and Setup --
1574
1575  We first traverse the branches and scan each word to determine if it
1576  contains widechars, and how many unique chars there are, this is
1577  important as we have to build a table with at least as many columns as we
1578  have unique chars.
1579
1580  We use an array of integers to represent the character codes 0..255
1581  (trie->charmap) and we use a an HV* to store Unicode characters. We use the
1582  native representation of the character value as the key and IV's for the
1583  coded index.
1584
1585  *TODO* If we keep track of how many times each character is used we can
1586  remap the columns so that the table compression later on is more
1587  efficient in terms of memory by ensuring the most common value is in the
1588  middle and the least common are on the outside.  IMO this would be better
1589  than a most to least common mapping as theres a decent chance the most
1590  common letter will share a node with the least common, meaning the node
1591  will not be compressible. With a middle is most common approach the worst
1592  case is when we have the least common nodes twice.
1593
1594  */
1595
1596  for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1597   regnode * const noper = NEXTOPER( cur );
1598   const U8 *uc = (U8*)STRING( noper );
1599   const U8 * const e  = uc + STR_LEN( noper );
1600   STRLEN foldlen = 0;
1601   U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1602   STRLEN skiplen = 0;
1603   const U8 *scan = (U8*)NULL;
1604   U32 wordlen      = 0;         /* required init */
1605   STRLEN chars = 0;
1606   bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the bitmap?*/
1607
1608   if (OP(noper) == NOTHING) {
1609    trie->minlen= 0;
1610    continue;
1611   }
1612   if ( set_bit ) { /* bitmap only alloced when !(UTF&&Folding) */
1613    TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
1614           regardless of encoding */
1615    if (OP( noper ) == EXACTFU_SS) {
1616     /* false positives are ok, so just set this */
1617     TRIE_BITMAP_SET(trie,0xDF);
1618    }
1619   }
1620   for ( ; uc < e ; uc += len ) {
1621    TRIE_CHARCOUNT(trie)++;
1622    TRIE_READ_CHAR;
1623    chars++;
1624    if ( uvc < 256 ) {
1625     if ( folder ) {
1626      U8 folded= folder[ (U8) uvc ];
1627      if ( !trie->charmap[ folded ] ) {
1628       trie->charmap[ folded ]=( ++trie->uniquecharcount );
1629       TRIE_STORE_REVCHAR( folded );
1630      }
1631     }
1632     if ( !trie->charmap[ uvc ] ) {
1633      trie->charmap[ uvc ]=( ++trie->uniquecharcount );
1634      TRIE_STORE_REVCHAR( uvc );
1635     }
1636     if ( set_bit ) {
1637      /* store the codepoint in the bitmap, and its folded
1638      * equivalent. */
1639      TRIE_BITMAP_SET(trie, uvc);
1640
1641      /* store the folded codepoint */
1642      if ( folder ) TRIE_BITMAP_SET(trie, folder[(U8) uvc ]);
1643
1644      if ( !UTF ) {
1645       /* store first byte of utf8 representation of
1646       variant codepoints */
1647       if (! UNI_IS_INVARIANT(uvc)) {
1648        TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));
1649       }
1650      }
1651      set_bit = 0; /* We've done our bit :-) */
1652     }
1653    } else {
1654     SV** svpp;
1655     if ( !widecharmap )
1656      widecharmap = newHV();
1657
1658     svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
1659
1660     if ( !svpp )
1661      Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%"UVXf, uvc );
1662
1663     if ( !SvTRUE( *svpp ) ) {
1664      sv_setiv( *svpp, ++trie->uniquecharcount );
1665      TRIE_STORE_REVCHAR(uvc);
1666     }
1667    }
1668   }
1669   if( cur == first ) {
1670    trie->minlen = chars;
1671    trie->maxlen = chars;
1672   } else if (chars < trie->minlen) {
1673    trie->minlen = chars;
1674   } else if (chars > trie->maxlen) {
1675    trie->maxlen = chars;
1676   }
1677   if (OP( noper ) == EXACTFU_SS) {
1678    /* XXX: workaround - 'ss' could match "\x{DF}" so minlen could be 1 and not 2*/
1679    if (trie->minlen > 1)
1680     trie->minlen= 1;
1681   }
1682   if (OP( noper ) == EXACTFU_TRICKYFOLD) {
1683    /* XXX: workround - things like "\x{1FBE}\x{0308}\x{0301}" can match "\x{0390}"
1684    *        - We assume that any such sequence might match a 2 byte string */
1685    if (trie->minlen > 2 )
1686     trie->minlen= 2;
1687   }
1688
1689  } /* end first pass */
1690  DEBUG_TRIE_COMPILE_r(
1691   PerlIO_printf( Perl_debug_log, "%*sTRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
1692     (int)depth * 2 + 2,"",
1693     ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
1694     (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
1695     (int)trie->minlen, (int)trie->maxlen )
1696  );
1697
1698  /*
1699   We now know what we are dealing with in terms of unique chars and
1700   string sizes so we can calculate how much memory a naive
1701   representation using a flat table  will take. If it's over a reasonable
1702   limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
1703   conservative but potentially much slower representation using an array
1704   of lists.
1705
1706   At the end we convert both representations into the same compressed
1707   form that will be used in regexec.c for matching with. The latter
1708   is a form that cannot be used to construct with but has memory
1709   properties similar to the list form and access properties similar
1710   to the table form making it both suitable for fast searches and
1711   small enough that its feasable to store for the duration of a program.
1712
1713   See the comment in the code where the compressed table is produced
1714   inplace from the flat tabe representation for an explanation of how
1715   the compression works.
1716
1717  */
1718
1719
1720  Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
1721  prev_states[1] = 0;
1722
1723  if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1) > SvIV(re_trie_maxbuff) ) {
1724   /*
1725    Second Pass -- Array Of Lists Representation
1726
1727    Each state will be represented by a list of charid:state records
1728    (reg_trie_trans_le) the first such element holds the CUR and LEN
1729    points of the allocated array. (See defines above).
1730
1731    We build the initial structure using the lists, and then convert
1732    it into the compressed table form which allows faster lookups
1733    (but cant be modified once converted).
1734   */
1735
1736   STRLEN transcount = 1;
1737
1738   DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log,
1739    "%*sCompiling trie using list compiler\n",
1740    (int)depth * 2 + 2, ""));
1741
1742   trie->states = (reg_trie_state *)
1743    PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1744         sizeof(reg_trie_state) );
1745   TRIE_LIST_NEW(1);
1746   next_alloc = 2;
1747
1748   for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1749
1750    regnode * const noper = NEXTOPER( cur );
1751    U8 *uc           = (U8*)STRING( noper );
1752    const U8 * const e = uc + STR_LEN( noper );
1753    U32 state        = 1;         /* required init */
1754    U16 charid       = 0;         /* sanity init */
1755    U8 *scan         = (U8*)NULL; /* sanity init */
1756    STRLEN foldlen   = 0;         /* required init */
1757    U32 wordlen      = 0;         /* required init */
1758    U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1759    STRLEN skiplen   = 0;
1760
1761    if (OP(noper) != NOTHING) {
1762     for ( ; uc < e ; uc += len ) {
1763
1764      TRIE_READ_CHAR;
1765
1766      if ( uvc < 256 ) {
1767       charid = trie->charmap[ uvc ];
1768      } else {
1769       SV** const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
1770       if ( !svpp ) {
1771        charid = 0;
1772       } else {
1773        charid=(U16)SvIV( *svpp );
1774       }
1775      }
1776      /* charid is now 0 if we dont know the char read, or nonzero if we do */
1777      if ( charid ) {
1778
1779       U16 check;
1780       U32 newstate = 0;
1781
1782       charid--;
1783       if ( !trie->states[ state ].trans.list ) {
1784        TRIE_LIST_NEW( state );
1785       }
1786       for ( check = 1; check <= TRIE_LIST_USED( state ); check++ ) {
1787        if ( TRIE_LIST_ITEM( state, check ).forid == charid ) {
1788         newstate = TRIE_LIST_ITEM( state, check ).newstate;
1789         break;
1790        }
1791       }
1792       if ( ! newstate ) {
1793        newstate = next_alloc++;
1794        prev_states[newstate] = state;
1795        TRIE_LIST_PUSH( state, charid, newstate );
1796        transcount++;
1797       }
1798       state = newstate;
1799      } else {
1800       Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1801      }
1802     }
1803    }
1804    TRIE_HANDLE_WORD(state);
1805
1806   } /* end second pass */
1807
1808   /* next alloc is the NEXT state to be allocated */
1809   trie->statecount = next_alloc;
1810   trie->states = (reg_trie_state *)
1811    PerlMemShared_realloc( trie->states,
1812         next_alloc
1813         * sizeof(reg_trie_state) );
1814
1815   /* and now dump it out before we compress it */
1816   DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
1817               revcharmap, next_alloc,
1818               depth+1)
1819   );
1820
1821   trie->trans = (reg_trie_trans *)
1822    PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
1823   {
1824    U32 state;
1825    U32 tp = 0;
1826    U32 zp = 0;
1827
1828
1829    for( state=1 ; state < next_alloc ; state ++ ) {
1830     U32 base=0;
1831
1832     /*
1833     DEBUG_TRIE_COMPILE_MORE_r(
1834      PerlIO_printf( Perl_debug_log, "tp: %d zp: %d ",tp,zp)
1835     );
1836     */
1837
1838     if (trie->states[state].trans.list) {
1839      U16 minid=TRIE_LIST_ITEM( state, 1).forid;
1840      U16 maxid=minid;
1841      U16 idx;
1842
1843      for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1844       const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
1845       if ( forid < minid ) {
1846        minid=forid;
1847       } else if ( forid > maxid ) {
1848        maxid=forid;
1849       }
1850      }
1851      if ( transcount < tp + maxid - minid + 1) {
1852       transcount *= 2;
1853       trie->trans = (reg_trie_trans *)
1854        PerlMemShared_realloc( trie->trans,
1855              transcount
1856              * sizeof(reg_trie_trans) );
1857       Zero( trie->trans + (transcount / 2), transcount / 2 , reg_trie_trans );
1858      }
1859      base = trie->uniquecharcount + tp - minid;
1860      if ( maxid == minid ) {
1861       U32 set = 0;
1862       for ( ; zp < tp ; zp++ ) {
1863        if ( ! trie->trans[ zp ].next ) {
1864         base = trie->uniquecharcount + zp - minid;
1865         trie->trans[ zp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1866         trie->trans[ zp ].check = state;
1867         set = 1;
1868         break;
1869        }
1870       }
1871       if ( !set ) {
1872        trie->trans[ tp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1873        trie->trans[ tp ].check = state;
1874        tp++;
1875        zp = tp;
1876       }
1877      } else {
1878       for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1879        const U32 tid = base -  trie->uniquecharcount + TRIE_LIST_ITEM( state, idx ).forid;
1880        trie->trans[ tid ].next = TRIE_LIST_ITEM( state, idx ).newstate;
1881        trie->trans[ tid ].check = state;
1882       }
1883       tp += ( maxid - minid + 1 );
1884      }
1885      Safefree(trie->states[ state ].trans.list);
1886     }
1887     /*
1888     DEBUG_TRIE_COMPILE_MORE_r(
1889      PerlIO_printf( Perl_debug_log, " base: %d\n",base);
1890     );
1891     */
1892     trie->states[ state ].trans.base=base;
1893    }
1894    trie->lasttrans = tp + 1;
1895   }
1896  } else {
1897   /*
1898   Second Pass -- Flat Table Representation.
1899
1900   we dont use the 0 slot of either trans[] or states[] so we add 1 to each.
1901   We know that we will need Charcount+1 trans at most to store the data
1902   (one row per char at worst case) So we preallocate both structures
1903   assuming worst case.
1904
1905   We then construct the trie using only the .next slots of the entry
1906   structs.
1907
1908   We use the .check field of the first entry of the node temporarily to
1909   make compression both faster and easier by keeping track of how many non
1910   zero fields are in the node.
1911
1912   Since trans are numbered from 1 any 0 pointer in the table is a FAIL
1913   transition.
1914
1915   There are two terms at use here: state as a TRIE_NODEIDX() which is a
1916   number representing the first entry of the node, and state as a
1917   TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1) and
1918   TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3) if there
1919   are 2 entrys per node. eg:
1920
1921    A B       A B
1922   1. 2 4    1. 3 7
1923   2. 0 3    3. 0 5
1924   3. 0 0    5. 0 0
1925   4. 0 0    7. 0 0
1926
1927   The table is internally in the right hand, idx form. However as we also
1928   have to deal with the states array which is indexed by nodenum we have to
1929   use TRIE_NODENUM() to convert.
1930
1931   */
1932   DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log,
1933    "%*sCompiling trie using table compiler\n",
1934    (int)depth * 2 + 2, ""));
1935
1936   trie->trans = (reg_trie_trans *)
1937    PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
1938         * trie->uniquecharcount + 1,
1939         sizeof(reg_trie_trans) );
1940   trie->states = (reg_trie_state *)
1941    PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1942         sizeof(reg_trie_state) );
1943   next_alloc = trie->uniquecharcount + 1;
1944
1945
1946   for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1947
1948    regnode * const noper   = NEXTOPER( cur );
1949    const U8 *uc     = (U8*)STRING( noper );
1950    const U8 * const e = uc + STR_LEN( noper );
1951
1952    U32 state        = 1;         /* required init */
1953
1954    U16 charid       = 0;         /* sanity init */
1955    U32 accept_state = 0;         /* sanity init */
1956    U8 *scan         = (U8*)NULL; /* sanity init */
1957
1958    STRLEN foldlen   = 0;         /* required init */
1959    U32 wordlen      = 0;         /* required init */
1960    STRLEN skiplen   = 0;
1961    U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1962
1963
1964    if ( OP(noper) != NOTHING ) {
1965     for ( ; uc < e ; uc += len ) {
1966
1967      TRIE_READ_CHAR;
1968
1969      if ( uvc < 256 ) {
1970       charid = trie->charmap[ uvc ];
1971      } else {
1972       SV* const * const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
1973       charid = svpp ? (U16)SvIV(*svpp) : 0;
1974      }
1975      if ( charid ) {
1976       charid--;
1977       if ( !trie->trans[ state + charid ].next ) {
1978        trie->trans[ state + charid ].next = next_alloc;
1979        trie->trans[ state ].check++;
1980        prev_states[TRIE_NODENUM(next_alloc)]
1981          = TRIE_NODENUM(state);
1982        next_alloc += trie->uniquecharcount;
1983       }
1984       state = trie->trans[ state + charid ].next;
1985      } else {
1986       Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1987      }
1988      /* charid is now 0 if we dont know the char read, or nonzero if we do */
1989     }
1990    }
1991    accept_state = TRIE_NODENUM( state );
1992    TRIE_HANDLE_WORD(accept_state);
1993
1994   } /* end second pass */
1995
1996   /* and now dump it out before we compress it */
1997   DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
1998               revcharmap,
1999               next_alloc, depth+1));
2000
2001   {
2002   /*
2003   * Inplace compress the table.*
2004
2005   For sparse data sets the table constructed by the trie algorithm will
2006   be mostly 0/FAIL transitions or to put it another way mostly empty.
2007   (Note that leaf nodes will not contain any transitions.)
2008
2009   This algorithm compresses the tables by eliminating most such
2010   transitions, at the cost of a modest bit of extra work during lookup:
2011
2012   - Each states[] entry contains a .base field which indicates the
2013   index in the state[] array wheres its transition data is stored.
2014
2015   - If .base is 0 there are no valid transitions from that node.
2016
2017   - If .base is nonzero then charid is added to it to find an entry in
2018   the trans array.
2019
2020   -If trans[states[state].base+charid].check!=state then the
2021   transition is taken to be a 0/Fail transition. Thus if there are fail
2022   transitions at the front of the node then the .base offset will point
2023   somewhere inside the previous nodes data (or maybe even into a node
2024   even earlier), but the .check field determines if the transition is
2025   valid.
2026
2027   XXX - wrong maybe?
2028   The following process inplace converts the table to the compressed
2029   table: We first do not compress the root node 1,and mark all its
2030   .check pointers as 1 and set its .base pointer as 1 as well. This
2031   allows us to do a DFA construction from the compressed table later,
2032   and ensures that any .base pointers we calculate later are greater
2033   than 0.
2034
2035   - We set 'pos' to indicate the first entry of the second node.
2036
2037   - We then iterate over the columns of the node, finding the first and
2038   last used entry at l and m. We then copy l..m into pos..(pos+m-l),
2039   and set the .check pointers accordingly, and advance pos
2040   appropriately and repreat for the next node. Note that when we copy
2041   the next pointers we have to convert them from the original
2042   NODEIDX form to NODENUM form as the former is not valid post
2043   compression.
2044
2045   - If a node has no transitions used we mark its base as 0 and do not
2046   advance the pos pointer.
2047
2048   - If a node only has one transition we use a second pointer into the
2049   structure to fill in allocated fail transitions from other states.
2050   This pointer is independent of the main pointer and scans forward
2051   looking for null transitions that are allocated to a state. When it
2052   finds one it writes the single transition into the "hole".  If the
2053   pointer doesnt find one the single transition is appended as normal.
2054
2055   - Once compressed we can Renew/realloc the structures to release the
2056   excess space.
2057
2058   See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
2059   specifically Fig 3.47 and the associated pseudocode.
2060
2061   demq
2062   */
2063   const U32 laststate = TRIE_NODENUM( next_alloc );
2064   U32 state, charid;
2065   U32 pos = 0, zp=0;
2066   trie->statecount = laststate;
2067
2068   for ( state = 1 ; state < laststate ; state++ ) {
2069    U8 flag = 0;
2070    const U32 stateidx = TRIE_NODEIDX( state );
2071    const U32 o_used = trie->trans[ stateidx ].check;
2072    U32 used = trie->trans[ stateidx ].check;
2073    trie->trans[ stateidx ].check = 0;
2074
2075    for ( charid = 0 ; used && charid < trie->uniquecharcount ; charid++ ) {
2076     if ( flag || trie->trans[ stateidx + charid ].next ) {
2077      if ( trie->trans[ stateidx + charid ].next ) {
2078       if (o_used == 1) {
2079        for ( ; zp < pos ; zp++ ) {
2080         if ( ! trie->trans[ zp ].next ) {
2081          break;
2082         }
2083        }
2084        trie->states[ state ].trans.base = zp + trie->uniquecharcount - charid ;
2085        trie->trans[ zp ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2086        trie->trans[ zp ].check = state;
2087        if ( ++zp > pos ) pos = zp;
2088        break;
2089       }
2090       used--;
2091      }
2092      if ( !flag ) {
2093       flag = 1;
2094       trie->states[ state ].trans.base = pos + trie->uniquecharcount - charid ;
2095      }
2096      trie->trans[ pos ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2097      trie->trans[ pos ].check = state;
2098      pos++;
2099     }
2100    }
2101   }
2102   trie->lasttrans = pos + 1;
2103   trie->states = (reg_trie_state *)
2104    PerlMemShared_realloc( trie->states, laststate
2105         * sizeof(reg_trie_state) );
2106   DEBUG_TRIE_COMPILE_MORE_r(
2107     PerlIO_printf( Perl_debug_log,
2108      "%*sAlloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n",
2109      (int)depth * 2 + 2,"",
2110      (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1 ),
2111      (IV)next_alloc,
2112      (IV)pos,
2113      ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
2114    );
2115
2116   } /* end table compress */
2117  }
2118  DEBUG_TRIE_COMPILE_MORE_r(
2119    PerlIO_printf(Perl_debug_log, "%*sStatecount:%"UVxf" Lasttrans:%"UVxf"\n",
2120     (int)depth * 2 + 2, "",
2121     (UV)trie->statecount,
2122     (UV)trie->lasttrans)
2123  );
2124  /* resize the trans array to remove unused space */
2125  trie->trans = (reg_trie_trans *)
2126   PerlMemShared_realloc( trie->trans, trie->lasttrans
2127        * sizeof(reg_trie_trans) );
2128
2129  {   /* Modify the program and insert the new TRIE node */
2130   U8 nodetype =(U8)(flags & 0xFF);
2131   char *str=NULL;
2132
2133 #ifdef DEBUGGING
2134   regnode *optimize = NULL;
2135 #ifdef RE_TRACK_PATTERN_OFFSETS
2136
2137   U32 mjd_offset = 0;
2138   U32 mjd_nodelen = 0;
2139 #endif /* RE_TRACK_PATTERN_OFFSETS */
2140 #endif /* DEBUGGING */
2141   /*
2142   This means we convert either the first branch or the first Exact,
2143   depending on whether the thing following (in 'last') is a branch
2144   or not and whther first is the startbranch (ie is it a sub part of
2145   the alternation or is it the whole thing.)
2146   Assuming its a sub part we convert the EXACT otherwise we convert
2147   the whole branch sequence, including the first.
2148   */
2149   /* Find the node we are going to overwrite */
2150   if ( first != startbranch || OP( last ) == BRANCH ) {
2151    /* branch sub-chain */
2152    NEXT_OFF( first ) = (U16)(last - first);
2153 #ifdef RE_TRACK_PATTERN_OFFSETS
2154    DEBUG_r({
2155     mjd_offset= Node_Offset((convert));
2156     mjd_nodelen= Node_Length((convert));
2157    });
2158 #endif
2159    /* whole branch chain */
2160   }
2161 #ifdef RE_TRACK_PATTERN_OFFSETS
2162   else {
2163    DEBUG_r({
2164     const  regnode *nop = NEXTOPER( convert );
2165     mjd_offset= Node_Offset((nop));
2166     mjd_nodelen= Node_Length((nop));
2167    });
2168   }
2169   DEBUG_OPTIMISE_r(
2170    PerlIO_printf(Perl_debug_log, "%*sMJD offset:%"UVuf" MJD length:%"UVuf"\n",
2171     (int)depth * 2 + 2, "",
2172     (UV)mjd_offset, (UV)mjd_nodelen)
2173   );
2174 #endif
2175   /* But first we check to see if there is a common prefix we can
2176   split out as an EXACT and put in front of the TRIE node.  */
2177   trie->startstate= 1;
2178   if ( trie->bitmap && !widecharmap && !trie->jump  ) {
2179    U32 state;
2180    for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
2181     U32 ofs = 0;
2182     I32 idx = -1;
2183     U32 count = 0;
2184     const U32 base = trie->states[ state ].trans.base;
2185
2186     if ( trie->states[state].wordnum )
2187       count = 1;
2188
2189     for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2190      if ( ( base + ofs >= trie->uniquecharcount ) &&
2191       ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
2192       trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
2193      {
2194       if ( ++count > 1 ) {
2195        SV **tmp = av_fetch( revcharmap, ofs, 0);
2196        const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
2197        if ( state == 1 ) break;
2198        if ( count == 2 ) {
2199         Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
2200         DEBUG_OPTIMISE_r(
2201          PerlIO_printf(Perl_debug_log,
2202           "%*sNew Start State=%"UVuf" Class: [",
2203           (int)depth * 2 + 2, "",
2204           (UV)state));
2205         if (idx >= 0) {
2206          SV ** const tmp = av_fetch( revcharmap, idx, 0);
2207          const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
2208
2209          TRIE_BITMAP_SET(trie,*ch);
2210          if ( folder )
2211           TRIE_BITMAP_SET(trie, folder[ *ch ]);
2212          DEBUG_OPTIMISE_r(
2213           PerlIO_printf(Perl_debug_log, "%s", (char*)ch)
2214          );
2215         }
2216        }
2217        TRIE_BITMAP_SET(trie,*ch);
2218        if ( folder )
2219         TRIE_BITMAP_SET(trie,folder[ *ch ]);
2220        DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"%s", ch));
2221       }
2222       idx = ofs;
2223      }
2224     }
2225     if ( count == 1 ) {
2226      SV **tmp = av_fetch( revcharmap, idx, 0);
2227      STRLEN len;
2228      char *ch = SvPV( *tmp, len );
2229      DEBUG_OPTIMISE_r({
2230       SV *sv=sv_newmortal();
2231       PerlIO_printf( Perl_debug_log,
2232        "%*sPrefix State: %"UVuf" Idx:%"UVuf" Char='%s'\n",
2233        (int)depth * 2 + 2, "",
2234        (UV)state, (UV)idx,
2235        pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6,
2236         PL_colors[0], PL_colors[1],
2237         (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2238         PERL_PV_ESCAPE_FIRSTCHAR
2239        )
2240       );
2241      });
2242      if ( state==1 ) {
2243       OP( convert ) = nodetype;
2244       str=STRING(convert);
2245       STR_LEN(convert)=0;
2246      }
2247      STR_LEN(convert) += len;
2248      while (len--)
2249       *str++ = *ch++;
2250     } else {
2251 #ifdef DEBUGGING
2252      if (state>1)
2253       DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"]\n"));
2254 #endif
2255      break;
2256     }
2257    }
2258    trie->prefixlen = (state-1);
2259    if (str) {
2260     regnode *n = convert+NODE_SZ_STR(convert);
2261     NEXT_OFF(convert) = NODE_SZ_STR(convert);
2262     trie->startstate = state;
2263     trie->minlen -= (state - 1);
2264     trie->maxlen -= (state - 1);
2265 #ifdef DEBUGGING
2266    /* At least the UNICOS C compiler choked on this
2267     * being argument to DEBUG_r(), so let's just have
2268     * it right here. */
2269    if (
2270 #ifdef PERL_EXT_RE_BUILD
2271     1
2272 #else
2273     DEBUG_r_TEST
2274 #endif
2275     ) {
2276     regnode *fix = convert;
2277     U32 word = trie->wordcount;
2278     mjd_nodelen++;
2279     Set_Node_Offset_Length(convert, mjd_offset, state - 1);
2280     while( ++fix < n ) {
2281      Set_Node_Offset_Length(fix, 0, 0);
2282     }
2283     while (word--) {
2284      SV ** const tmp = av_fetch( trie_words, word, 0 );
2285      if (tmp) {
2286       if ( STR_LEN(convert) <= SvCUR(*tmp) )
2287        sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
2288       else
2289        sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
2290      }
2291     }
2292    }
2293 #endif
2294     if (trie->maxlen) {
2295      convert = n;
2296     } else {
2297      NEXT_OFF(convert) = (U16)(tail - convert);
2298      DEBUG_r(optimize= n);
2299     }
2300    }
2301   }
2302   if (!jumper)
2303    jumper = last;
2304   if ( trie->maxlen ) {
2305    NEXT_OFF( convert ) = (U16)(tail - convert);
2306    ARG_SET( convert, data_slot );
2307    /* Store the offset to the first unabsorbed branch in
2308    jump[0], which is otherwise unused by the jump logic.
2309    We use this when dumping a trie and during optimisation. */
2310    if (trie->jump)
2311     trie->jump[0] = (U16)(nextbranch - convert);
2312
2313    /* If the start state is not accepting (meaning there is no empty string/NOTHING)
2314    *   and there is a bitmap
2315    *   and the first "jump target" node we found leaves enough room
2316    * then convert the TRIE node into a TRIEC node, with the bitmap
2317    * embedded inline in the opcode - this is hypothetically faster.
2318    */
2319    if ( !trie->states[trie->startstate].wordnum
2320     && trie->bitmap
2321     && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
2322    {
2323     OP( convert ) = TRIEC;
2324     Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
2325     PerlMemShared_free(trie->bitmap);
2326     trie->bitmap= NULL;
2327    } else
2328     OP( convert ) = TRIE;
2329
2330    /* store the type in the flags */
2331    convert->flags = nodetype;
2332    DEBUG_r({
2333    optimize = convert
2334      + NODE_STEP_REGNODE
2335      + regarglen[ OP( convert ) ];
2336    });
2337    /* XXX We really should free up the resource in trie now,
2338     as we won't use them - (which resources?) dmq */
2339   }
2340   /* needed for dumping*/
2341   DEBUG_r(if (optimize) {
2342    regnode *opt = convert;
2343
2344    while ( ++opt < optimize) {
2345     Set_Node_Offset_Length(opt,0,0);
2346    }
2347    /*
2348     Try to clean up some of the debris left after the
2349     optimisation.
2350    */
2351    while( optimize < jumper ) {
2352     mjd_nodelen += Node_Length((optimize));
2353     OP( optimize ) = OPTIMIZED;
2354     Set_Node_Offset_Length(optimize,0,0);
2355     optimize++;
2356    }
2357    Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
2358   });
2359  } /* end node insert */
2360  REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, convert);
2361
2362  /*  Finish populating the prev field of the wordinfo array.  Walk back
2363  *  from each accept state until we find another accept state, and if
2364  *  so, point the first word's .prev field at the second word. If the
2365  *  second already has a .prev field set, stop now. This will be the
2366  *  case either if we've already processed that word's accept state,
2367  *  or that state had multiple words, and the overspill words were
2368  *  already linked up earlier.
2369  */
2370  {
2371   U16 word;
2372   U32 state;
2373   U16 prev;
2374
2375   for (word=1; word <= trie->wordcount; word++) {
2376    prev = 0;
2377    if (trie->wordinfo[word].prev)
2378     continue;
2379    state = trie->wordinfo[word].accept;
2380    while (state) {
2381     state = prev_states[state];
2382     if (!state)
2383      break;
2384     prev = trie->states[state].wordnum;
2385     if (prev)
2386      break;
2387    }
2388    trie->wordinfo[word].prev = prev;
2389   }
2390   Safefree(prev_states);
2391  }
2392
2393
2394  /* and now dump out the compressed format */
2395  DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
2396
2397  RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
2398 #ifdef DEBUGGING
2399  RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
2400  RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
2401 #else
2402  SvREFCNT_dec(revcharmap);
2403 #endif
2404  return trie->jump
2405   ? MADE_JUMP_TRIE
2406   : trie->startstate>1
2407    ? MADE_EXACT_TRIE
2408    : MADE_TRIE;
2409 }
2410
2411 STATIC void
2412 S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source,  regnode *stclass, U32 depth)
2413 {
2414 /* The Trie is constructed and compressed now so we can build a fail array if it's needed
2415
2416    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and 3.32 in the
2417    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi, Ullman 1985/88
2418    ISBN 0-201-10088-6
2419
2420    We find the fail state for each state in the trie, this state is the longest proper
2421    suffix of the current state's 'word' that is also a proper prefix of another word in our
2422    trie. State 1 represents the word '' and is thus the default fail state. This allows
2423    the DFA not to have to restart after its tried and failed a word at a given point, it
2424    simply continues as though it had been matching the other word in the first place.
2425    Consider
2426  'abcdgu'=~/abcdefg|cdgu/
2427    When we get to 'd' we are still matching the first word, we would encounter 'g' which would
2428    fail, which would bring us to the state representing 'd' in the second word where we would
2429    try 'g' and succeed, proceeding to match 'cdgu'.
2430  */
2431  /* add a fail transition */
2432  const U32 trie_offset = ARG(source);
2433  reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
2434  U32 *q;
2435  const U32 ucharcount = trie->uniquecharcount;
2436  const U32 numstates = trie->statecount;
2437  const U32 ubound = trie->lasttrans + ucharcount;
2438  U32 q_read = 0;
2439  U32 q_write = 0;
2440  U32 charid;
2441  U32 base = trie->states[ 1 ].trans.base;
2442  U32 *fail;
2443  reg_ac_data *aho;
2444  const U32 data_slot = add_data( pRExC_state, 1, "T" );
2445  GET_RE_DEBUG_FLAGS_DECL;
2446
2447  PERL_ARGS_ASSERT_MAKE_TRIE_FAILTABLE;
2448 #ifndef DEBUGGING
2449  PERL_UNUSED_ARG(depth);
2450 #endif
2451
2452
2453  ARG_SET( stclass, data_slot );
2454  aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
2455  RExC_rxi->data->data[ data_slot ] = (void*)aho;
2456  aho->trie=trie_offset;
2457  aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
2458  Copy( trie->states, aho->states, numstates, reg_trie_state );
2459  Newxz( q, numstates, U32);
2460  aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
2461  aho->refcount = 1;
2462  fail = aho->fail;
2463  /* initialize fail[0..1] to be 1 so that we always have
2464  a valid final fail state */
2465  fail[ 0 ] = fail[ 1 ] = 1;
2466
2467  for ( charid = 0; charid < ucharcount ; charid++ ) {
2468   const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
2469   if ( newstate ) {
2470    q[ q_write ] = newstate;
2471    /* set to point at the root */
2472    fail[ q[ q_write++ ] ]=1;
2473   }
2474  }
2475  while ( q_read < q_write) {
2476   const U32 cur = q[ q_read++ % numstates ];
2477   base = trie->states[ cur ].trans.base;
2478
2479   for ( charid = 0 ; charid < ucharcount ; charid++ ) {
2480    const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
2481    if (ch_state) {
2482     U32 fail_state = cur;
2483     U32 fail_base;
2484     do {
2485      fail_state = fail[ fail_state ];
2486      fail_base = aho->states[ fail_state ].trans.base;
2487     } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
2488
2489     fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
2490     fail[ ch_state ] = fail_state;
2491     if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
2492     {
2493       aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
2494     }
2495     q[ q_write++ % numstates] = ch_state;
2496    }
2497   }
2498  }
2499  /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
2500  when we fail in state 1, this allows us to use the
2501  charclass scan to find a valid start char. This is based on the principle
2502  that theres a good chance the string being searched contains lots of stuff
2503  that cant be a start char.
2504  */
2505  fail[ 0 ] = fail[ 1 ] = 0;
2506  DEBUG_TRIE_COMPILE_r({
2507   PerlIO_printf(Perl_debug_log,
2508      "%*sStclass Failtable (%"UVuf" states): 0",
2509      (int)(depth * 2), "", (UV)numstates
2510   );
2511   for( q_read=1; q_read<numstates; q_read++ ) {
2512    PerlIO_printf(Perl_debug_log, ", %"UVuf, (UV)fail[q_read]);
2513   }
2514   PerlIO_printf(Perl_debug_log, "\n");
2515  });
2516  Safefree(q);
2517  /*RExC_seen |= REG_SEEN_TRIEDFA;*/
2518 }
2519
2520
2521 /*
2522  * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2523  * These need to be revisited when a newer toolchain becomes available.
2524  */
2525 #if defined(__sparc64__) && defined(__GNUC__)
2526 #   if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2527 #       undef  SPARC64_GCC_WORKAROUND
2528 #       define SPARC64_GCC_WORKAROUND 1
2529 #   endif
2530 #endif
2531
2532 #define DEBUG_PEEP(str,scan,depth) \
2533  DEBUG_OPTIMISE_r({if (scan){ \
2534  SV * const mysv=sv_newmortal(); \
2535  regnode *Next = regnext(scan); \
2536  regprop(RExC_rx, mysv, scan); \
2537  PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s (%d)\n", \
2538  (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\
2539  Next ? (REG_NODE_NUM(Next)) : 0 ); \
2540    }});
2541
2542
2543 /* The below joins as many adjacent EXACTish nodes as possible into a single
2544  * one, and looks for problematic sequences of characters whose folds vs.
2545  * non-folds have sufficiently different lengths, that the optimizer would be
2546  * fooled into rejecting legitimate matches of them, and the trie construction
2547  * code can't cope with them.  The joining is only done if:
2548  * 1) there is room in the current conglomerated node to entirely contain the
2549  *    next one.
2550  * 2) they are the exact same node type
2551  *
2552  * The adjacent nodes actually may be separated by NOTHING kind nodes, and
2553  * these get optimized out
2554  *
2555  * If there are problematic code sequences, *min_subtract is set to the delta
2556  * that the minimum size of the node can be less than its actual size.  And,
2557  * the node type of the result is changed to reflect that it contains these
2558  * sequences.
2559  *
2560  * And *has_exactf_sharp_s is set to indicate whether or not the node is EXACTF
2561  * and contains LATIN SMALL LETTER SHARP S
2562  *
2563  * This is as good a place as any to discuss the design of handling these
2564  * problematic sequences.  It's been wrong in Perl for a very long time.  There
2565  * are three code points in Unicode whose folded lengths differ so much from
2566  * the un-folded lengths that it causes problems for the optimizer and trie
2567  * construction.  Why only these are problematic, and not others where lengths
2568  * also differ is something I (khw) do not understand.  New versions of Unicode
2569  * might add more such code points.  Hopefully the logic in fold_grind.t that
2570  * figures out what to test (in part by verifying that each size-combination
2571  * gets tested) will catch any that do come along, so they can be added to the
2572  * special handling below.  The chances of new ones are actually rather small,
2573  * as most, if not all, of the world's scripts that have casefolding have
2574  * already been encoded by Unicode.  Also, a number of Unicode's decisions were
2575  * made to allow compatibility with pre-existing standards, and almost all of
2576  * those have already been dealt with.  These would otherwise be the most
2577  * likely candidates for generating further tricky sequences.  In other words,
2578  * Unicode by itself is unlikely to add new ones unless it is for compatibility
2579  * with pre-existing standards, and there aren't many of those left.
2580  *
2581  * The previous designs for dealing with these involved assigning a special
2582  * node for them.  This approach doesn't work, as evidenced by this example:
2583  *      "\xDFs" =~ /s\xDF/ui    # Used to fail before these patches
2584  * Both these fold to "sss", but if the pattern is parsed to create a node of
2585  * that would match just the \xDF, it won't be able to handle the case where a
2586  * successful match would have to cross the node's boundary.  The new approach
2587  * that hopefully generally solves the problem generates an EXACTFU_SS node
2588  * that is "sss".
2589  *
2590  * There are a number of components to the approach (a lot of work for just
2591  * three code points!):
2592  * 1)   This routine examines each EXACTFish node that could contain the
2593  *      problematic sequences.  It returns in *min_subtract how much to
2594  *      subtract from the the actual length of the string to get a real minimum
2595  *      for one that could match it.  This number is usually 0 except for the
2596  *      problematic sequences.  This delta is used by the caller to adjust the
2597  *      min length of the match, and the delta between min and max, so that the
2598  *      optimizer doesn't reject these possibilities based on size constraints.
2599  * 2)   These sequences are not currently correctly handled by the trie code
2600  *      either, so it changes the joined node type to ops that are not handled
2601  *      by trie's, those new ops being EXACTFU_SS and EXACTFU_TRICKYFOLD.
2602  * 3)   This is sufficient for the two Greek sequences (described below), but
2603  *      the one involving the Sharp s (\xDF) needs more.  The node type
2604  *      EXACTFU_SS is used for an EXACTFU node that contains at least one "ss"
2605  *      sequence in it.  For non-UTF-8 patterns and strings, this is the only
2606  *      case where there is a possible fold length change.  That means that a
2607  *      regular EXACTFU node without UTF-8 involvement doesn't have to concern
2608  *      itself with length changes, and so can be processed faster.  regexec.c
2609  *      takes advantage of this.  Generally, an EXACTFish node that is in UTF-8
2610  *      is pre-folded by regcomp.c.  This saves effort in regex matching.
2611  *      However, probably mostly for historical reasons, the pre-folding isn't
2612  *      done for non-UTF8 patterns (and it can't be for EXACTF and EXACTFL
2613  *      nodes, as what they fold to isn't known until runtime.)  The fold
2614  *      possibilities for the non-UTF8 patterns are quite simple, except for
2615  *      the sharp s.  All the ones that don't involve a UTF-8 target string
2616  *      are members of a fold-pair, and arrays are set up for all of them
2617  *      that quickly find the other member of the pair.  It might actually
2618  *      be faster to pre-fold these, but it isn't currently done, except for
2619  *      the sharp s.  Code elsewhere in this file makes sure that it gets
2620  *      folded to 'ss', even if the pattern isn't UTF-8.  This avoids the
2621  *      issues described in the next item.
2622  * 4)   A problem remains for the sharp s in EXACTF nodes.  Whether it matches
2623  *      'ss' or not is not knowable at compile time.  It will match iff the
2624  *      target string is in UTF-8, unlike the EXACTFU nodes, where it always
2625  *      matches; and the EXACTFL and EXACTFA nodes where it never does.  Thus
2626  *      it can't be folded to "ss" at compile time, unlike EXACTFU does as
2627  *      described in item 3).  An assumption that the optimizer part of
2628  *      regexec.c (probably unwittingly) makes is that a character in the
2629  *      pattern corresponds to at most a single character in the target string.
2630  *      (And I do mean character, and not byte here, unlike other parts of the
2631  *      documentation that have never been updated to account for multibyte
2632  *      Unicode.)  This assumption is wrong only in this case, as all other
2633  *      cases are either 1-1 folds when no UTF-8 is involved; or is true by
2634  *      virtue of having this file pre-fold UTF-8 patterns.   I'm
2635  *      reluctant to try to change this assumption, so instead the code punts.
2636  *      This routine examines EXACTF nodes for the sharp s, and returns a
2637  *      boolean indicating whether or not the node is an EXACTF node that
2638  *      contains a sharp s.  When it is true, the caller sets a flag that later
2639  *      causes the optimizer in this file to not set values for the floating
2640  *      and fixed string lengths, and thus avoids the optimizer code in
2641  *      regexec.c that makes the invalid assumption.  Thus, there is no
2642  *      optimization based on string lengths for EXACTF nodes that contain the
2643  *      sharp s.  This only happens for /id rules (which means the pattern
2644  *      isn't in UTF-8).
2645  */
2646
2647 #define JOIN_EXACT(scan,min_subtract,has_exactf_sharp_s, flags) \
2648  if (PL_regkind[OP(scan)] == EXACT) \
2649   join_exact(pRExC_state,(scan),(min_subtract),has_exactf_sharp_s, (flags),NULL,depth+1)
2650
2651 STATIC U32
2652 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, UV *min_subtract, bool *has_exactf_sharp_s, U32 flags,regnode *val, U32 depth) {
2653  /* Merge several consecutive EXACTish nodes into one. */
2654  regnode *n = regnext(scan);
2655  U32 stringok = 1;
2656  regnode *next = scan + NODE_SZ_STR(scan);
2657  U32 merged = 0;
2658  U32 stopnow = 0;
2659 #ifdef DEBUGGING
2660  regnode *stop = scan;
2661  GET_RE_DEBUG_FLAGS_DECL;
2662 #else
2663  PERL_UNUSED_ARG(depth);
2664 #endif
2665
2666  PERL_ARGS_ASSERT_JOIN_EXACT;
2667 #ifndef EXPERIMENTAL_INPLACESCAN
2668  PERL_UNUSED_ARG(flags);
2669  PERL_UNUSED_ARG(val);
2670 #endif
2671  DEBUG_PEEP("join",scan,depth);
2672
2673  /* Look through the subsequent nodes in the chain.  Skip NOTHING, merge
2674  * EXACT ones that are mergeable to the current one. */
2675  while (n
2676   && (PL_regkind[OP(n)] == NOTHING
2677    || (stringok && OP(n) == OP(scan)))
2678   && NEXT_OFF(n)
2679   && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
2680  {
2681
2682   if (OP(n) == TAIL || n > next)
2683    stringok = 0;
2684   if (PL_regkind[OP(n)] == NOTHING) {
2685    DEBUG_PEEP("skip:",n,depth);
2686    NEXT_OFF(scan) += NEXT_OFF(n);
2687    next = n + NODE_STEP_REGNODE;
2688 #ifdef DEBUGGING
2689    if (stringok)
2690     stop = n;
2691 #endif
2692    n = regnext(n);
2693   }
2694   else if (stringok) {
2695    const unsigned int oldl = STR_LEN(scan);
2696    regnode * const nnext = regnext(n);
2697
2698    if (oldl + STR_LEN(n) > U8_MAX)
2699     break;
2700
2701    DEBUG_PEEP("merg",n,depth);
2702    merged++;
2703
2704    NEXT_OFF(scan) += NEXT_OFF(n);
2705    STR_LEN(scan) += STR_LEN(n);
2706    next = n + NODE_SZ_STR(n);
2707    /* Now we can overwrite *n : */
2708    Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
2709 #ifdef DEBUGGING
2710    stop = next - 1;
2711 #endif
2712    n = nnext;
2713    if (stopnow) break;
2714   }
2715
2716 #ifdef EXPERIMENTAL_INPLACESCAN
2717   if (flags && !NEXT_OFF(n)) {
2718    DEBUG_PEEP("atch", val, depth);
2719    if (reg_off_by_arg[OP(n)]) {
2720     ARG_SET(n, val - n);
2721    }
2722    else {
2723     NEXT_OFF(n) = val - n;
2724    }
2725    stopnow = 1;
2726   }
2727 #endif
2728  }
2729
2730  *min_subtract = 0;
2731  *has_exactf_sharp_s = FALSE;
2732
2733  /* Here, all the adjacent mergeable EXACTish nodes have been merged.  We
2734  * can now analyze for sequences of problematic code points.  (Prior to
2735  * this final joining, sequences could have been split over boundaries, and
2736  * hence missed).  The sequences only happen in folding, hence for any
2737  * non-EXACT EXACTish node */
2738  if (OP(scan) != EXACT) {
2739   U8 *s;
2740   U8 * s0 = (U8*) STRING(scan);
2741   U8 * const s_end = s0 + STR_LEN(scan);
2742
2743   /* The below is perhaps overboard, but this allows us to save a test
2744   * each time through the loop at the expense of a mask.  This is
2745   * because on both EBCDIC and ASCII machines, 'S' and 's' differ by a
2746   * single bit.  On ASCII they are 32 apart; on EBCDIC, they are 64.
2747   * This uses an exclusive 'or' to find that bit and then inverts it to
2748   * form a mask, with just a single 0, in the bit position where 'S' and
2749   * 's' differ. */
2750   const U8 S_or_s_mask = (U8) ~ ('S' ^ 's');
2751   const U8 s_masked = 's' & S_or_s_mask;
2752
2753   /* One pass is made over the node's string looking for all the
2754   * possibilities.  to avoid some tests in the loop, there are two main
2755   * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
2756   * non-UTF-8 */
2757   if (UTF) {
2758
2759    /* There are two problematic Greek code points in Unicode
2760    * casefolding
2761    *
2762    * U+0390 - GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
2763    * U+03B0 - GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
2764    *
2765    * which casefold to
2766    *
2767    * Unicode                      UTF-8
2768    *
2769    * U+03B9 U+0308 U+0301         0xCE 0xB9 0xCC 0x88 0xCC 0x81
2770    * U+03C5 U+0308 U+0301         0xCF 0x85 0xCC 0x88 0xCC 0x81
2771    *
2772    * This means that in case-insensitive matching (or "loose
2773    * matching", as Unicode calls it), an EXACTF of length six (the
2774    * UTF-8 encoded byte length of the above casefolded versions) can
2775    * match a target string of length two (the byte length of UTF-8
2776    * encoded U+0390 or U+03B0).  This would rather mess up the
2777    * minimum length computation.  (there are other code points that
2778    * also fold to these two sequences, but the delta is smaller)
2779    *
2780    * If these sequences are found, the minimum length is decreased by
2781    * four (six minus two).
2782    *
2783    * Similarly, 'ss' may match the single char and byte LATIN SMALL
2784    * LETTER SHARP S.  We decrease the min length by 1 for each
2785    * occurrence of 'ss' found */
2786
2787 #ifdef EBCDIC /* RD tunifold greek 0390 and 03B0 */
2788 #     define U390_first_byte 0xb4
2789    const U8 U390_tail[] = "\x68\xaf\x49\xaf\x42";
2790 #     define U3B0_first_byte 0xb5
2791    const U8 U3B0_tail[] = "\x46\xaf\x49\xaf\x42";
2792 #else
2793 #     define U390_first_byte 0xce
2794    const U8 U390_tail[] = "\xb9\xcc\x88\xcc\x81";
2795 #     define U3B0_first_byte 0xcf
2796    const U8 U3B0_tail[] = "\x85\xcc\x88\xcc\x81";
2797 #endif
2798    const U8 len = sizeof(U390_tail); /* (-1 for NUL; +1 for 1st byte;
2799             yields a net of 0 */
2800    /* Examine the string for one of the problematic sequences */
2801    for (s = s0;
2802     s < s_end - 1; /* Can stop 1 before the end, as minimum length
2803         * sequence we are looking for is 2 */
2804     s += UTF8SKIP(s))
2805    {
2806
2807     /* Look for the first byte in each problematic sequence */
2808     switch (*s) {
2809      /* We don't have to worry about other things that fold to
2810      * 's' (such as the long s, U+017F), as all above-latin1
2811      * code points have been pre-folded */
2812      case 's':
2813      case 'S':
2814
2815       /* Current character is an 's' or 'S'.  If next one is
2816       * as well, we have the dreaded sequence */
2817       if (((*(s+1) & S_or_s_mask) == s_masked)
2818        /* These two node types don't have special handling
2819        * for 'ss' */
2820        && OP(scan) != EXACTFL && OP(scan) != EXACTFA)
2821       {
2822        *min_subtract += 1;
2823        OP(scan) = EXACTFU_SS;
2824        s++;    /* No need to look at this character again */
2825       }
2826       break;
2827
2828      case U390_first_byte:
2829       if (s_end - s >= len
2830
2831        /* The 1's are because are skipping comparing the
2832        * first byte */
2833        && memEQ(s + 1, U390_tail, len - 1))
2834       {
2835        goto greek_sequence;
2836       }
2837       break;
2838
2839      case U3B0_first_byte:
2840       if (! (s_end - s >= len
2841        && memEQ(s + 1, U3B0_tail, len - 1)))
2842       {
2843        break;
2844       }
2845      greek_sequence:
2846       *min_subtract += 4;
2847
2848       /* This can't currently be handled by trie's, so change
2849       * the node type to indicate this.  If EXACTFA and
2850       * EXACTFL were ever to be handled by trie's, this
2851       * would have to be changed.  If this node has already
2852       * been changed to EXACTFU_SS in this loop, leave it as
2853       * is.  (I (khw) think it doesn't matter in regexec.c
2854       * for UTF patterns, but no need to change it */
2855       if (OP(scan) == EXACTFU) {
2856        OP(scan) = EXACTFU_TRICKYFOLD;
2857       }
2858       s += 6; /* We already know what this sequence is.  Skip
2859         the rest of it */
2860       break;
2861     }
2862    }
2863   }
2864   else if (OP(scan) != EXACTFL && OP(scan) != EXACTFA) {
2865
2866    /* Here, the pattern is not UTF-8.  We need to look only for the
2867    * 'ss' sequence, and in the EXACTF case, the sharp s, which can be
2868    * in the final position.  Otherwise we can stop looking 1 byte
2869    * earlier because have to find both the first and second 's' */
2870    const U8* upper = (OP(scan) == EXACTF) ? s_end : s_end -1;
2871
2872    for (s = s0; s < upper; s++) {
2873     switch (*s) {
2874      case 'S':
2875      case 's':
2876       if (s_end - s > 1
2877        && ((*(s+1) & S_or_s_mask) == s_masked))
2878       {
2879        *min_subtract += 1;
2880
2881        /* EXACTF nodes need to know that the minimum
2882        * length changed so that a sharp s in the string
2883        * can match this ss in the pattern, but they
2884        * remain EXACTF nodes, as they are not trie'able,
2885        * so don't have to invent a new node type to
2886        * exclude them from the trie code */
2887        if (OP(scan) != EXACTF) {
2888         OP(scan) = EXACTFU_SS;
2889        }
2890        s++;
2891       }
2892       break;
2893      case LATIN_SMALL_LETTER_SHARP_S:
2894       if (OP(scan) == EXACTF) {
2895        *has_exactf_sharp_s = TRUE;
2896       }
2897       break;
2898     }
2899    }
2900   }
2901  }
2902
2903 #ifdef DEBUGGING
2904  /* Allow dumping but overwriting the collection of skipped
2905  * ops and/or strings with fake optimized ops */
2906  n = scan + NODE_SZ_STR(scan);
2907  while (n <= stop) {
2908   OP(n) = OPTIMIZED;
2909   FLAGS(n) = 0;
2910   NEXT_OFF(n) = 0;
2911   n++;
2912  }
2913 #endif
2914  DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
2915  return stopnow;
2916 }
2917
2918 /* REx optimizer.  Converts nodes into quicker variants "in place".
2919    Finds fixed substrings.  */
2920
2921 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
2922    to the position after last scanned or to NULL. */
2923
2924 #define INIT_AND_WITHP \
2925  assert(!and_withp); \
2926  Newx(and_withp,1,struct regnode_charclass_class); \
2927  SAVEFREEPV(and_withp)
2928
2929 /* this is a chain of data about sub patterns we are processing that
2930    need to be handled separately/specially in study_chunk. Its so
2931    we can simulate recursion without losing state.  */
2932 struct scan_frame;
2933 typedef struct scan_frame {
2934  regnode *last;  /* last node to process in this frame */
2935  regnode *next;  /* next node to process when last is reached */
2936  struct scan_frame *prev; /*previous frame*/
2937  I32 stop; /* what stopparen do we use */
2938 } scan_frame;
2939
2940
2941 #define SCAN_COMMIT(s, data, m) scan_commit(s, data, m, is_inf)
2942
2943 #define CASE_SYNST_FNC(nAmE)                                       \
2944 case nAmE:                                                         \
2945  if (flags & SCF_DO_STCLASS_AND) {                              \
2946    for (value = 0; value < 256; value++)                  \
2947     if (!is_ ## nAmE ## _cp(value))                       \
2948      ANYOF_BITMAP_CLEAR(data->start_class, value);  \
2949  }                                                              \
2950  else {                                                         \
2951    for (value = 0; value < 256; value++)                  \
2952     if (is_ ## nAmE ## _cp(value))                        \
2953      ANYOF_BITMAP_SET(data->start_class, value);    \
2954  }                                                              \
2955  break;                                                         \
2956 case N ## nAmE:                                                    \
2957  if (flags & SCF_DO_STCLASS_AND) {                              \
2958    for (value = 0; value < 256; value++)                   \
2959     if (is_ ## nAmE ## _cp(value))                         \
2960      ANYOF_BITMAP_CLEAR(data->start_class, value);   \
2961  }                                                               \
2962  else {                                                          \
2963    for (value = 0; value < 256; value++)                   \
2964     if (!is_ ## nAmE ## _cp(value))                        \
2965      ANYOF_BITMAP_SET(data->start_class, value);     \
2966  }                                                               \
2967  break
2968
2969
2970
2971 STATIC I32
2972 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
2973       I32 *minlenp, I32 *deltap,
2974       regnode *last,
2975       scan_data_t *data,
2976       I32 stopparen,
2977       U8* recursed,
2978       struct regnode_charclass_class *and_withp,
2979       U32 flags, U32 depth)
2980       /* scanp: Start here (read-write). */
2981       /* deltap: Write maxlen-minlen here. */
2982       /* last: Stop before this one. */
2983       /* data: string data about the pattern */
2984       /* stopparen: treat close N as END */
2985       /* recursed: which subroutines have we recursed into */
2986       /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
2987 {
2988  dVAR;
2989  I32 min = 0, pars = 0, code;
2990  regnode *scan = *scanp, *next;
2991  I32 delta = 0;
2992  int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
2993  int is_inf_internal = 0;  /* The studied chunk is infinite */
2994  I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
2995  scan_data_t data_fake;
2996  SV *re_trie_maxbuff = NULL;
2997  regnode *first_non_open = scan;
2998  I32 stopmin = I32_MAX;
2999  scan_frame *frame = NULL;
3000  GET_RE_DEBUG_FLAGS_DECL;
3001
3002  PERL_ARGS_ASSERT_STUDY_CHUNK;
3003
3004 #ifdef DEBUGGING
3005  StructCopy(&zero_scan_data, &data_fake, scan_data_t);
3006 #endif
3007
3008  if ( depth == 0 ) {
3009   while (first_non_open && OP(first_non_open) == OPEN)
3010    first_non_open=regnext(first_non_open);
3011  }
3012
3013
3014   fake_study_recurse:
3015  while ( scan && OP(scan) != END && scan < last ){
3016   UV min_subtract = 0;    /* How much to subtract from the minimum node
3017         length to get a real minimum (because the
3018         folded version may be shorter) */
3019   bool has_exactf_sharp_s = FALSE;
3020   /* Peephole optimizer: */
3021   DEBUG_STUDYDATA("Peep:", data,depth);
3022   DEBUG_PEEP("Peep",scan,depth);
3023
3024   /* Its not clear to khw or hv why this is done here, and not in the
3025   * clauses that deal with EXACT nodes.  khw's guess is that it's
3026   * because of a previous design */
3027   JOIN_EXACT(scan,&min_subtract, &has_exactf_sharp_s, 0);
3028
3029   /* Follow the next-chain of the current node and optimize
3030   away all the NOTHINGs from it.  */
3031   if (OP(scan) != CURLYX) {
3032    const int max = (reg_off_by_arg[OP(scan)]
3033      ? I32_MAX
3034      /* I32 may be smaller than U16 on CRAYs! */
3035      : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
3036    int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
3037    int noff;
3038    regnode *n = scan;
3039
3040    /* Skip NOTHING and LONGJMP. */
3041    while ((n = regnext(n))
3042     && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
3043      || ((OP(n) == LONGJMP) && (noff = ARG(n))))
3044     && off + noff < max)
3045     off += noff;
3046    if (reg_off_by_arg[OP(scan)])
3047     ARG(scan) = off;
3048    else
3049     NEXT_OFF(scan) = off;
3050   }
3051
3052
3053
3054   /* The principal pseudo-switch.  Cannot be a switch, since we
3055   look into several different things.  */
3056   if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
3057     || OP(scan) == IFTHEN) {
3058    next = regnext(scan);
3059    code = OP(scan);
3060    /* demq: the op(next)==code check is to see if we have "branch-branch" AFAICT */
3061
3062    if (OP(next) == code || code == IFTHEN) {
3063     /* NOTE - There is similar code to this block below for handling
3064     TRIE nodes on a re-study.  If you change stuff here check there
3065     too. */
3066     I32 max1 = 0, min1 = I32_MAX, num = 0;
3067     struct regnode_charclass_class accum;
3068     regnode * const startbranch=scan;
3069
3070     if (flags & SCF_DO_SUBSTR)
3071      SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot merge strings after this. */
3072     if (flags & SCF_DO_STCLASS)
3073      cl_init_zero(pRExC_state, &accum);
3074
3075     while (OP(scan) == code) {
3076      I32 deltanext, minnext, f = 0, fake;
3077      struct regnode_charclass_class this_class;
3078
3079      num++;
3080      data_fake.flags = 0;
3081      if (data) {
3082       data_fake.whilem_c = data->whilem_c;
3083       data_fake.last_closep = data->last_closep;
3084      }
3085      else
3086       data_fake.last_closep = &fake;
3087
3088      data_fake.pos_delta = delta;
3089      next = regnext(scan);
3090      scan = NEXTOPER(scan);
3091      if (code != BRANCH)
3092       scan = NEXTOPER(scan);
3093      if (flags & SCF_DO_STCLASS) {
3094       cl_init(pRExC_state, &this_class);
3095       data_fake.start_class = &this_class;
3096       f = SCF_DO_STCLASS_AND;
3097      }
3098      if (flags & SCF_WHILEM_VISITED_POS)
3099       f |= SCF_WHILEM_VISITED_POS;
3100
3101      /* we suppose the run is continuous, last=next...*/
3102      minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
3103           next, &data_fake,
3104           stopparen, recursed, NULL, f,depth+1);
3105      if (min1 > minnext)
3106       min1 = minnext;
3107      if (max1 < minnext + deltanext)
3108       max1 = minnext + deltanext;
3109      if (deltanext == I32_MAX)
3110       is_inf = is_inf_internal = 1;
3111      scan = next;
3112      if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3113       pars++;
3114      if (data_fake.flags & SCF_SEEN_ACCEPT) {
3115       if ( stopmin > minnext)
3116        stopmin = min + min1;
3117       flags &= ~SCF_DO_SUBSTR;
3118       if (data)
3119        data->flags |= SCF_SEEN_ACCEPT;
3120      }
3121      if (data) {
3122       if (data_fake.flags & SF_HAS_EVAL)
3123        data->flags |= SF_HAS_EVAL;
3124       data->whilem_c = data_fake.whilem_c;
3125      }
3126      if (flags & SCF_DO_STCLASS)
3127       cl_or(pRExC_state, &accum, &this_class);
3128     }
3129     if (code == IFTHEN && num < 2) /* Empty ELSE branch */
3130      min1 = 0;
3131     if (flags & SCF_DO_SUBSTR) {
3132      data->pos_min += min1;
3133      data->pos_delta += max1 - min1;
3134      if (max1 != min1 || is_inf)
3135       data->longest = &(data->longest_float);
3136     }
3137     min += min1;
3138     delta += max1 - min1;
3139     if (flags & SCF_DO_STCLASS_OR) {
3140      cl_or(pRExC_state, data->start_class, &accum);
3141      if (min1) {
3142       cl_and(data->start_class, and_withp);
3143       flags &= ~SCF_DO_STCLASS;
3144      }
3145     }
3146     else if (flags & SCF_DO_STCLASS_AND) {
3147      if (min1) {
3148       cl_and(data->start_class, &accum);
3149       flags &= ~SCF_DO_STCLASS;
3150      }
3151      else {
3152       /* Switch to OR mode: cache the old value of
3153       * data->start_class */
3154       INIT_AND_WITHP;
3155       StructCopy(data->start_class, and_withp,
3156         struct regnode_charclass_class);
3157       flags &= ~SCF_DO_STCLASS_AND;
3158       StructCopy(&accum, data->start_class,
3159         struct regnode_charclass_class);
3160       flags |= SCF_DO_STCLASS_OR;
3161       data->start_class->flags |= ANYOF_EOS;
3162      }
3163     }
3164
3165     if (PERL_ENABLE_TRIE_OPTIMISATION && OP( startbranch ) == BRANCH ) {
3166     /* demq.
3167
3168     Assuming this was/is a branch we are dealing with: 'scan' now
3169     points at the item that follows the branch sequence, whatever
3170     it is. We now start at the beginning of the sequence and look
3171     for subsequences of
3172
3173     BRANCH->EXACT=>x1
3174     BRANCH->EXACT=>x2
3175     tail
3176
3177     which would be constructed from a pattern like /A|LIST|OF|WORDS/
3178
3179     If we can find such a subsequence we need to turn the first
3180     element into a trie and then add the subsequent branch exact
3181     strings to the trie.
3182
3183     We have two cases
3184
3185      1. patterns where the whole set of branches can be converted.
3186
3187      2. patterns where only a subset can be converted.
3188
3189     In case 1 we can replace the whole set with a single regop
3190     for the trie. In case 2 we need to keep the start and end
3191     branches so
3192
3193      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
3194      becomes BRANCH TRIE; BRANCH X;
3195
3196     There is an additional case, that being where there is a
3197     common prefix, which gets split out into an EXACT like node
3198     preceding the TRIE node.
3199
3200     If x(1..n)==tail then we can do a simple trie, if not we make
3201     a "jump" trie, such that when we match the appropriate word
3202     we "jump" to the appropriate tail node. Essentially we turn
3203     a nested if into a case structure of sorts.
3204
3205     */
3206
3207      int made=0;
3208      if (!re_trie_maxbuff) {
3209       re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
3210       if (!SvIOK(re_trie_maxbuff))
3211        sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
3212      }
3213      if ( SvIV(re_trie_maxbuff)>=0  ) {
3214       regnode *cur;
3215       regnode *first = (regnode *)NULL;
3216       regnode *last = (regnode *)NULL;
3217       regnode *tail = scan;
3218       U8 trietype = 0;
3219       U32 count=0;
3220
3221 #ifdef DEBUGGING
3222       SV * const mysv = sv_newmortal();       /* for dumping */
3223 #endif
3224       /* var tail is used because there may be a TAIL
3225       regop in the way. Ie, the exacts will point to the
3226       thing following the TAIL, but the last branch will
3227       point at the TAIL. So we advance tail. If we
3228       have nested (?:) we may have to move through several
3229       tails.
3230       */
3231
3232       while ( OP( tail ) == TAIL ) {
3233        /* this is the TAIL generated by (?:) */
3234        tail = regnext( tail );
3235       }
3236
3237
3238       DEBUG_OPTIMISE_r({
3239        regprop(RExC_rx, mysv, tail );
3240        PerlIO_printf( Perl_debug_log, "%*s%s%s\n",
3241         (int)depth * 2 + 2, "",
3242         "Looking for TRIE'able sequences. Tail node is: ",
3243         SvPV_nolen_const( mysv )
3244        );
3245       });
3246
3247       /*
3248
3249        Step through the branches
3250         cur represents each branch,
3251         noper is the first thing to be matched as part of that branch
3252         noper_next is the regnext() of that node.
3253
3254        We normally handle a case like this /FOO[xyz]|BAR[pqr]/
3255        via a "jump trie" but we also support building with NOJUMPTRIE,
3256        which restricts the trie logic to structures like /FOO|BAR/.
3257
3258        If noper is a trieable nodetype then the branch is a possible optimization
3259        target. If we are building under NOJUMPTRIE then we require that noper_next
3260        is the same as scan (our current position in the regex program).
3261
3262        Once we have two or more consecutive such branches we can create a
3263        trie of the EXACT's contents and stitch it in place into the program.
3264
3265        If the sequence represents all of the branches in the alternation we
3266        replace the entire thing with a single TRIE node.
3267
3268        Otherwise when it is a subsequence we need to stitch it in place and
3269        replace only the relevant branches. This means the first branch has
3270        to remain as it is used by the alternation logic, and its next pointer,
3271        and needs to be repointed at the item on the branch chain following
3272        the last branch we have optimized away.
3273
3274        This could be either a BRANCH, in which case the subsequence is internal,
3275        or it could be the item following the branch sequence in which case the
3276        subsequence is at the end (which does not necessarily mean the first node
3277        is the start of the alternation).
3278
3279        TRIE_TYPE(X) is a define which maps the optype to a trietype.
3280
3281         optype          |  trietype
3282         ----------------+-----------
3283         NOTHING         | NOTHING
3284         EXACT           | EXACT
3285         EXACTFU         | EXACTFU
3286         EXACTFU_SS      | EXACTFU
3287         EXACTFU_TRICKYFOLD | EXACTFU
3288         EXACTFA         | 0
3289
3290
3291       */
3292 #define TRIE_TYPE(X) ( ( NOTHING == (X) ) ? NOTHING :   \
3293      ( EXACT == (X) )   ? EXACT :        \
3294      ( EXACTFU == (X) || EXACTFU_SS == (X) || EXACTFU_TRICKYFOLD == (X) ) ? EXACTFU :        \
3295      0 )
3296
3297       /* dont use tail as the end marker for this traverse */
3298       for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
3299        regnode * const noper = NEXTOPER( cur );
3300        U8 noper_type = OP( noper );
3301        U8 noper_trietype = TRIE_TYPE( noper_type );
3302 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
3303        regnode * const noper_next = regnext( noper );
3304 #endif
3305
3306        DEBUG_OPTIMISE_r({
3307         regprop(RExC_rx, mysv, cur);
3308         PerlIO_printf( Perl_debug_log, "%*s- %s (%d)",
3309         (int)depth * 2 + 2,"", SvPV_nolen_const( mysv ), REG_NODE_NUM(cur) );
3310
3311         regprop(RExC_rx, mysv, noper);
3312         PerlIO_printf( Perl_debug_log, " -> %s",
3313          SvPV_nolen_const(mysv));
3314
3315         if ( noper_next ) {
3316         regprop(RExC_rx, mysv, noper_next );
3317         PerlIO_printf( Perl_debug_log,"\t=> %s\t",
3318          SvPV_nolen_const(mysv));
3319         }
3320         PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d)\n",
3321         REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur) );
3322        });
3323
3324        /* Is noper a trieable nodetype that can be merged with the
3325        * current trie (if there is one)? */
3326        if ( noper_trietype
3327         &&
3328         (
3329           /* XXX: Currently we cannot allow a NOTHING node to be the first element
3330           * of a TRIEABLE sequence, Otherwise we will overwrite the regop following
3331           * the NOTHING with the TRIE regop later on. This is because a NOTHING node
3332           * is only one regnode wide, and a TRIE is two regnodes. An example of a
3333           * problematic pattern is: "x" =~ /\A(?>(?:(?:)A|B|C?x))\z/
3334           * At a later point of time we can somewhat workaround this by handling
3335           * NOTHING -> EXACT sequences as generated by /(?:)A|(?:)B/ type patterns,
3336           * as we can effectively ignore the NOTHING regop in that case.
3337           * This clause, which allows NOTHING to start a sequence is left commented
3338           * out as a reference.
3339           * - Yves
3340
3341           ( noper_trietype == NOTHING)
3342           || ( trietype == NOTHING )
3343           */
3344           ( noper_trietype == NOTHING && trietype )
3345           || ( trietype == noper_trietype )
3346         )
3347 #ifdef NOJUMPTRIE
3348         && noper_next == tail
3349 #endif
3350         && count < U16_MAX)
3351        {
3352         /* Handle mergable triable node
3353         * Either we are the first node in a new trieable sequence,
3354         * in which case we do some bookkeeping, otherwise we update
3355         * the end pointer. */
3356         count++;
3357         if ( !first ) {
3358          first = cur;
3359          trietype = noper_trietype;
3360         } else {
3361          if ( trietype == NOTHING )
3362           trietype = noper_trietype;
3363          last = cur;
3364         }
3365        } /* end handle mergable triable node */
3366        else {
3367         /* handle unmergable node -
3368         * noper may either be a triable node which can not be tried
3369         * together with the current trie, or a non triable node */
3370         if ( last ) {
3371          /* If last is set and trietype is not NOTHING then we have found
3372          * at least two triable branch sequences in a row of a similar
3373          * trietype so we can turn them into a trie. If/when we
3374          * allow NOTHING to start a trie sequence this condition will be
3375          * required, and it isn't expensive so we leave it in for now. */
3376          if ( trietype != NOTHING )
3377           make_trie( pRExC_state,
3378             startbranch, first, cur, tail, count,
3379             trietype, depth+1 );
3380          last = NULL; /* note: we clear/update first, trietype etc below, so we dont do it here */
3381         }
3382         if ( noper_trietype
3383 #ifdef NOJUMPTRIE
3384          && noper_next == tail
3385 #endif
3386         ){
3387          /* noper is triable, so we can start a new trie sequence */
3388          count = 1;
3389          first = cur;
3390          trietype = noper_trietype;
3391         } else if (first) {
3392          /* if we already saw a first but the current node is not triable then we have
3393          * to reset the first information. */
3394          count = 0;
3395          first = NULL;
3396          trietype = 0;
3397         }
3398        } /* end handle unmergable node */
3399       } /* loop over branches */
3400       DEBUG_OPTIMISE_r({
3401        regprop(RExC_rx, mysv, cur);
3402        PerlIO_printf( Perl_debug_log,
3403        "%*s- %s (%d) <SCAN FINISHED>\n", (int)depth * 2 + 2,
3404        "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
3405
3406       });
3407       if ( last && trietype != NOTHING ) {
3408        /* the last branch of the sequence was part of a trie,
3409        * so we have to construct it here outside of the loop
3410        */
3411        made= make_trie( pRExC_state, startbranch, first, scan, tail, count, trietype, depth+1 );
3412 #ifdef TRIE_STUDY_OPT
3413        if ( ((made == MADE_EXACT_TRIE &&
3414         startbranch == first)
3415         || ( first_non_open == first )) &&
3416         depth==0 ) {
3417         flags |= SCF_TRIE_RESTUDY;
3418         if ( startbranch == first
3419          && scan == tail )
3420         {
3421          RExC_seen &=~REG_TOP_LEVEL_BRANCHES;
3422         }
3423        }
3424 #endif
3425       } /* end if ( last) */
3426      } /* TRIE_MAXBUF is non zero */
3427
3428     } /* do trie */
3429
3430    }
3431    else if ( code == BRANCHJ ) {  /* single branch is optimized. */
3432     scan = NEXTOPER(NEXTOPER(scan));
3433    } else   /* single branch is optimized. */
3434     scan = NEXTOPER(scan);
3435    continue;
3436   } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB || OP(scan) == GOSTART) {
3437    scan_frame *newframe = NULL;
3438    I32 paren;
3439    regnode *start;
3440    regnode *end;
3441
3442    if (OP(scan) != SUSPEND) {
3443    /* set the pointer */
3444     if (OP(scan) == GOSUB) {
3445      paren = ARG(scan);
3446      RExC_recurse[ARG2L(scan)] = scan;
3447      start = RExC_open_parens[paren-1];
3448      end   = RExC_close_parens[paren-1];
3449     } else {
3450      paren = 0;
3451      start = RExC_rxi->program + 1;
3452      end   = RExC_opend;
3453     }
3454     if (!recursed) {
3455      Newxz(recursed, (((RExC_npar)>>3) +1), U8);
3456      SAVEFREEPV(recursed);
3457     }
3458     if (!PAREN_TEST(recursed,paren+1)) {
3459      PAREN_SET(recursed,paren+1);
3460      Newx(newframe,1,scan_frame);
3461     } else {
3462      if (flags & SCF_DO_SUBSTR) {
3463       SCAN_COMMIT(pRExC_state,data,minlenp);
3464       data->longest = &(data->longest_float);
3465      }
3466      is_inf = is_inf_internal = 1;
3467      if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3468       cl_anything(pRExC_state, data->start_class);
3469      flags &= ~SCF_DO_STCLASS;
3470     }
3471    } else {
3472     Newx(newframe,1,scan_frame);
3473     paren = stopparen;
3474     start = scan+2;
3475     end = regnext(scan);
3476    }
3477    if (newframe) {
3478     assert(start);
3479     assert(end);
3480     SAVEFREEPV(newframe);
3481     newframe->next = regnext(scan);
3482     newframe->last = last;
3483     newframe->stop = stopparen;
3484     newframe->prev = frame;
3485
3486     frame = newframe;
3487     scan =  start;
3488     stopparen = paren;
3489     last = end;
3490
3491     continue;
3492    }
3493   }
3494   else if (OP(scan) == EXACT) {
3495    I32 l = STR_LEN(scan);
3496    UV uc;
3497    if (UTF) {
3498     const U8 * const s = (U8*)STRING(scan);
3499     uc = utf8_to_uvchr_buf(s, s + l, NULL);
3500     l = utf8_length(s, s + l);
3501    } else {
3502     uc = *((U8*)STRING(scan));
3503    }
3504    min += l;
3505    if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
3506     /* The code below prefers earlier match for fixed
3507     offset, later match for variable offset.  */
3508     if (data->last_end == -1) { /* Update the start info. */
3509      data->last_start_min = data->pos_min;
3510      data->last_start_max = is_inf
3511       ? I32_MAX : data->pos_min + data->pos_delta;
3512     }
3513     sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
3514     if (UTF)
3515      SvUTF8_on(data->last_found);
3516     {
3517      SV * const sv = data->last_found;
3518      MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3519       mg_find(sv, PERL_MAGIC_utf8) : NULL;
3520      if (mg && mg->mg_len >= 0)
3521       mg->mg_len += utf8_length((U8*)STRING(scan),
3522             (U8*)STRING(scan)+STR_LEN(scan));
3523     }
3524     data->last_end = data->pos_min + l;
3525     data->pos_min += l; /* As in the first entry. */
3526     data->flags &= ~SF_BEFORE_EOL;
3527    }
3528    if (flags & SCF_DO_STCLASS_AND) {
3529     /* Check whether it is compatible with what we know already! */
3530     int compat = 1;
3531
3532
3533     /* If compatible, we or it in below.  It is compatible if is
3534     * in the bitmp and either 1) its bit or its fold is set, or 2)
3535     * it's for a locale.  Even if there isn't unicode semantics
3536     * here, at runtime there may be because of matching against a
3537     * utf8 string, so accept a possible false positive for
3538     * latin1-range folds */
3539     if (uc >= 0x100 ||
3540      (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3541      && !ANYOF_BITMAP_TEST(data->start_class, uc)
3542      && (!(data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD)
3543       || !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3544      )
3545     {
3546      compat = 0;
3547     }
3548     ANYOF_CLASS_ZERO(data->start_class);
3549     ANYOF_BITMAP_ZERO(data->start_class);
3550     if (compat)
3551      ANYOF_BITMAP_SET(data->start_class, uc);
3552     else if (uc >= 0x100) {
3553      int i;
3554
3555      /* Some Unicode code points fold to the Latin1 range; as
3556      * XXX temporary code, instead of figuring out if this is
3557      * one, just assume it is and set all the start class bits
3558      * that could be some such above 255 code point's fold
3559      * which will generate fals positives.  As the code
3560      * elsewhere that does compute the fold settles down, it
3561      * can be extracted out and re-used here */
3562      for (i = 0; i < 256; i++){
3563       if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
3564        ANYOF_BITMAP_SET(data->start_class, i);
3565       }
3566      }
3567     }
3568     data->start_class->flags &= ~ANYOF_EOS;
3569     if (uc < 0x100)
3570     data->start_class->flags &= ~ANYOF_UNICODE_ALL;
3571    }
3572    else if (flags & SCF_DO_STCLASS_OR) {
3573     /* false positive possible if the class is case-folded */
3574     if (uc < 0x100)
3575      ANYOF_BITMAP_SET(data->start_class, uc);
3576     else
3577      data->start_class->flags |= ANYOF_UNICODE_ALL;
3578     data->start_class->flags &= ~ANYOF_EOS;
3579     cl_and(data->start_class, and_withp);
3580    }
3581    flags &= ~SCF_DO_STCLASS;
3582   }
3583   else if (PL_regkind[OP(scan)] == EXACT) { /* But OP != EXACT! */
3584    I32 l = STR_LEN(scan);
3585    UV uc = *((U8*)STRING(scan));
3586
3587    /* Search for fixed substrings supports EXACT only. */
3588    if (flags & SCF_DO_SUBSTR) {
3589     assert(data);
3590     SCAN_COMMIT(pRExC_state, data, minlenp);
3591    }
3592    if (UTF) {
3593     const U8 * const s = (U8 *)STRING(scan);
3594     uc = utf8_to_uvchr_buf(s, s + l, NULL);
3595     l = utf8_length(s, s + l);
3596    }
3597    else if (has_exactf_sharp_s) {
3598     RExC_seen |= REG_SEEN_EXACTF_SHARP_S;
3599    }
3600    min += l - min_subtract;
3601    if (min < 0) {
3602     min = 0;
3603    }
3604    delta += min_subtract;
3605    if (flags & SCF_DO_SUBSTR) {
3606     data->pos_min += l - min_subtract;
3607     if (data->pos_min < 0) {
3608      data->pos_min = 0;
3609     }
3610     data->pos_delta += min_subtract;
3611     if (min_subtract) {
3612      data->longest = &(data->longest_float);
3613     }
3614    }
3615    if (flags & SCF_DO_STCLASS_AND) {
3616     /* Check whether it is compatible with what we know already! */
3617     int compat = 1;
3618     if (uc >= 0x100 ||
3619     (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3620     && !ANYOF_BITMAP_TEST(data->start_class, uc)
3621     && !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3622     {
3623      compat = 0;
3624     }
3625     ANYOF_CLASS_ZERO(data->start_class);
3626     ANYOF_BITMAP_ZERO(data->start_class);
3627     if (compat) {
3628      ANYOF_BITMAP_SET(data->start_class, uc);
3629      data->start_class->flags &= ~ANYOF_EOS;
3630      data->start_class->flags |= ANYOF_LOC_NONBITMAP_FOLD;
3631      if (OP(scan) == EXACTFL) {
3632       /* XXX This set is probably no longer necessary, and
3633       * probably wrong as LOCALE now is on in the initial
3634       * state */
3635       data->start_class->flags |= ANYOF_LOCALE;
3636      }
3637      else {
3638
3639       /* Also set the other member of the fold pair.  In case
3640       * that unicode semantics is called for at runtime, use
3641       * the full latin1 fold.  (Can't do this for locale,
3642       * because not known until runtime) */
3643       ANYOF_BITMAP_SET(data->start_class, PL_fold_latin1[uc]);
3644
3645       /* All other (EXACTFL handled above) folds except under
3646       * /iaa that include s, S, and sharp_s also may include
3647       * the others */
3648       if (OP(scan) != EXACTFA) {
3649        if (uc == 's' || uc == 'S') {
3650         ANYOF_BITMAP_SET(data->start_class,
3651             LATIN_SMALL_LETTER_SHARP_S);
3652        }
3653        else if (uc == LATIN_SMALL_LETTER_SHARP_S) {
3654         ANYOF_BITMAP_SET(data->start_class, 's');
3655         ANYOF_BITMAP_SET(data->start_class, 'S');
3656        }
3657       }
3658      }
3659     }
3660     else if (uc >= 0x100) {
3661      int i;
3662      for (i = 0; i < 256; i++){
3663       if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
3664        ANYOF_BITMAP_SET(data->start_class, i);
3665       }
3666      }
3667     }
3668    }
3669    else if (flags & SCF_DO_STCLASS_OR) {
3670     if (data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD) {
3671      /* false positive possible if the class is case-folded.
3672      Assume that the locale settings are the same... */
3673      if (uc < 0x100) {
3674       ANYOF_BITMAP_SET(data->start_class, uc);
3675       if (OP(scan) != EXACTFL) {
3676
3677        /* And set the other member of the fold pair, but
3678        * can't do that in locale because not known until
3679        * run-time */
3680        ANYOF_BITMAP_SET(data->start_class,
3681            PL_fold_latin1[uc]);
3682
3683        /* All folds except under /iaa that include s, S,
3684        * and sharp_s also may include the others */
3685        if (OP(scan) != EXACTFA) {
3686         if (uc == 's' || uc == 'S') {
3687          ANYOF_BITMAP_SET(data->start_class,
3688             LATIN_SMALL_LETTER_SHARP_S);
3689         }
3690         else if (uc == LATIN_SMALL_LETTER_SHARP_S) {
3691          ANYOF_BITMAP_SET(data->start_class, 's');
3692          ANYOF_BITMAP_SET(data->start_class, 'S');
3693         }
3694        }
3695       }
3696      }
3697      data->start_class->flags &= ~ANYOF_EOS;
3698     }
3699     cl_and(data->start_class, and_withp);
3700    }
3701    flags &= ~SCF_DO_STCLASS;
3702   }
3703   else if (REGNODE_VARIES(OP(scan))) {
3704    I32 mincount, maxcount, minnext, deltanext, fl = 0;
3705    I32 f = flags, pos_before = 0;
3706    regnode * const oscan = scan;
3707    struct regnode_charclass_class this_class;
3708    struct regnode_charclass_class *oclass = NULL;
3709    I32 next_is_eval = 0;
3710
3711    switch (PL_regkind[OP(scan)]) {
3712    case WHILEM:  /* End of (?:...)* . */
3713     scan = NEXTOPER(scan);
3714     goto finish;
3715    case PLUS:
3716     if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
3717      next = NEXTOPER(scan);
3718      if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
3719       mincount = 1;
3720       maxcount = REG_INFTY;
3721       next = regnext(scan);
3722       scan = NEXTOPER(scan);
3723       goto do_curly;
3724      }
3725     }
3726     if (flags & SCF_DO_SUBSTR)
3727      data->pos_min++;
3728     min++;
3729     /* Fall through. */
3730    case STAR:
3731     if (flags & SCF_DO_STCLASS) {
3732      mincount = 0;
3733      maxcount = REG_INFTY;
3734      next = regnext(scan);
3735      scan = NEXTOPER(scan);
3736      goto do_curly;
3737     }
3738     is_inf = is_inf_internal = 1;
3739     scan = regnext(scan);
3740     if (flags & SCF_DO_SUBSTR) {
3741      SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot extend fixed substrings */
3742      data->longest = &(data->longest_float);
3743     }
3744     goto optimize_curly_tail;
3745    case CURLY:
3746     if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
3747      && (scan->flags == stopparen))
3748     {
3749      mincount = 1;
3750      maxcount = 1;
3751     } else {
3752      mincount = ARG1(scan);
3753      maxcount = ARG2(scan);
3754     }
3755     next = regnext(scan);
3756     if (OP(scan) == CURLYX) {
3757      I32 lp = (data ? *(data->last_closep) : 0);
3758      scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
3759     }
3760     scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3761     next_is_eval = (OP(scan) == EVAL);
3762    do_curly:
3763     if (flags & SCF_DO_SUBSTR) {
3764      if (mincount == 0) SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot extend fixed substrings */
3765      pos_before = data->pos_min;
3766     }
3767     if (data) {
3768      fl = data->flags;
3769      data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
3770      if (is_inf)
3771       data->flags |= SF_IS_INF;
3772     }
3773     if (flags & SCF_DO_STCLASS) {
3774      cl_init(pRExC_state, &this_class);
3775      oclass = data->start_class;
3776      data->start_class = &this_class;
3777      f |= SCF_DO_STCLASS_AND;
3778      f &= ~SCF_DO_STCLASS_OR;
3779     }
3780     /* Exclude from super-linear cache processing any {n,m}
3781     regops for which the combination of input pos and regex
3782     pos is not enough information to determine if a match
3783     will be possible.
3784
3785     For example, in the regex /foo(bar\s*){4,8}baz/ with the
3786     regex pos at the \s*, the prospects for a match depend not
3787     only on the input position but also on how many (bar\s*)
3788     repeats into the {4,8} we are. */
3789    if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
3790      f &= ~SCF_WHILEM_VISITED_POS;
3791
3792     /* This will finish on WHILEM, setting scan, or on NULL: */
3793     minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
3794          last, data, stopparen, recursed, NULL,
3795          (mincount == 0
3796           ? (f & ~SCF_DO_SUBSTR) : f),depth+1);
3797
3798     if (flags & SCF_DO_STCLASS)
3799      data->start_class = oclass;
3800     if (mincount == 0 || minnext == 0) {
3801      if (flags & SCF_DO_STCLASS_OR) {
3802       cl_or(pRExC_state, data->start_class, &this_class);
3803      }
3804      else if (flags & SCF_DO_STCLASS_AND) {
3805       /* Switch to OR mode: cache the old value of
3806       * data->start_class */
3807       INIT_AND_WITHP;
3808       StructCopy(data->start_class, and_withp,
3809         struct regnode_charclass_class);
3810       flags &= ~SCF_DO_STCLASS_AND;
3811       StructCopy(&this_class, data->start_class,
3812         struct regnode_charclass_class);
3813       flags |= SCF_DO_STCLASS_OR;
3814       data->start_class->flags |= ANYOF_EOS;
3815      }
3816     } else {  /* Non-zero len */
3817      if (flags & SCF_DO_STCLASS_OR) {
3818       cl_or(pRExC_state, data->start_class, &this_class);
3819       cl_and(data->start_class, and_withp);
3820      }
3821      else if (flags & SCF_DO_STCLASS_AND)
3822       cl_and(data->start_class, &this_class);
3823      flags &= ~SCF_DO_STCLASS;
3824     }
3825     if (!scan)   /* It was not CURLYX, but CURLY. */
3826      scan = next;
3827     if ( /* ? quantifier ok, except for (?{ ... }) */
3828      (next_is_eval || !(mincount == 0 && maxcount == 1))
3829      && (minnext == 0) && (deltanext == 0)
3830      && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
3831      && maxcount <= REG_INFTY/3) /* Complement check for big count */
3832     {
3833      ckWARNreg(RExC_parse,
3834        "Quantifier unexpected on zero-length expression");
3835     }
3836
3837     min += minnext * mincount;
3838     is_inf_internal |= ((maxcount == REG_INFTY
3839          && (minnext + deltanext) > 0)
3840          || deltanext == I32_MAX);
3841     is_inf |= is_inf_internal;
3842     delta += (minnext + deltanext) * maxcount - minnext * mincount;
3843
3844     /* Try powerful optimization CURLYX => CURLYN. */
3845     if (  OP(oscan) == CURLYX && data
3846      && data->flags & SF_IN_PAR
3847      && !(data->flags & SF_HAS_EVAL)
3848      && !deltanext && minnext == 1 ) {
3849      /* Try to optimize to CURLYN.  */
3850      regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
3851      regnode * const nxt1 = nxt;
3852 #ifdef DEBUGGING
3853      regnode *nxt2;
3854 #endif
3855
3856      /* Skip open. */
3857      nxt = regnext(nxt);
3858      if (!REGNODE_SIMPLE(OP(nxt))
3859       && !(PL_regkind[OP(nxt)] == EXACT
3860        && STR_LEN(nxt) == 1))
3861       goto nogo;
3862 #ifdef DEBUGGING
3863      nxt2 = nxt;
3864 #endif
3865      nxt = regnext(nxt);
3866      if (OP(nxt) != CLOSE)
3867       goto nogo;
3868      if (RExC_open_parens) {
3869       RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3870       RExC_close_parens[ARG(nxt1)-1]=nxt+2; /*close->while*/
3871      }
3872      /* Now we know that nxt2 is the only contents: */
3873      oscan->flags = (U8)ARG(nxt);
3874      OP(oscan) = CURLYN;
3875      OP(nxt1) = NOTHING; /* was OPEN. */
3876
3877 #ifdef DEBUGGING
3878      OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3879      NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
3880      NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
3881      OP(nxt) = OPTIMIZED; /* was CLOSE. */
3882      OP(nxt + 1) = OPTIMIZED; /* was count. */
3883      NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
3884 #endif
3885     }
3886    nogo:
3887
3888     /* Try optimization CURLYX => CURLYM. */
3889     if (  OP(oscan) == CURLYX && data
3890      && !(data->flags & SF_HAS_PAR)
3891      && !(data->flags & SF_HAS_EVAL)
3892      && !deltanext /* atom is fixed width */
3893      && minnext != 0 /* CURLYM can't handle zero width */
3894     ) {
3895      /* XXXX How to optimize if data == 0? */
3896      /* Optimize to a simpler form.  */
3897      regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
3898      regnode *nxt2;
3899
3900      OP(oscan) = CURLYM;
3901      while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
3902        && (OP(nxt2) != WHILEM))
3903       nxt = nxt2;
3904      OP(nxt2)  = SUCCEED; /* Whas WHILEM */
3905      /* Need to optimize away parenths. */
3906      if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
3907       /* Set the parenth number.  */
3908       regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
3909
3910       oscan->flags = (U8)ARG(nxt);
3911       if (RExC_open_parens) {
3912        RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3913        RExC_close_parens[ARG(nxt1)-1]=nxt2+1; /*close->NOTHING*/
3914       }
3915       OP(nxt1) = OPTIMIZED; /* was OPEN. */
3916       OP(nxt) = OPTIMIZED; /* was CLOSE. */
3917
3918 #ifdef DEBUGGING
3919       OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3920       OP(nxt + 1) = OPTIMIZED; /* was count. */
3921       NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
3922       NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
3923 #endif
3924 #if 0
3925       while ( nxt1 && (OP(nxt1) != WHILEM)) {
3926        regnode *nnxt = regnext(nxt1);
3927        if (nnxt == nxt) {
3928         if (reg_off_by_arg[OP(nxt1)])
3929          ARG_SET(nxt1, nxt2 - nxt1);
3930         else if (nxt2 - nxt1 < U16_MAX)
3931          NEXT_OFF(nxt1) = nxt2 - nxt1;
3932         else
3933          OP(nxt) = NOTHING; /* Cannot beautify */
3934        }
3935        nxt1 = nnxt;
3936       }
3937 #endif
3938       /* Optimize again: */
3939       study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
3940          NULL, stopparen, recursed, NULL, 0,depth+1);
3941      }
3942      else
3943       oscan->flags = 0;
3944     }
3945     else if ((OP(oscan) == CURLYX)
3946       && (flags & SCF_WHILEM_VISITED_POS)
3947       /* See the comment on a similar expression above.
3948        However, this time it's not a subexpression
3949        we care about, but the expression itself. */
3950       && (maxcount == REG_INFTY)
3951       && data && ++data->whilem_c < 16) {
3952      /* This stays as CURLYX, we can put the count/of pair. */
3953      /* Find WHILEM (as in regexec.c) */
3954      regnode *nxt = oscan + NEXT_OFF(oscan);
3955
3956      if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
3957       nxt += ARG(nxt);
3958      PREVOPER(nxt)->flags = (U8)(data->whilem_c
3959       | (RExC_whilem_seen << 4)); /* On WHILEM */
3960     }
3961     if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
3962      pars++;
3963     if (flags & SCF_DO_SUBSTR) {
3964      SV *last_str = NULL;
3965      int counted = mincount != 0;
3966
3967      if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
3968 #if defined(SPARC64_GCC_WORKAROUND)
3969       I32 b = 0;
3970       STRLEN l = 0;
3971       const char *s = NULL;
3972       I32 old = 0;
3973
3974       if (pos_before >= data->last_start_min)
3975        b = pos_before;
3976       else
3977        b = data->last_start_min;
3978
3979       l = 0;
3980       s = SvPV_const(data->last_found, l);
3981       old = b - data->last_start_min;
3982
3983 #else
3984       I32 b = pos_before >= data->last_start_min
3985        ? pos_before : data->last_start_min;
3986       STRLEN l;
3987       const char * const s = SvPV_const(data->last_found, l);
3988       I32 old = b - data->last_start_min;
3989 #endif
3990
3991       if (UTF)
3992        old = utf8_hop((U8*)s, old) - (U8*)s;
3993       l -= old;
3994       /* Get the added string: */
3995       last_str = newSVpvn_utf8(s  + old, l, UTF);
3996       if (deltanext == 0 && pos_before == b) {
3997        /* What was added is a constant string */
3998        if (mincount > 1) {
3999         SvGROW(last_str, (mincount * l) + 1);
4000         repeatcpy(SvPVX(last_str) + l,
4001           SvPVX_const(last_str), l, mincount - 1);
4002         SvCUR_set(last_str, SvCUR(last_str) * mincount);
4003         /* Add additional parts. */
4004         SvCUR_set(data->last_found,
4005           SvCUR(data->last_found) - l);
4006         sv_catsv(data->last_found, last_str);
4007         {
4008          SV * sv = data->last_found;
4009          MAGIC *mg =
4010           SvUTF8(sv) && SvMAGICAL(sv) ?
4011           mg_find(sv, PERL_MAGIC_utf8) : NULL;
4012          if (mg && mg->mg_len >= 0)
4013           mg->mg_len += CHR_SVLEN(last_str) - l;
4014         }
4015         data->last_end += l * (mincount - 1);
4016        }
4017       } else {
4018        /* start offset must point into the last copy */
4019        data->last_start_min += minnext * (mincount - 1);
4020        data->last_start_max += is_inf ? I32_MAX
4021         : (maxcount - 1) * (minnext + data->pos_delta);
4022       }
4023      }
4024      /* It is counted once already... */
4025      data->pos_min += minnext * (mincount - counted);
4026      data->pos_delta += - counted * deltanext +
4027       (minnext + deltanext) * maxcount - minnext * mincount;
4028      if (mincount != maxcount) {
4029       /* Cannot extend fixed substrings found inside
4030        the group.  */
4031       SCAN_COMMIT(pRExC_state,data,minlenp);
4032       if (mincount && last_str) {
4033        SV * const sv = data->last_found;
4034        MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
4035         mg_find(sv, PERL_MAGIC_utf8) : NULL;
4036
4037        if (mg)
4038         mg->mg_len = -1;
4039        sv_setsv(sv, last_str);
4040        data->last_end = data->pos_min;
4041        data->last_start_min =
4042         data->pos_min - CHR_SVLEN(last_str);
4043        data->last_start_max = is_inf
4044         ? I32_MAX
4045         : data->pos_min + data->pos_delta
4046         - CHR_SVLEN(last_str);
4047       }
4048       data->longest = &(data->longest_float);
4049      }
4050      SvREFCNT_dec(last_str);
4051     }
4052     if (data && (fl & SF_HAS_EVAL))
4053      data->flags |= SF_HAS_EVAL;
4054    optimize_curly_tail:
4055     if (OP(oscan) != CURLYX) {
4056      while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
4057       && NEXT_OFF(next))
4058       NEXT_OFF(oscan) += NEXT_OFF(next);
4059     }
4060     continue;
4061    default:   /* REF, ANYOFV, and CLUMP only? */
4062     if (flags & SCF_DO_SUBSTR) {
4063      SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */
4064      data->longest = &(data->longest_float);
4065     }
4066     is_inf = is_inf_internal = 1;
4067     if (flags & SCF_DO_STCLASS_OR)
4068      cl_anything(pRExC_state, data->start_class);
4069     flags &= ~SCF_DO_STCLASS;
4070     break;
4071    }
4072   }
4073   else if (OP(scan) == LNBREAK) {
4074    if (flags & SCF_DO_STCLASS) {
4075     int value = 0;
4076     data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
4077      if (flags & SCF_DO_STCLASS_AND) {
4078      for (value = 0; value < 256; value++)
4079       if (!is_VERTWS_cp(value))
4080        ANYOF_BITMAP_CLEAR(data->start_class, value);
4081     }
4082     else {
4083      for (value = 0; value < 256; value++)
4084       if (is_VERTWS_cp(value))
4085        ANYOF_BITMAP_SET(data->start_class, value);
4086     }
4087     if (flags & SCF_DO_STCLASS_OR)
4088      cl_and(data->start_class, and_withp);
4089     flags &= ~SCF_DO_STCLASS;
4090    }
4091    min += 1;
4092    delta += 1;
4093    if (flags & SCF_DO_SUBSTR) {
4094      SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */
4095      data->pos_min += 1;
4096     data->pos_delta += 1;
4097     data->longest = &(data->longest_float);
4098     }
4099   }
4100   else if (REGNODE_SIMPLE(OP(scan))) {
4101    int value = 0;
4102
4103    if (flags & SCF_DO_SUBSTR) {
4104     SCAN_COMMIT(pRExC_state,data,minlenp);
4105     data->pos_min++;
4106    }
4107    min++;
4108    if (flags & SCF_DO_STCLASS) {
4109     data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
4110
4111     /* Some of the logic below assumes that switching
4112     locale on will only add false positives. */
4113     switch (PL_regkind[OP(scan)]) {
4114     case SANY:
4115     default:
4116     do_default:
4117      /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */
4118      if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4119       cl_anything(pRExC_state, data->start_class);
4120      break;
4121     case REG_ANY:
4122      if (OP(scan) == SANY)
4123       goto do_default;
4124      if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
4125       value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
4126         || ANYOF_CLASS_TEST_ANY_SET(data->start_class));
4127       cl_anything(pRExC_state, data->start_class);
4128      }
4129      if (flags & SCF_DO_STCLASS_AND || !value)
4130       ANYOF_BITMAP_CLEAR(data->start_class,'\n');
4131      break;
4132     case ANYOF:
4133      if (flags & SCF_DO_STCLASS_AND)
4134       cl_and(data->start_class,
4135        (struct regnode_charclass_class*)scan);
4136      else
4137       cl_or(pRExC_state, data->start_class,
4138        (struct regnode_charclass_class*)scan);
4139      break;
4140     case ALNUM:
4141      if (flags & SCF_DO_STCLASS_AND) {
4142       if (!(data->start_class->flags & ANYOF_LOCALE)) {
4143        ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
4144        if (OP(scan) == ALNUMU) {
4145         for (value = 0; value < 256; value++) {
4146          if (!isWORDCHAR_L1(value)) {
4147           ANYOF_BITMAP_CLEAR(data->start_class, value);
4148          }
4149         }
4150        } else {
4151         for (value = 0; value < 256; value++) {
4152          if (!isALNUM(value)) {
4153           ANYOF_BITMAP_CLEAR(data->start_class, value);
4154          }
4155         }
4156        }
4157       }
4158      }
4159      else {
4160       if (data->start_class->flags & ANYOF_LOCALE)
4161        ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
4162
4163       /* Even if under locale, set the bits for non-locale
4164       * in case it isn't a true locale-node.  This will
4165       * create false positives if it truly is locale */
4166       if (OP(scan) == ALNUMU) {
4167        for (value = 0; value < 256; value++) {
4168         if (isWORDCHAR_L1(value)) {
4169          ANYOF_BITMAP_SET(data->start_class, value);
4170         }
4171        }
4172       } else {
4173        for (value = 0; value < 256; value++) {
4174         if (isALNUM(value)) {
4175          ANYOF_BITMAP_SET(data->start_class, value);
4176         }
4177        }
4178       }
4179      }
4180      break;
4181     case NALNUM:
4182      if (flags & SCF_DO_STCLASS_AND) {
4183       if (!(data->start_class->flags & ANYOF_LOCALE)) {
4184        ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
4185        if (OP(scan) == NALNUMU) {
4186         for (value = 0; value < 256; value++) {
4187          if (isWORDCHAR_L1(value)) {
4188           ANYOF_BITMAP_CLEAR(data->start_class, value);
4189          }
4190         }
4191        } else {
4192         for (value = 0; value < 256; value++) {
4193          if (isALNUM(value)) {
4194           ANYOF_BITMAP_CLEAR(data->start_class, value);
4195          }
4196         }
4197        }
4198       }
4199      }
4200      else {
4201       if (data->start_class->flags & ANYOF_LOCALE)
4202        ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
4203
4204       /* Even if under locale, set the bits for non-locale in
4205       * case it isn't a true locale-node.  This will create
4206       * false positives if it truly is locale */
4207       if (OP(scan) == NALNUMU) {
4208        for (value = 0; value < 256; value++) {
4209         if (! isWORDCHAR_L1(value)) {
4210          ANYOF_BITMAP_SET(data->start_class, value);
4211         }
4212        }
4213       } else {
4214        for (value = 0; value < 256; value++) {
4215         if (! isALNUM(value)) {
4216          ANYOF_BITMAP_SET(data->start_class, value);
4217         }
4218        }
4219       }
4220      }
4221      break;
4222     case SPACE:
4223      if (flags & SCF_DO_STCLASS_AND) {
4224       if (!(data->start_class->flags & ANYOF_LOCALE)) {
4225        ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
4226        if (OP(scan) == SPACEU) {
4227         for (value = 0; value < 256; value++) {
4228          if (!isSPACE_L1(value)) {
4229           ANYOF_BITMAP_CLEAR(data->start_class, value);
4230          }
4231         }
4232        } else {
4233         for (value = 0; value < 256; value++) {
4234          if (!isSPACE(value)) {
4235           ANYOF_BITMAP_CLEAR(data->start_class, value);
4236          }
4237         }
4238        }
4239       }
4240      }
4241      else {
4242       if (data->start_class->flags & ANYOF_LOCALE) {
4243        ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
4244       }
4245       if (OP(scan) == SPACEU) {
4246        for (value = 0; value < 256; value++) {
4247         if (isSPACE_L1(value)) {
4248          ANYOF_BITMAP_SET(data->start_class, value);
4249         }
4250        }
4251       } else {
4252        for (value = 0; value < 256; value++) {
4253         if (isSPACE(value)) {
4254          ANYOF_BITMAP_SET(data->start_class, value);
4255         }
4256        }
4257       }
4258      }
4259      break;
4260     case NSPACE:
4261      if (flags & SCF_DO_STCLASS_AND) {
4262       if (!(data->start_class->flags & ANYOF_LOCALE)) {
4263        ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
4264        if (OP(scan) == NSPACEU) {
4265         for (value = 0; value < 256; value++) {
4266          if (isSPACE_L1(value)) {
4267           ANYOF_BITMAP_CLEAR(data->start_class, value);
4268          }
4269         }
4270        } else {
4271         for (value = 0; value < 256; value++) {
4272          if (isSPACE(value)) {
4273           ANYOF_BITMAP_CLEAR(data->start_class, value);
4274          }
4275         }
4276        }
4277       }
4278      }
4279      else {
4280       if (data->start_class->flags & ANYOF_LOCALE)
4281        ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
4282       if (OP(scan) == NSPACEU) {
4283        for (value = 0; value < 256; value++) {
4284         if (!isSPACE_L1(value)) {
4285          ANYOF_BITMAP_SET(data->start_class, value);
4286         }
4287        }
4288       }
4289       else {
4290        for (value = 0; value < 256; value++) {
4291         if (!isSPACE(value)) {
4292          ANYOF_BITMAP_SET(data->start_class, value);
4293         }
4294        }
4295       }
4296      }
4297      break;
4298     case DIGIT:
4299      if (flags & SCF_DO_STCLASS_AND) {
4300       if (!(data->start_class->flags & ANYOF_LOCALE)) {
4301        ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NDIGIT);
4302        for (value = 0; value < 256; value++)
4303         if (!isDIGIT(value))
4304          ANYOF_BITMAP_CLEAR(data->start_class, value);
4305       }
4306      }
4307      else {
4308       if (data->start_class->flags & ANYOF_LOCALE)
4309        ANYOF_CLASS_SET(data->start_class,ANYOF_DIGIT);
4310       for (value = 0; value < 256; value++)
4311        if (isDIGIT(value))
4312         ANYOF_BITMAP_SET(data->start_class, value);
4313      }
4314      break;
4315     case NDIGIT:
4316      if (flags & SCF_DO_STCLASS_AND) {
4317       if (!(data->start_class->flags & ANYOF_LOCALE))
4318        ANYOF_CLASS_CLEAR(data->start_class,ANYOF_DIGIT);
4319       for (value = 0; value < 256; value++)
4320        if (isDIGIT(value))
4321         ANYOF_BITMAP_CLEAR(data->start_class, value);
4322      }
4323      else {
4324       if (data->start_class->flags & ANYOF_LOCALE)
4325        ANYOF_CLASS_SET(data->start_class,ANYOF_NDIGIT);
4326       for (value = 0; value < 256; value++)
4327        if (!isDIGIT(value))
4328         ANYOF_BITMAP_SET(data->start_class, value);
4329      }
4330      break;
4331     CASE_SYNST_FNC(VERTWS);
4332     CASE_SYNST_FNC(HORIZWS);
4333
4334     }
4335     if (flags & SCF_DO_STCLASS_OR)
4336      cl_and(data->start_class, and_withp);
4337     flags &= ~SCF_DO_STCLASS;
4338    }
4339   }
4340   else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
4341    data->flags |= (OP(scan) == MEOL
4342        ? SF_BEFORE_MEOL
4343        : SF_BEFORE_SEOL);
4344   }
4345   else if (  PL_regkind[OP(scan)] == BRANCHJ
4346     /* Lookbehind, or need to calculate parens/evals/stclass: */
4347     && (scan->flags || data || (flags & SCF_DO_STCLASS))
4348     && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
4349    if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY
4350     || OP(scan) == UNLESSM )
4351    {
4352     /* Negative Lookahead/lookbehind
4353     In this case we can't do fixed string optimisation.
4354     */
4355
4356     I32 deltanext, minnext, fake = 0;
4357     regnode *nscan;
4358     struct regnode_charclass_class intrnl;
4359     int f = 0;
4360
4361     data_fake.flags = 0;
4362     if (data) {
4363      data_fake.whilem_c = data->whilem_c;
4364      data_fake.last_closep = data->last_closep;
4365     }
4366     else
4367      data_fake.last_closep = &fake;
4368     data_fake.pos_delta = delta;
4369     if ( flags & SCF_DO_STCLASS && !scan->flags
4370      && OP(scan) == IFMATCH ) { /* Lookahead */
4371      cl_init(pRExC_state, &intrnl);
4372      data_fake.start_class = &intrnl;
4373      f |= SCF_DO_STCLASS_AND;
4374     }
4375     if (flags & SCF_WHILEM_VISITED_POS)
4376      f |= SCF_WHILEM_VISITED_POS;
4377     next = regnext(scan);
4378     nscan = NEXTOPER(NEXTOPER(scan));
4379     minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext,
4380      last, &data_fake, stopparen, recursed, NULL, f, depth+1);
4381     if (scan->flags) {
4382      if (deltanext) {
4383       FAIL("Variable length lookbehind not implemented");
4384      }
4385      else if (minnext > (I32)U8_MAX) {
4386       FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4387      }
4388      scan->flags = (U8)minnext;
4389     }
4390     if (data) {
4391      if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4392       pars++;
4393      if (data_fake.flags & SF_HAS_EVAL)
4394       data->flags |= SF_HAS_EVAL;
4395      data->whilem_c = data_fake.whilem_c;
4396     }
4397     if (f & SCF_DO_STCLASS_AND) {
4398      if (flags & SCF_DO_STCLASS_OR) {
4399       /* OR before, AND after: ideally we would recurse with
4400       * data_fake to get the AND applied by study of the
4401       * remainder of the pattern, and then derecurse;
4402       * *** HACK *** for now just treat as "no information".
4403       * See [perl #56690].
4404       */
4405       cl_init(pRExC_state, data->start_class);
4406      }  else {
4407       /* AND before and after: combine and continue */
4408       const int was = (data->start_class->flags & ANYOF_EOS);
4409
4410       cl_and(data->start_class, &intrnl);
4411       if (was)
4412        data->start_class->flags |= ANYOF_EOS;
4413      }
4414     }
4415    }
4416 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
4417    else {
4418     /* Positive Lookahead/lookbehind
4419     In this case we can do fixed string optimisation,
4420     but we must be careful about it. Note in the case of
4421     lookbehind the positions will be offset by the minimum
4422     length of the pattern, something we won't know about
4423     until after the recurse.
4424     */
4425     I32 deltanext, fake = 0;
4426     regnode *nscan;
4427     struct regnode_charclass_class intrnl;
4428     int f = 0;
4429     /* We use SAVEFREEPV so that when the full compile
4430      is finished perl will clean up the allocated
4431      minlens when it's all done. This way we don't
4432      have to worry about freeing them when we know
4433      they wont be used, which would be a pain.
4434     */
4435     I32 *minnextp;
4436     Newx( minnextp, 1, I32 );
4437     SAVEFREEPV(minnextp);
4438
4439     if (data) {
4440      StructCopy(data, &data_fake, scan_data_t);
4441      if ((flags & SCF_DO_SUBSTR) && data->last_found) {
4442       f |= SCF_DO_SUBSTR;
4443       if (scan->flags)
4444        SCAN_COMMIT(pRExC_state, &data_fake,minlenp);
4445       data_fake.last_found=newSVsv(data->last_found);
4446      }
4447     }
4448     else
4449      data_fake.last_closep = &fake;
4450     data_fake.flags = 0;
4451     data_fake.pos_delta = delta;
4452     if (is_inf)
4453      data_fake.flags |= SF_IS_INF;
4454     if ( flags & SCF_DO_STCLASS && !scan->flags
4455      && OP(scan) == IFMATCH ) { /* Lookahead */
4456      cl_init(pRExC_state, &intrnl);
4457      data_fake.start_class = &intrnl;
4458      f |= SCF_DO_STCLASS_AND;
4459     }
4460     if (flags & SCF_WHILEM_VISITED_POS)
4461      f |= SCF_WHILEM_VISITED_POS;
4462     next = regnext(scan);
4463     nscan = NEXTOPER(NEXTOPER(scan));
4464
4465     *minnextp = study_chunk(pRExC_state, &nscan, minnextp, &deltanext,
4466      last, &data_fake, stopparen, recursed, NULL, f,depth+1);
4467     if (scan->flags) {
4468      if (deltanext) {
4469       FAIL("Variable length lookbehind not implemented");
4470      }
4471      else if (*minnextp > (I32)U8_MAX) {
4472       FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4473      }
4474      scan->flags = (U8)*minnextp;
4475     }
4476
4477     *minnextp += min;
4478
4479     if (f & SCF_DO_STCLASS_AND) {
4480      const int was = (data->start_class->flags & ANYOF_EOS);
4481
4482      cl_and(data->start_class, &intrnl);
4483      if (was)
4484       data->start_class->flags |= ANYOF_EOS;
4485     }
4486     if (data) {
4487      if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4488       pars++;
4489      if (data_fake.flags & SF_HAS_EVAL)
4490       data->flags |= SF_HAS_EVAL;
4491      data->whilem_c = data_fake.whilem_c;
4492      if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
4493       if (RExC_rx->minlen<*minnextp)
4494        RExC_rx->minlen=*minnextp;
4495       SCAN_COMMIT(pRExC_state, &data_fake, minnextp);
4496       SvREFCNT_dec(data_fake.last_found);
4497
4498       if ( data_fake.minlen_fixed != minlenp )
4499       {
4500        data->offset_fixed= data_fake.offset_fixed;
4501        data->minlen_fixed= data_fake.minlen_fixed;
4502        data->lookbehind_fixed+= scan->flags;
4503       }
4504       if ( data_fake.minlen_float != minlenp )
4505       {
4506        data->minlen_float= data_fake.minlen_float;
4507        data->offset_float_min=data_fake.offset_float_min;
4508        data->offset_float_max=data_fake.offset_float_max;
4509        data->lookbehind_float+= scan->flags;
4510       }
4511      }
4512     }
4513
4514
4515    }
4516 #endif
4517   }
4518   else if (OP(scan) == OPEN) {
4519    if (stopparen != (I32)ARG(scan))
4520     pars++;
4521   }
4522   else if (OP(scan) == CLOSE) {
4523    if (stopparen == (I32)ARG(scan)) {
4524     break;
4525    }
4526    if ((I32)ARG(scan) == is_par) {
4527     next = regnext(scan);
4528
4529     if ( next && (OP(next) != WHILEM) && next < last)
4530      is_par = 0;  /* Disable optimization */
4531    }
4532    if (data)
4533     *(data->last_closep) = ARG(scan);
4534   }
4535   else if (OP(scan) == EVAL) {
4536     if (data)
4537      data->flags |= SF_HAS_EVAL;
4538   }
4539   else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
4540    if (flags & SCF_DO_SUBSTR) {
4541     SCAN_COMMIT(pRExC_state,data,minlenp);
4542     flags &= ~SCF_DO_SUBSTR;
4543    }
4544    if (data && OP(scan)==ACCEPT) {
4545     data->flags |= SCF_SEEN_ACCEPT;
4546     if (stopmin > min)
4547      stopmin = min;
4548    }
4549   }
4550   else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
4551   {
4552     if (flags & SCF_DO_SUBSTR) {
4553      SCAN_COMMIT(pRExC_state,data,minlenp);
4554      data->longest = &(data->longest_float);
4555     }
4556     is_inf = is_inf_internal = 1;
4557     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4558      cl_anything(pRExC_state, data->start_class);
4559     flags &= ~SCF_DO_STCLASS;
4560   }
4561   else if (OP(scan) == GPOS) {
4562    if (!(RExC_rx->extflags & RXf_GPOS_FLOAT) &&
4563     !(delta || is_inf || (data && data->pos_delta)))
4564    {
4565     if (!(RExC_rx->extflags & RXf_ANCH) && (flags & SCF_DO_SUBSTR))
4566      RExC_rx->extflags |= RXf_ANCH_GPOS;
4567     if (RExC_rx->gofs < (U32)min)
4568      RExC_rx->gofs = min;
4569    } else {
4570     RExC_rx->extflags |= RXf_GPOS_FLOAT;
4571     RExC_rx->gofs = 0;
4572    }
4573   }
4574 #ifdef TRIE_STUDY_OPT
4575 #ifdef FULL_TRIE_STUDY
4576   else if (PL_regkind[OP(scan)] == TRIE) {
4577    /* NOTE - There is similar code to this block above for handling
4578    BRANCH nodes on the initial study.  If you change stuff here
4579    check there too. */
4580    regnode *trie_node= scan;
4581    regnode *tail= regnext(scan);
4582    reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4583    I32 max1 = 0, min1 = I32_MAX;
4584    struct regnode_charclass_class accum;
4585
4586    if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
4587     SCAN_COMMIT(pRExC_state, data,minlenp); /* Cannot merge strings after this. */
4588    if (flags & SCF_DO_STCLASS)
4589     cl_init_zero(pRExC_state, &accum);
4590
4591    if (!trie->jump) {
4592     min1= trie->minlen;
4593     max1= trie->maxlen;
4594    } else {
4595     const regnode *nextbranch= NULL;
4596     U32 word;
4597
4598     for ( word=1 ; word <= trie->wordcount ; word++)
4599     {
4600      I32 deltanext=0, minnext=0, f = 0, fake;
4601      struct regnode_charclass_class this_class;
4602
4603      data_fake.flags = 0;
4604      if (data) {
4605       data_fake.whilem_c = data->whilem_c;
4606       data_fake.last_closep = data->last_closep;
4607      }
4608      else
4609       data_fake.last_closep = &fake;
4610      data_fake.pos_delta = delta;
4611      if (flags & SCF_DO_STCLASS) {
4612       cl_init(pRExC_state, &this_class);
4613       data_fake.start_class = &this_class;
4614       f = SCF_DO_STCLASS_AND;
4615      }
4616      if (flags & SCF_WHILEM_VISITED_POS)
4617       f |= SCF_WHILEM_VISITED_POS;
4618
4619      if (trie->jump[word]) {
4620       if (!nextbranch)
4621        nextbranch = trie_node + trie->jump[0];
4622       scan= trie_node + trie->jump[word];
4623       /* We go from the jump point to the branch that follows
4624       it. Note this means we need the vestigal unused branches
4625       even though they arent otherwise used.
4626       */
4627       minnext = study_chunk(pRExC_state, &scan, minlenp,
4628        &deltanext, (regnode *)nextbranch, &data_fake,
4629        stopparen, recursed, NULL, f,depth+1);
4630      }
4631      if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
4632       nextbranch= regnext((regnode*)nextbranch);
4633
4634      if (min1 > (I32)(minnext + trie->minlen))
4635       min1 = minnext + trie->minlen;
4636      if (max1 < (I32)(minnext + deltanext + trie->maxlen))
4637       max1 = minnext + deltanext + trie->maxlen;
4638      if (deltanext == I32_MAX)
4639       is_inf = is_inf_internal = 1;
4640
4641      if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4642       pars++;
4643      if (data_fake.flags & SCF_SEEN_ACCEPT) {
4644       if ( stopmin > min + min1)
4645        stopmin = min + min1;
4646       flags &= ~SCF_DO_SUBSTR;
4647       if (data)
4648        data->flags |= SCF_SEEN_ACCEPT;
4649      }
4650      if (data) {
4651       if (data_fake.flags & SF_HAS_EVAL)
4652        data->flags |= SF_HAS_EVAL;
4653       data->whilem_c = data_fake.whilem_c;
4654      }
4655      if (flags & SCF_DO_STCLASS)
4656       cl_or(pRExC_state, &accum, &this_class);
4657     }
4658    }
4659    if (flags & SCF_DO_SUBSTR) {
4660     data->pos_min += min1;
4661     data->pos_delta += max1 - min1;
4662     if (max1 != min1 || is_inf)
4663      data->longest = &(data->longest_float);
4664    }
4665    min += min1;
4666    delta += max1 - min1;
4667    if (flags & SCF_DO_STCLASS_OR) {
4668     cl_or(pRExC_state, data->start_class, &accum);
4669     if (min1) {
4670      cl_and(data->start_class, and_withp);
4671      flags &= ~SCF_DO_STCLASS;
4672     }
4673    }
4674    else if (flags & SCF_DO_STCLASS_AND) {
4675     if (min1) {
4676      cl_and(data->start_class, &accum);
4677      flags &= ~SCF_DO_STCLASS;
4678     }
4679     else {
4680      /* Switch to OR mode: cache the old value of
4681      * data->start_class */
4682      INIT_AND_WITHP;
4683      StructCopy(data->start_class, and_withp,
4684        struct regnode_charclass_class);
4685      flags &= ~SCF_DO_STCLASS_AND;
4686      StructCopy(&accum, data->start_class,
4687        struct regnode_charclass_class);
4688      flags |= SCF_DO_STCLASS_OR;
4689      data->start_class->flags |= ANYOF_EOS;
4690     }
4691    }
4692    scan= tail;
4693    continue;
4694   }
4695 #else
4696   else if (PL_regkind[OP(scan)] == TRIE) {
4697    reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4698    U8*bang=NULL;
4699
4700    min += trie->minlen;
4701    delta += (trie->maxlen - trie->minlen);
4702    flags &= ~SCF_DO_STCLASS; /* xxx */
4703    if (flags & SCF_DO_SUBSTR) {
4704      SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */
4705      data->pos_min += trie->minlen;
4706      data->pos_delta += (trie->maxlen - trie->minlen);
4707     if (trie->maxlen != trie->minlen)
4708      data->longest = &(data->longest_float);
4709     }
4710     if (trie->jump) /* no more substrings -- for now /grr*/
4711      flags &= ~SCF_DO_SUBSTR;
4712   }
4713 #endif /* old or new */
4714 #endif /* TRIE_STUDY_OPT */
4715
4716   /* Else: zero-length, ignore. */
4717   scan = regnext(scan);
4718  }
4719  if (frame) {
4720   last = frame->last;
4721   scan = frame->next;
4722   stopparen = frame->stop;
4723   frame = frame->prev;
4724   goto fake_study_recurse;
4725  }
4726
4727   finish:
4728  assert(!frame);
4729  DEBUG_STUDYDATA("pre-fin:",data,depth);
4730
4731  *scanp = scan;
4732  *deltap = is_inf_internal ? I32_MAX : delta;
4733  if (flags & SCF_DO_SUBSTR && is_inf)
4734   data->pos_delta = I32_MAX - data->pos_min;
4735  if (is_par > (I32)U8_MAX)
4736   is_par = 0;
4737  if (is_par && pars==1 && data) {
4738   data->flags |= SF_IN_PAR;
4739   data->flags &= ~SF_HAS_PAR;
4740  }
4741  else if (pars && data) {
4742   data->flags |= SF_HAS_PAR;
4743   data->flags &= ~SF_IN_PAR;
4744  }
4745  if (flags & SCF_DO_STCLASS_OR)
4746   cl_and(data->start_class, and_withp);
4747  if (flags & SCF_TRIE_RESTUDY)
4748   data->flags |=  SCF_TRIE_RESTUDY;
4749
4750  DEBUG_STUDYDATA("post-fin:",data,depth);
4751
4752  return min < stopmin ? min : stopmin;
4753 }
4754
4755 STATIC U32
4756 S_add_data(RExC_state_t *pRExC_state, U32 n, const char *s)
4757 {
4758  U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
4759
4760  PERL_ARGS_ASSERT_ADD_DATA;
4761
4762  Renewc(RExC_rxi->data,
4763   sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
4764   char, struct reg_data);
4765  if(count)
4766   Renew(RExC_rxi->data->what, count + n, U8);
4767  else
4768   Newx(RExC_rxi->data->what, n, U8);
4769  RExC_rxi->data->count = count + n;
4770  Copy(s, RExC_rxi->data->what + count, n, U8);
4771  return count;
4772 }
4773
4774 /*XXX: todo make this not included in a non debugging perl */
4775 #ifndef PERL_IN_XSUB_RE
4776 void
4777 Perl_reginitcolors(pTHX)
4778 {
4779  dVAR;
4780  const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
4781  if (s) {
4782   char *t = savepv(s);
4783   int i = 0;
4784   PL_colors[0] = t;
4785   while (++i < 6) {
4786    t = strchr(t, '\t');
4787    if (t) {
4788     *t = '\0';
4789     PL_colors[i] = ++t;
4790    }
4791    else
4792     PL_colors[i] = t = (char *)"";
4793   }
4794  } else {
4795   int i = 0;
4796   while (i < 6)
4797    PL_colors[i++] = (char *)"";
4798  }
4799  PL_colorset = 1;
4800 }
4801 #endif
4802
4803
4804 #ifdef TRIE_STUDY_OPT
4805 #define CHECK_RESTUDY_GOTO                                  \
4806   if (                                                \
4807    (data.flags & SCF_TRIE_RESTUDY)               \
4808    && ! restudied++                              \
4809   )     goto reStudy
4810 #else
4811 #define CHECK_RESTUDY_GOTO
4812 #endif
4813
4814 /*
4815  - pregcomp - compile a regular expression into internal code
4816  *
4817  * We can't allocate space until we know how big the compiled form will be,
4818  * but we can't compile it (and thus know how big it is) until we've got a
4819  * place to put the code.  So we cheat:  we compile it twice, once with code
4820  * generation turned off and size counting turned on, and once "for real".
4821  * This also means that we don't allocate space until we are sure that the
4822  * thing really will compile successfully, and we never have to move the
4823  * code and thus invalidate pointers into it.  (Note that it has to be in
4824  * one piece because free() must be able to free it all.) [NB: not true in perl]
4825  *
4826  * Beware that the optimization-preparation code in here knows about some
4827  * of the structure of the compiled regexp.  [I'll say.]
4828  */
4829
4830
4831
4832 #ifndef PERL_IN_XSUB_RE
4833 #define RE_ENGINE_PTR &reh_regexp_engine
4834 #else
4835 extern const struct regexp_engine my_reg_engine;
4836 #define RE_ENGINE_PTR &my_reg_engine
4837 #endif
4838
4839 #ifndef PERL_IN_XSUB_RE
4840 REGEXP *
4841 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
4842 {
4843  dVAR;
4844  HV * const table = GvHV(PL_hintgv);
4845
4846  PERL_ARGS_ASSERT_PREGCOMP;
4847
4848  /* Dispatch a request to compile a regexp to correct
4849  regexp engine. */
4850  if (table) {
4851   SV **ptr= hv_fetchs(table, "regcomp", FALSE);
4852   GET_RE_DEBUG_FLAGS_DECL;
4853   if (ptr && SvIOK(*ptr) && SvIV(*ptr)) {
4854    const regexp_engine *eng=INT2PTR(regexp_engine*,SvIV(*ptr));
4855    DEBUG_COMPILE_r({
4856     PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
4857      SvIV(*ptr));
4858    });
4859    return CALLREGCOMP_ENG(eng, pattern, flags);
4860   }
4861  }
4862  return Perl_re_compile(aTHX_ pattern, flags);
4863 }
4864 #endif
4865
4866 REGEXP *
4867 Perl_re_compile(pTHX_ SV * const pattern, U32 orig_pm_flags)
4868 {
4869  dVAR;
4870  REGEXP *rx;
4871  struct regexp *r;
4872  register regexp_internal *ri;
4873  STRLEN plen;
4874  char* VOL exp;
4875  char* xend;
4876  regnode *scan;
4877  I32 flags;
4878  I32 minlen = 0;
4879  U32 pm_flags;
4880
4881  /* these are all flags - maybe they should be turned
4882  * into a single int with different bit masks */
4883  I32 sawlookahead = 0;
4884  I32 sawplus = 0;
4885  I32 sawopen = 0;
4886  bool used_setjump = FALSE;
4887  regex_charset initial_charset = get_regex_charset(orig_pm_flags);
4888
4889  U8 jump_ret = 0;
4890  dJMPENV;
4891  scan_data_t data;
4892  RExC_state_t RExC_state;
4893  RExC_state_t * const pRExC_state = &RExC_state;
4894 #ifdef TRIE_STUDY_OPT
4895  int restudied;
4896  RExC_state_t copyRExC_state;
4897 #endif
4898  GET_RE_DEBUG_FLAGS_DECL;
4899
4900  PERL_ARGS_ASSERT_RE_COMPILE;
4901
4902  DEBUG_r(if (!PL_colorset) reginitcolors());
4903
4904 #ifndef PERL_IN_XSUB_RE
4905  /* Initialize these here instead of as-needed, as is quick and avoids
4906  * having to test them each time otherwise */
4907  if (! PL_AboveLatin1) {
4908   PL_AboveLatin1 = _new_invlist_C_array(AboveLatin1_invlist);
4909   PL_ASCII = _new_invlist_C_array(ASCII_invlist);
4910   PL_Latin1 = _new_invlist_C_array(Latin1_invlist);
4911
4912   PL_L1PosixAlnum = _new_invlist_C_array(L1PosixAlnum_invlist);
4913   PL_PosixAlnum = _new_invlist_C_array(PosixAlnum_invlist);
4914
4915   PL_L1PosixAlpha = _new_invlist_C_array(L1PosixAlpha_invlist);
4916   PL_PosixAlpha = _new_invlist_C_array(PosixAlpha_invlist);
4917
4918   PL_PosixBlank = _new_invlist_C_array(PosixBlank_invlist);
4919   PL_XPosixBlank = _new_invlist_C_array(XPosixBlank_invlist);
4920
4921   PL_L1Cased = _new_invlist_C_array(L1Cased_invlist);
4922
4923   PL_PosixCntrl = _new_invlist_C_array(PosixCntrl_invlist);
4924   PL_XPosixCntrl = _new_invlist_C_array(XPosixCntrl_invlist);
4925
4926   PL_PosixDigit = _new_invlist_C_array(PosixDigit_invlist);
4927
4928   PL_L1PosixGraph = _new_invlist_C_array(L1PosixGraph_invlist);
4929   PL_PosixGraph = _new_invlist_C_array(PosixGraph_invlist);
4930
4931   PL_L1PosixAlnum = _new_invlist_C_array(L1PosixAlnum_invlist);
4932   PL_PosixAlnum = _new_invlist_C_array(PosixAlnum_invlist);
4933
4934   PL_L1PosixLower = _new_invlist_C_array(L1PosixLower_invlist);
4935   PL_PosixLower = _new_invlist_C_array(PosixLower_invlist);
4936
4937   PL_L1PosixPrint = _new_invlist_C_array(L1PosixPrint_invlist);
4938   PL_PosixPrint = _new_invlist_C_array(PosixPrint_invlist);
4939
4940   PL_L1PosixPunct = _new_invlist_C_array(L1PosixPunct_invlist);
4941   PL_PosixPunct = _new_invlist_C_array(PosixPunct_invlist);
4942
4943   PL_PerlSpace = _new_invlist_C_array(PerlSpace_invlist);
4944   PL_XPerlSpace = _new_invlist_C_array(XPerlSpace_invlist);
4945
4946   PL_PosixSpace = _new_invlist_C_array(PosixSpace_invlist);
4947   PL_XPosixSpace = _new_invlist_C_array(XPosixSpace_invlist);
4948
4949   PL_L1PosixUpper = _new_invlist_C_array(L1PosixUpper_invlist);
4950   PL_PosixUpper = _new_invlist_C_array(PosixUpper_invlist);
4951
4952   PL_VertSpace = _new_invlist_C_array(VertSpace_invlist);
4953
4954   PL_PosixWord = _new_invlist_C_array(PosixWord_invlist);
4955   PL_L1PosixWord = _new_invlist_C_array(L1PosixWord_invlist);
4956
4957   PL_PosixXDigit = _new_invlist_C_array(PosixXDigit_invlist);
4958   PL_XPosixXDigit = _new_invlist_C_array(XPosixXDigit_invlist);
4959  }
4960 #endif
4961
4962  exp = SvPV(pattern, plen);
4963
4964  if (plen == 0) { /* ignore the utf8ness if the pattern is 0 length */
4965   RExC_utf8 = RExC_orig_utf8 = 0;
4966  }
4967  else {
4968   RExC_utf8 = RExC_orig_utf8 = SvUTF8(pattern);
4969  }
4970  RExC_uni_semantics = 0;
4971  RExC_contains_locale = 0;
4972
4973  /****************** LONG JUMP TARGET HERE***********************/
4974  /* Longjmp back to here if have to switch in midstream to utf8 */
4975  if (! RExC_orig_utf8) {
4976   JMPENV_PUSH(jump_ret);
4977   used_setjump = TRUE;
4978  }
4979
4980  if (jump_ret == 0) {    /* First time through */
4981   xend = exp + plen;
4982
4983   DEBUG_COMPILE_r({
4984    SV *dsv= sv_newmortal();
4985    RE_PV_QUOTED_DECL(s, RExC_utf8,
4986     dsv, exp, plen, 60);
4987    PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
4988       PL_colors[4],PL_colors[5],s);
4989   });
4990  }
4991  else {  /* longjumped back */
4992   STRLEN len = plen;
4993
4994   /* If the cause for the longjmp was other than changing to utf8, pop
4995   * our own setjmp, and longjmp to the correct handler */
4996   if (jump_ret != UTF8_LONGJMP) {
4997    JMPENV_POP;
4998    JMPENV_JUMP(jump_ret);
4999   }
5000
5001   GET_RE_DEBUG_FLAGS;
5002
5003   /* It's possible to write a regexp in ascii that represents Unicode
5004   codepoints outside of the byte range, such as via \x{100}. If we
5005   detect such a sequence we have to convert the entire pattern to utf8
5006   and then recompile, as our sizing calculation will have been based
5007   on 1 byte == 1 character, but we will need to use utf8 to encode
5008   at least some part of the pattern, and therefore must convert the whole
5009   thing.
5010   -- dmq */
5011   DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
5012    "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
5013   exp = (char*)Perl_bytes_to_utf8(aTHX_
5014           (U8*)SvPV_nomg(pattern, plen),
5015           &len);
5016   xend = exp + len;
5017   RExC_orig_utf8 = RExC_utf8 = 1;
5018   SAVEFREEPV(exp);
5019  }
5020
5021 #ifdef TRIE_STUDY_OPT
5022  restudied = 0;
5023 #endif
5024
5025  pm_flags = orig_pm_flags;
5026
5027  if (initial_charset == REGEX_LOCALE_CHARSET) {
5028   RExC_contains_locale = 1;
5029  }
5030  else if (RExC_utf8 && initial_charset == REGEX_DEPENDS_CHARSET) {
5031
5032   /* Set to use unicode semantics if the pattern is in utf8 and has the
5033   * 'depends' charset specified, as it means unicode when utf8  */
5034   set_regex_charset(&pm_flags, REGEX_UNICODE_CHARSET);
5035  }
5036
5037  RExC_precomp = exp;
5038  RExC_flags = pm_flags;
5039  RExC_sawback = 0;
5040
5041  RExC_seen = 0;
5042  RExC_in_lookbehind = 0;
5043  RExC_seen_zerolen = *exp == '^' ? -1 : 0;
5044  RExC_seen_evals = 0;
5045  RExC_extralen = 0;
5046  RExC_override_recoding = 0;
5047
5048  /* First pass: determine size, legality. */
5049  RExC_parse = exp;
5050  RExC_start = exp;
5051  RExC_end = xend;
5052  RExC_naughty = 0;
5053  RExC_npar = 1;
5054  RExC_nestroot = 0;
5055  RExC_size = 0L;
5056  RExC_emit = &PL_regdummy;
5057  RExC_whilem_seen = 0;
5058  RExC_open_parens = NULL;
5059  RExC_close_parens = NULL;
5060  RExC_opend = NULL;
5061  RExC_paren_names = NULL;
5062 #ifdef DEBUGGING
5063  RExC_paren_name_list = NULL;
5064 #endif
5065  RExC_recurse = NULL;
5066  RExC_recurse_count = 0;
5067
5068 #if 0 /* REGC() is (currently) a NOP at the first pass.
5069  * Clever compilers notice this and complain. --jhi */
5070  REGC((U8)REG_MAGIC, (char*)RExC_emit);
5071 #endif
5072  DEBUG_PARSE_r(
5073   PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n");
5074   RExC_lastnum=0;
5075   RExC_lastparse=NULL;
5076  );
5077  if (reg(pRExC_state, 0, &flags,1) == NULL) {
5078   RExC_precomp = NULL;
5079   return(NULL);
5080  }
5081
5082  /* Here, finished first pass.  Get rid of any added setjmp */
5083  if (used_setjump) {
5084   JMPENV_POP;
5085  }
5086
5087  DEBUG_PARSE_r({
5088   PerlIO_printf(Perl_debug_log,
5089    "Required size %"IVdf" nodes\n"
5090    "Starting second pass (creation)\n",
5091    (IV)RExC_size);
5092   RExC_lastnum=0;
5093   RExC_lastparse=NULL;
5094  });
5095
5096  /* The first pass could have found things that force Unicode semantics */
5097  if ((RExC_utf8 || RExC_uni_semantics)
5098   && get_regex_charset(pm_flags) == REGEX_DEPENDS_CHARSET)
5099  {
5100   set_regex_charset(&pm_flags, REGEX_UNICODE_CHARSET);
5101  }
5102
5103  /* Small enough for pointer-storage convention?
5104  If extralen==0, this means that we will not need long jumps. */
5105  if (RExC_size >= 0x10000L && RExC_extralen)
5106   RExC_size += RExC_extralen;
5107  else
5108   RExC_extralen = 0;
5109  if (RExC_whilem_seen > 15)
5110   RExC_whilem_seen = 15;
5111
5112  /* Allocate space and zero-initialize. Note, the two step process
5113  of zeroing when in debug mode, thus anything assigned has to
5114  happen after that */
5115  rx = (REGEXP*) newSV_type(SVt_REGEXP);
5116  r = (struct regexp*)SvANY(rx);
5117  Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
5118   char, regexp_internal);
5119  if ( r == NULL || ri == NULL )
5120   FAIL("Regexp out of space");
5121 #ifdef DEBUGGING
5122  /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
5123  Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode), char);
5124 #else
5125  /* bulk initialize base fields with 0. */
5126  Zero(ri, sizeof(regexp_internal), char);
5127 #endif
5128
5129  /* non-zero initialization begins here */
5130  RXi_SET( r, ri );
5131  r->engine= RE_ENGINE_PTR;
5132  r->extflags = pm_flags;
5133  {
5134   bool has_p     = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
5135   bool has_charset = (get_regex_charset(r->extflags) != REGEX_DEPENDS_CHARSET);
5136
5137   /* The caret is output if there are any defaults: if not all the STD
5138   * flags are set, or if no character set specifier is needed */
5139   bool has_default =
5140      (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
5141      || ! has_charset);
5142   bool has_runon = ((RExC_seen & REG_SEEN_RUN_ON_COMMENT)==REG_SEEN_RUN_ON_COMMENT);
5143   U16 reganch = (U16)((r->extflags & RXf_PMf_STD_PMMOD)
5144        >> RXf_PMf_STD_PMMOD_SHIFT);
5145   const char *fptr = STD_PAT_MODS;        /*"msix"*/
5146   char *p;
5147   /* Allocate for the worst case, which is all the std flags are turned
5148   * on.  If more precision is desired, we could do a population count of
5149   * the flags set.  This could be done with a small lookup table, or by
5150   * shifting, masking and adding, or even, when available, assembly
5151   * language for a machine-language population count.
5152   * We never output a minus, as all those are defaults, so are
5153   * covered by the caret */
5154   const STRLEN wraplen = plen + has_p + has_runon
5155    + has_default       /* If needs a caret */
5156
5157     /* If needs a character set specifier */
5158    + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
5159    + (sizeof(STD_PAT_MODS) - 1)
5160    + (sizeof("(?:)") - 1);
5161
5162   p = sv_grow(MUTABLE_SV(rx), wraplen + 1); /* +1 for the ending NUL */
5163   SvPOK_on(rx);
5164   SvFLAGS(rx) |= SvUTF8(pattern);
5165   *p++='('; *p++='?';
5166
5167   /* If a default, cover it using the caret */
5168   if (has_default) {
5169    *p++= DEFAULT_PAT_MOD;
5170   }
5171   if (has_charset) {
5172    STRLEN len;
5173    const char* const name = get_regex_charset_name(r->extflags, &len);
5174    Copy(name, p, len, char);
5175    p += len;
5176   }
5177   if (has_p)
5178    *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
5179   {
5180    char ch;
5181    while((ch = *fptr++)) {
5182     if(reganch & 1)
5183      *p++ = ch;
5184     reganch >>= 1;
5185    }
5186   }
5187
5188   *p++ = ':';
5189   Copy(RExC_precomp, p, plen, char);
5190   assert ((RX_WRAPPED(rx) - p) < 16);
5191   r->pre_prefix = p - RX_WRAPPED(rx);
5192   p += plen;
5193   if (has_runon)
5194    *p++ = '\n';
5195   *p++ = ')';
5196   *p = 0;
5197   SvCUR_set(rx, p - SvPVX_const(rx));
5198  }
5199
5200  r->intflags = 0;
5201  r->nparens = RExC_npar - 1; /* set early to validate backrefs */
5202
5203  if (RExC_seen & REG_SEEN_RECURSE) {
5204   Newxz(RExC_open_parens, RExC_npar,regnode *);
5205   SAVEFREEPV(RExC_open_parens);
5206   Newxz(RExC_close_parens,RExC_npar,regnode *);
5207   SAVEFREEPV(RExC_close_parens);
5208  }
5209
5210  /* Useful during FAIL. */
5211 #ifdef RE_TRACK_PATTERN_OFFSETS
5212  Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
5213  DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log,
5214       "%s %"UVuf" bytes for offset annotations.\n",
5215       ri->u.offsets ? "Got" : "Couldn't get",
5216       (UV)((2*RExC_size+1) * sizeof(U32))));
5217 #endif
5218  SetProgLen(ri,RExC_size);
5219  RExC_rx_sv = rx;
5220  RExC_rx = r;
5221  RExC_rxi = ri;
5222  REH_CALL_COMP_BEGIN_HOOK(pRExC_state->rx);
5223
5224  /* Second pass: emit code. */
5225  RExC_flags = pm_flags; /* don't let top level (?i) bleed */
5226  RExC_parse = exp;
5227  RExC_end = xend;
5228  RExC_naughty = 0;
5229  RExC_npar = 1;
5230  RExC_emit_start = ri->program;
5231  RExC_emit = ri->program;
5232  RExC_emit_bound = ri->program + RExC_size + 1;
5233
5234  /* Store the count of eval-groups for security checks: */
5235  RExC_rx->seen_evals = RExC_seen_evals;
5236  REGC((U8)REG_MAGIC, (char*) RExC_emit++);
5237  if (reg(pRExC_state, 0, &flags,1) == NULL) {
5238   ReREFCNT_dec(rx);
5239   return(NULL);
5240  }
5241  /* XXXX To minimize changes to RE engine we always allocate
5242  3-units-long substrs field. */
5243  Newx(r->substrs, 1, struct reg_substr_data);
5244  if (RExC_recurse_count) {
5245   Newxz(RExC_recurse,RExC_recurse_count,regnode *);
5246   SAVEFREEPV(RExC_recurse);
5247  }
5248
5249 reStudy:
5250  r->minlen = minlen = sawlookahead = sawplus = sawopen = 0;
5251  Zero(r->substrs, 1, struct reg_substr_data);
5252
5253 #ifdef TRIE_STUDY_OPT
5254  if (!restudied) {
5255   StructCopy(&zero_scan_data, &data, scan_data_t);
5256   copyRExC_state = RExC_state;
5257  } else {
5258   U32 seen=RExC_seen;
5259   DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n"));
5260
5261   RExC_state = copyRExC_state;
5262   if (seen & REG_TOP_LEVEL_BRANCHES)
5263    RExC_seen |= REG_TOP_LEVEL_BRANCHES;
5264   else
5265    RExC_seen &= ~REG_TOP_LEVEL_BRANCHES;
5266   if (data.last_found) {
5267    SvREFCNT_dec(data.longest_fixed);
5268    SvREFCNT_dec(data.longest_float);
5269    SvREFCNT_dec(data.last_found);
5270   }
5271   StructCopy(&zero_scan_data, &data, scan_data_t);
5272  }
5273 #else
5274  StructCopy(&zero_scan_data, &data, scan_data_t);
5275 #endif
5276
5277  /* Dig out information for optimizations. */
5278  r->extflags = RExC_flags; /* was pm_op */
5279  /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
5280
5281  if (UTF)
5282   SvUTF8_on(rx); /* Unicode in it? */
5283  ri->regstclass = NULL;
5284  if (RExC_naughty >= 10) /* Probably an expensive pattern. */
5285   r->intflags |= PREGf_NAUGHTY;
5286  scan = ri->program + 1;  /* First BRANCH. */
5287
5288  /* testing for BRANCH here tells us whether there is "must appear"
5289  data in the pattern. If there is then we can use it for optimisations */
5290  if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES)) { /*  Only one top-level choice. */
5291   I32 fake;
5292   STRLEN longest_float_length, longest_fixed_length;
5293   struct regnode_charclass_class ch_class; /* pointed to by data */
5294   int stclass_flag;
5295   I32 last_close = 0; /* pointed to by data */
5296   regnode *first= scan;
5297   regnode *first_next= regnext(first);
5298   /*
5299   * Skip introductions and multiplicators >= 1
5300   * so that we can extract the 'meat' of the pattern that must
5301   * match in the large if() sequence following.
5302   * NOTE that EXACT is NOT covered here, as it is normally
5303   * picked up by the optimiser separately.
5304   *
5305   * This is unfortunate as the optimiser isnt handling lookahead
5306   * properly currently.
5307   *
5308   */
5309   while ((OP(first) == OPEN && (sawopen = 1)) ||
5310    /* An OR of *one* alternative - should not happen now. */
5311    (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
5312    /* for now we can't handle lookbehind IFMATCH*/
5313    (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
5314    (OP(first) == PLUS) ||
5315    (OP(first) == MINMOD) ||
5316    /* An {n,m} with n>0 */
5317    (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
5318    (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
5319   {
5320     /*
5321     * the only op that could be a regnode is PLUS, all the rest
5322     * will be regnode_1 or regnode_2.
5323     *
5324     */
5325     if (OP(first) == PLUS)
5326      sawplus = 1;
5327     else
5328      first += regarglen[OP(first)];
5329
5330     first = NEXTOPER(first);
5331     first_next= regnext(first);
5332   }
5333
5334   /* Starting-point info. */
5335  again:
5336   DEBUG_PEEP("first:",first,0);
5337   /* Ignore EXACT as we deal with it later. */
5338   if (PL_regkind[OP(first)] == EXACT) {
5339    if (OP(first) == EXACT)
5340     NOOP; /* Empty, get anchored substr later. */
5341    else
5342     ri->regstclass = first;
5343   }
5344 #ifdef TRIE_STCLASS
5345   else if (PL_regkind[OP(first)] == TRIE &&
5346     ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0)
5347   {
5348    regnode *trie_op;
5349    /* this can happen only on restudy */
5350    if ( OP(first) == TRIE ) {
5351     struct regnode_1 *trieop = (struct regnode_1 *)
5352      PerlMemShared_calloc(1, sizeof(struct regnode_1));
5353     StructCopy(first,trieop,struct regnode_1);
5354     trie_op=(regnode *)trieop;
5355    } else {
5356     struct regnode_charclass *trieop = (struct regnode_charclass *)
5357      PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
5358     StructCopy(first,trieop,struct regnode_charclass);
5359     trie_op=(regnode *)trieop;
5360    }
5361    OP(trie_op)+=2;
5362    make_trie_failtable(pRExC_state, (regnode *)first, trie_op, 0);
5363    ri->regstclass = trie_op;
5364   }
5365 #endif
5366   else if (REGNODE_SIMPLE(OP(first)))
5367    ri->regstclass = first;
5368   else if (PL_regkind[OP(first)] == BOUND ||
5369     PL_regkind[OP(first)] == NBOUND)
5370    ri->regstclass = first;
5371   else if (PL_regkind[OP(first)] == BOL) {
5372    r->extflags |= (OP(first) == MBOL
5373       ? RXf_ANCH_MBOL
5374       : (OP(first) == SBOL
5375        ? RXf_ANCH_SBOL
5376        : RXf_ANCH_BOL));
5377    first = NEXTOPER(first);
5378    goto again;
5379   }
5380   else if (OP(first) == GPOS) {
5381    r->extflags |= RXf_ANCH_GPOS;
5382    first = NEXTOPER(first);
5383    goto again;
5384   }
5385   else if ((!sawopen || !RExC_sawback) &&
5386    (OP(first) == STAR &&
5387    PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
5388    !(r->extflags & RXf_ANCH) && !(RExC_seen & REG_SEEN_EVAL))
5389   {
5390    /* turn .* into ^.* with an implied $*=1 */
5391    const int type =
5392     (OP(NEXTOPER(first)) == REG_ANY)
5393      ? RXf_ANCH_MBOL
5394      : RXf_ANCH_SBOL;
5395    r->extflags |= type;
5396    r->intflags |= PREGf_IMPLICIT;
5397    first = NEXTOPER(first);
5398    goto again;
5399   }
5400   if (sawplus && !sawlookahead && (!sawopen || !RExC_sawback)
5401    && !(RExC_seen & REG_SEEN_EVAL)) /* May examine pos and $& */
5402    /* x+ must match at the 1st pos of run of x's */
5403    r->intflags |= PREGf_SKIP;
5404
5405   /* Scan is after the zeroth branch, first is atomic matcher. */
5406 #ifdef TRIE_STUDY_OPT
5407   DEBUG_PARSE_r(
5408    if (!restudied)
5409     PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
5410        (IV)(first - scan + 1))
5411   );
5412 #else
5413   DEBUG_PARSE_r(
5414    PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
5415     (IV)(first - scan + 1))
5416   );
5417 #endif
5418
5419
5420   /*
5421   * If there's something expensive in the r.e., find the
5422   * longest literal string that must appear and make it the
5423   * regmust.  Resolve ties in favor of later strings, since
5424   * the regstart check works with the beginning of the r.e.
5425   * and avoiding duplication strengthens checking.  Not a
5426   * strong reason, but sufficient in the absence of others.
5427   * [Now we resolve ties in favor of the earlier string if
5428   * it happens that c_offset_min has been invalidated, since the
5429   * earlier string may buy us something the later one won't.]
5430   */
5431
5432   data.longest_fixed = newSVpvs("");
5433   data.longest_float = newSVpvs("");
5434   data.last_found = newSVpvs("");
5435   data.longest = &(data.longest_fixed);
5436   first = scan;
5437   if (!ri->regstclass) {
5438    cl_init(pRExC_state, &ch_class);
5439    data.start_class = &ch_class;
5440    stclass_flag = SCF_DO_STCLASS_AND;
5441   } else    /* XXXX Check for BOUND? */
5442    stclass_flag = 0;
5443   data.last_closep = &last_close;
5444
5445   minlen = study_chunk(pRExC_state, &first, &minlen, &fake, scan + RExC_size, /* Up to end */
5446    &data, -1, NULL, NULL,
5447    SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0);
5448
5449
5450   CHECK_RESTUDY_GOTO;
5451
5452
5453   if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
5454    && data.last_start_min == 0 && data.last_end > 0
5455    && !RExC_seen_zerolen
5456    && !(RExC_seen & REG_SEEN_VERBARG)
5457    && (!(RExC_seen & REG_SEEN_GPOS) || (r->extflags & RXf_ANCH_GPOS)))
5458    r->extflags |= RXf_CHECK_ALL;
5459   scan_commit(pRExC_state, &data,&minlen,0);
5460   SvREFCNT_dec(data.last_found);
5461
5462   /* Note that code very similar to this but for anchored string
5463   follows immediately below, changes may need to be made to both.
5464   Be careful.
5465   */
5466   longest_float_length = CHR_SVLEN(data.longest_float);
5467   if (longest_float_length
5468    || (data.flags & SF_FL_BEFORE_EOL
5469     && (!(data.flags & SF_FL_BEFORE_MEOL)
5470      || (RExC_flags & RXf_PMf_MULTILINE))))
5471   {
5472    I32 t,ml;
5473
5474    /* See comments for join_exact for why REG_SEEN_EXACTF_SHARP_S */
5475    if ((RExC_seen & REG_SEEN_EXACTF_SHARP_S)
5476     || (SvCUR(data.longest_fixed)  /* ok to leave SvCUR */
5477      && data.offset_fixed == data.offset_float_min
5478      && SvCUR(data.longest_fixed) == SvCUR(data.longest_float)))
5479      goto remove_float;  /* As in (a)+. */
5480
5481    /* copy the information about the longest float from the reg_scan_data
5482    over to the program. */
5483    if (SvUTF8(data.longest_float)) {
5484     r->float_utf8 = data.longest_float;
5485     r->float_substr = NULL;
5486    } else {
5487     r->float_substr = data.longest_float;
5488     r->float_utf8 = NULL;
5489    }
5490    /* float_end_shift is how many chars that must be matched that
5491    follow this item. We calculate it ahead of time as once the
5492    lookbehind offset is added in we lose the ability to correctly
5493    calculate it.*/
5494    ml = data.minlen_float ? *(data.minlen_float)
5495         : (I32)longest_float_length;
5496    r->float_end_shift = ml - data.offset_float_min
5497     - longest_float_length + (SvTAIL(data.longest_float) != 0)
5498     + data.lookbehind_float;
5499    r->float_min_offset = data.offset_float_min - data.lookbehind_float;
5500    r->float_max_offset = data.offset_float_max;
5501    if (data.offset_float_max < I32_MAX) /* Don't offset infinity */
5502     r->float_max_offset -= data.lookbehind_float;
5503
5504    t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */
5505      && (!(data.flags & SF_FL_BEFORE_MEOL)
5506       || (RExC_flags & RXf_PMf_MULTILINE)));
5507    fbm_compile(data.longest_float, t ? FBMcf_TAIL : 0);
5508   }
5509   else {
5510   remove_float:
5511    r->float_substr = r->float_utf8 = NULL;
5512    SvREFCNT_dec(data.longest_float);
5513    longest_float_length = 0;
5514   }
5515
5516   /* Note that code very similar to this but for floating string
5517   is immediately above, changes may need to be made to both.
5518   Be careful.
5519   */
5520   longest_fixed_length = CHR_SVLEN(data.longest_fixed);
5521
5522   /* See comments for join_exact for why REG_SEEN_EXACTF_SHARP_S */
5523   if (! (RExC_seen & REG_SEEN_EXACTF_SHARP_S)
5524    && (longest_fixed_length
5525     || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
5526      && (!(data.flags & SF_FIX_BEFORE_MEOL)
5527       || (RExC_flags & RXf_PMf_MULTILINE)))) )
5528   {
5529    I32 t,ml;
5530
5531    /* copy the information about the longest fixed
5532    from the reg_scan_data over to the program. */
5533    if (SvUTF8(data.longest_fixed)) {
5534     r->anchored_utf8 = data.longest_fixed;
5535     r->anchored_substr = NULL;
5536    } else {
5537     r->anchored_substr = data.longest_fixed;
5538     r->anchored_utf8 = NULL;
5539    }
5540    /* fixed_end_shift is how many chars that must be matched that
5541    follow this item. We calculate it ahead of time as once the
5542    lookbehind offset is added in we lose the ability to correctly
5543    calculate it.*/
5544    ml = data.minlen_fixed ? *(data.minlen_fixed)
5545         : (I32)longest_fixed_length;
5546    r->anchored_end_shift = ml - data.offset_fixed
5547     - longest_fixed_length + (SvTAIL(data.longest_fixed) != 0)
5548     + data.lookbehind_fixed;
5549    r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
5550
5551    t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */
5552     && (!(data.flags & SF_FIX_BEFORE_MEOL)
5553      || (RExC_flags & RXf_PMf_MULTILINE)));
5554    fbm_compile(data.longest_fixed, t ? FBMcf_TAIL : 0);
5555   }
5556   else {
5557    r->anchored_substr = r->anchored_utf8 = NULL;
5558    SvREFCNT_dec(data.longest_fixed);
5559    longest_fixed_length = 0;
5560   }
5561   if (ri->regstclass
5562    && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
5563    ri->regstclass = NULL;
5564
5565   if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
5566    && stclass_flag
5567    && !(data.start_class->flags & ANYOF_EOS)
5568    && !cl_is_anything(data.start_class))
5569   {
5570    const U32 n = add_data(pRExC_state, 1, "f");
5571    data.start_class->flags |= ANYOF_IS_SYNTHETIC;
5572
5573    Newx(RExC_rxi->data->data[n], 1,
5574     struct regnode_charclass_class);
5575    StructCopy(data.start_class,
5576      (struct regnode_charclass_class*)RExC_rxi->data->data[n],
5577      struct regnode_charclass_class);
5578    ri->regstclass = (regnode*)RExC_rxi->data->data[n];
5579    r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
5580    DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
5581      regprop(r, sv, (regnode*)data.start_class);
5582      PerlIO_printf(Perl_debug_log,
5583          "synthetic stclass \"%s\".\n",
5584          SvPVX_const(sv));});
5585   }
5586
5587   /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
5588   if (longest_fixed_length > longest_float_length) {
5589    r->check_end_shift = r->anchored_end_shift;
5590    r->check_substr = r->anchored_substr;
5591    r->check_utf8 = r->anchored_utf8;
5592    r->check_offset_min = r->check_offset_max = r->anchored_offset;
5593    if (r->extflags & RXf_ANCH_SINGLE)
5594     r->extflags |= RXf_NOSCAN;
5595   }
5596   else {
5597    r->check_end_shift = r->float_end_shift;
5598    r->check_substr = r->float_substr;
5599    r->check_utf8 = r->float_utf8;
5600    r->check_offset_min = r->float_min_offset;
5601    r->check_offset_max = r->float_max_offset;
5602   }
5603   /* XXXX Currently intuiting is not compatible with ANCH_GPOS.
5604   This should be changed ASAP!  */
5605   if ((r->check_substr || r->check_utf8) && !(r->extflags & RXf_ANCH_GPOS)) {
5606    r->extflags |= RXf_USE_INTUIT;
5607    if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
5608     r->extflags |= RXf_INTUIT_TAIL;
5609   }
5610   /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
5611   if ( (STRLEN)minlen < longest_float_length )
5612    minlen= longest_float_length;
5613   if ( (STRLEN)minlen < longest_fixed_length )
5614    minlen= longest_fixed_length;
5615   */
5616  }
5617  else {
5618   /* Several toplevels. Best we can is to set minlen. */
5619   I32 fake;
5620   struct regnode_charclass_class ch_class;
5621   I32 last_close = 0;
5622
5623   DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n"));
5624
5625   scan = ri->program + 1;
5626   cl_init(pRExC_state, &ch_class);
5627   data.start_class = &ch_class;
5628   data.last_closep = &last_close;
5629
5630
5631   minlen = study_chunk(pRExC_state, &scan, &minlen, &fake, scan + RExC_size,
5632    &data, -1, NULL, NULL, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0);
5633
5634   CHECK_RESTUDY_GOTO;
5635
5636   r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
5637     = r->float_substr = r->float_utf8 = NULL;
5638
5639   if (!(data.start_class->flags & ANYOF_EOS)
5640    && !cl_is_anything(data.start_class))
5641   {
5642    const U32 n = add_data(pRExC_state, 1, "f");
5643    data.start_class->flags |= ANYOF_IS_SYNTHETIC;
5644
5645    Newx(RExC_rxi->data->data[n], 1,
5646     struct regnode_charclass_class);
5647    StructCopy(data.start_class,
5648      (struct regnode_charclass_class*)RExC_rxi->data->data[n],
5649      struct regnode_charclass_class);
5650    ri->regstclass = (regnode*)RExC_rxi->data->data[n];
5651    r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
5652    DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
5653      regprop(r, sv, (regnode*)data.start_class);
5654      PerlIO_printf(Perl_debug_log,
5655          "synthetic stclass \"%s\".\n",
5656          SvPVX_const(sv));});
5657   }
5658  }
5659
5660  /* Guard against an embedded (?=) or (?<=) with a longer minlen than
5661  the "real" pattern. */
5662  DEBUG_OPTIMISE_r({
5663   PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf"\n",
5664      (IV)minlen, (IV)r->minlen);
5665  });
5666  r->minlenret = minlen;
5667  if (r->minlen < minlen)
5668   r->minlen = minlen;
5669
5670  if (RExC_seen & REG_SEEN_GPOS)
5671   r->extflags |= RXf_GPOS_SEEN;
5672  if (RExC_seen & REG_SEEN_LOOKBEHIND)
5673   r->extflags |= RXf_LOOKBEHIND_SEEN;
5674  if (RExC_seen & REG_SEEN_EVAL)
5675   r->extflags |= RXf_EVAL_SEEN;
5676  if (RExC_seen & REG_SEEN_CANY)
5677   r->extflags |= RXf_CANY_SEEN;
5678  if (RExC_seen & REG_SEEN_VERBARG)
5679   r->intflags |= PREGf_VERBARG_SEEN;
5680  if (RExC_seen & REG_SEEN_CUTGROUP)
5681   r->intflags |= PREGf_CUTGROUP_SEEN;
5682  if (RExC_paren_names)
5683   RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
5684  else
5685   RXp_PAREN_NAMES(r) = NULL;
5686
5687 #ifdef STUPID_PATTERN_CHECKS
5688  if (RX_PRELEN(rx) == 0)
5689   r->extflags |= RXf_NULL;
5690  if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
5691   /* XXX: this should happen BEFORE we compile */
5692   r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
5693  else if (RX_PRELEN(rx) == 3 && memEQ("\\s+", RX_PRECOMP(rx), 3))
5694   r->extflags |= RXf_WHITE;
5695  else if (RX_PRELEN(rx) == 1 && RXp_PRECOMP(rx)[0] == '^')
5696   r->extflags |= RXf_START_ONLY;
5697 #else
5698  if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
5699    /* XXX: this should happen BEFORE we compile */
5700    r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
5701  else {
5702   regnode *first = ri->program + 1;
5703   U8 fop = OP(first);
5704
5705   if (PL_regkind[fop] == NOTHING && OP(NEXTOPER(first)) == END)
5706    r->extflags |= RXf_NULL;
5707   else if (PL_regkind[fop] == BOL && OP(NEXTOPER(first)) == END)
5708    r->extflags |= RXf_START_ONLY;
5709   else if (fop == PLUS && OP(NEXTOPER(first)) == SPACE
5710        && OP(regnext(first)) == END)
5711    r->extflags |= RXf_WHITE;
5712  }
5713 #endif
5714 #ifdef DEBUGGING
5715  if (RExC_paren_names) {
5716   ri->name_list_idx = add_data( pRExC_state, 1, "a" );
5717   ri->data->data[ri->name_list_idx] = (void*)SvREFCNT_inc(RExC_paren_name_list);
5718  } else
5719 #endif
5720   ri->name_list_idx = 0;
5721
5722  if (RExC_recurse_count) {
5723   for ( ; RExC_recurse_count ; RExC_recurse_count-- ) {
5724    const regnode *scan = RExC_recurse[RExC_recurse_count-1];
5725    ARG2L_SET( scan, RExC_open_parens[ARG(scan)-1] - scan );
5726   }
5727  }
5728  Newxz(r->offs, RExC_npar, regexp_paren_pair);
5729  /* assume we don't need to swap parens around before we match */
5730
5731  DEBUG_DUMP_r({
5732   PerlIO_printf(Perl_debug_log,"Final program:\n");
5733   regdump(r);
5734  });
5735 #ifdef RE_TRACK_PATTERN_OFFSETS
5736  DEBUG_OFFSETS_r(if (ri->u.offsets) {
5737   const U32 len = ri->u.offsets[0];
5738   U32 i;
5739   GET_RE_DEBUG_FLAGS_DECL;
5740   PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)ri->u.offsets[0]);
5741   for (i = 1; i <= len; i++) {
5742    if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
5743     PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
5744     (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
5745    }
5746   PerlIO_printf(Perl_debug_log, "\n");
5747  });
5748 #endif
5749  return rx;
5750 }
5751
5752 #undef RE_ENGINE_PTR
5753
5754
5755 SV*
5756 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
5757      const U32 flags)
5758 {
5759  PERL_ARGS_ASSERT_REG_NAMED_BUFF;
5760
5761  PERL_UNUSED_ARG(value);
5762
5763  if (flags & RXapif_FETCH) {
5764   return reg_named_buff_fetch(rx, key, flags);
5765  } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
5766   Perl_croak_no_modify(aTHX);
5767   return NULL;
5768  } else if (flags & RXapif_EXISTS) {
5769   return reg_named_buff_exists(rx, key, flags)
5770    ? &PL_sv_yes
5771    : &PL_sv_no;
5772  } else if (flags & RXapif_REGNAMES) {
5773   return reg_named_buff_all(rx, flags);
5774  } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
5775   return reg_named_buff_scalar(rx, flags);
5776  } else {
5777   Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
5778   return NULL;
5779  }
5780 }
5781
5782 SV*
5783 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
5784       const U32 flags)
5785 {
5786  PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
5787  PERL_UNUSED_ARG(lastkey);
5788
5789  if (flags & RXapif_FIRSTKEY)
5790   return reg_named_buff_firstkey(rx, flags);
5791  else if (flags & RXapif_NEXTKEY)
5792   return reg_named_buff_nextkey(rx, flags);
5793  else {
5794   Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter", (int)flags);
5795   return NULL;
5796  }
5797 }
5798
5799 SV*
5800 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
5801       const U32 flags)
5802 {
5803  AV *retarray = NULL;
5804  SV *ret;
5805  struct regexp *const rx = (struct regexp *)SvANY(r);
5806
5807  PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
5808
5809  if (flags & RXapif_ALL)
5810   retarray=newAV();
5811
5812  if (rx && RXp_PAREN_NAMES(rx)) {
5813   HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
5814   if (he_str) {
5815    IV i;
5816    SV* sv_dat=HeVAL(he_str);
5817    I32 *nums=(I32*)SvPVX(sv_dat);
5818    for ( i=0; i<SvIVX(sv_dat); i++ ) {
5819     if ((I32)(rx->nparens) >= nums[i]
5820      && rx->offs[nums[i]].start != -1
5821      && rx->offs[nums[i]].end != -1)
5822     {
5823      ret = newSVpvs("");
5824      CALLREG_NUMBUF_FETCH(r,nums[i],ret);
5825      if (!retarray)
5826       return ret;
5827     } else {
5828      if (retarray)
5829       ret = newSVsv(&PL_sv_undef);
5830     }
5831     if (retarray)
5832      av_push(retarray, ret);
5833    }
5834    if (retarray)
5835     return newRV_noinc(MUTABLE_SV(retarray));
5836   }
5837  }
5838  return NULL;
5839 }
5840
5841 bool
5842 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
5843       const U32 flags)
5844 {
5845  struct regexp *const rx = (struct regexp *)SvANY(r);
5846
5847  PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
5848
5849  if (rx && RXp_PAREN_NAMES(rx)) {
5850   if (flags & RXapif_ALL) {
5851    return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
5852   } else {
5853    SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
5854    if (sv) {
5855     SvREFCNT_dec(sv);
5856     return TRUE;
5857    } else {
5858     return FALSE;
5859    }
5860   }
5861  } else {
5862   return FALSE;
5863  }
5864 }
5865
5866 SV*
5867 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
5868 {
5869  struct regexp *const rx = (struct regexp *)SvANY(r);
5870
5871  PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
5872
5873  if ( rx && RXp_PAREN_NAMES(rx) ) {
5874   (void)hv_iterinit(RXp_PAREN_NAMES(rx));
5875
5876   return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
5877  } else {
5878   return FALSE;
5879  }
5880 }
5881
5882 SV*
5883 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
5884 {
5885  struct regexp *const rx = (struct regexp *)SvANY(r);
5886  GET_RE_DEBUG_FLAGS_DECL;
5887
5888  PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
5889
5890  if (rx && RXp_PAREN_NAMES(rx)) {
5891   HV *hv = RXp_PAREN_NAMES(rx);
5892   HE *temphe;
5893   while ( (temphe = hv_iternext_flags(hv,0)) ) {
5894    IV i;
5895    IV parno = 0;
5896    SV* sv_dat = HeVAL(temphe);
5897    I32 *nums = (I32*)SvPVX(sv_dat);
5898    for ( i = 0; i < SvIVX(sv_dat); i++ ) {
5899     if ((I32)(rx->lastparen) >= nums[i] &&
5900      rx->offs[nums[i]].start != -1 &&
5901      rx->offs[nums[i]].end != -1)
5902     {
5903      parno = nums[i];
5904      break;
5905     }
5906    }
5907    if (parno || flags & RXapif_ALL) {
5908     return newSVhek(HeKEY_hek(temphe));
5909    }
5910   }
5911  }
5912  return NULL;
5913 }
5914
5915 SV*
5916 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
5917 {
5918  SV *ret;
5919  AV *av;
5920  I32 length;
5921  struct regexp *const rx = (struct regexp *)SvANY(r);
5922
5923  PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
5924
5925  if (rx && RXp_PAREN_NAMES(rx)) {
5926   if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
5927    return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
5928   } else if (flags & RXapif_ONE) {
5929    ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
5930    av = MUTABLE_AV(SvRV(ret));
5931    length = av_len(av);
5932    SvREFCNT_dec(ret);
5933    return newSViv(length + 1);
5934   } else {
5935    Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar", (int)flags);
5936    return NULL;
5937   }
5938  }
5939  return &PL_sv_undef;
5940 }
5941
5942 SV*
5943 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
5944 {
5945  struct regexp *const rx = (struct regexp *)SvANY(r);
5946  AV *av = newAV();
5947
5948  PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
5949
5950  if (rx && RXp_PAREN_NAMES(rx)) {
5951   HV *hv= RXp_PAREN_NAMES(rx);
5952   HE *temphe;
5953   (void)hv_iterinit(hv);
5954   while ( (temphe = hv_iternext_flags(hv,0)) ) {
5955    IV i;
5956    IV parno = 0;
5957    SV* sv_dat = HeVAL(temphe);
5958    I32 *nums = (I32*)SvPVX(sv_dat);
5959    for ( i = 0; i < SvIVX(sv_dat); i++ ) {
5960     if ((I32)(rx->lastparen) >= nums[i] &&
5961      rx->offs[nums[i]].start != -1 &&
5962      rx->offs[nums[i]].end != -1)
5963     {
5964      parno = nums[i];
5965      break;
5966     }
5967    }
5968    if (parno || flags & RXapif_ALL) {
5969     av_push(av, newSVhek(HeKEY_hek(temphe)));
5970    }
5971   }
5972  }
5973
5974  return newRV_noinc(MUTABLE_SV(av));
5975 }
5976
5977 void
5978 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
5979        SV * const sv)
5980 {
5981  struct regexp *const rx = (struct regexp *)SvANY(r);
5982  char *s = NULL;
5983  I32 i = 0;
5984  I32 s1, t1;
5985
5986  PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
5987
5988  if (!rx->subbeg) {
5989   sv_setsv(sv,&PL_sv_undef);
5990   return;
5991  }
5992  else
5993  if (paren == RX_BUFF_IDX_PREMATCH && rx->offs[0].start != -1) {
5994   /* $` */
5995   i = rx->offs[0].start;
5996   s = rx->subbeg;
5997  }
5998  else
5999  if (paren == RX_BUFF_IDX_POSTMATCH && rx->offs[0].end != -1) {
6000   /* $' */
6001   s = rx->subbeg + rx->offs[0].end;
6002   i = rx->sublen - rx->offs[0].end;
6003  }
6004  else
6005  if ( 0 <= paren && paren <= (I32)rx->nparens &&
6006   (s1 = rx->offs[paren].start) != -1 &&
6007   (t1 = rx->offs[paren].end) != -1)
6008  {
6009   /* $& $1 ... */
6010   i = t1 - s1;
6011   s = rx->subbeg + s1;
6012  } else {
6013   sv_setsv(sv,&PL_sv_undef);
6014   return;
6015  }
6016  assert(rx->sublen >= (s - rx->subbeg) + i );
6017  if (i >= 0) {
6018   const int oldtainted = PL_tainted;
6019   TAINT_NOT;
6020   sv_setpvn(sv, s, i);
6021   PL_tainted = oldtainted;
6022   if ( (rx->extflags & RXf_CANY_SEEN)
6023    ? (RXp_MATCH_UTF8(rx)
6024       && (!i || is_utf8_string((U8*)s, i)))
6025    : (RXp_MATCH_UTF8(rx)) )
6026   {
6027    SvUTF8_on(sv);
6028   }
6029   else
6030    SvUTF8_off(sv);
6031   if (PL_tainting) {
6032    if (RXp_MATCH_TAINTED(rx)) {
6033     if (SvTYPE(sv) >= SVt_PVMG) {
6034      MAGIC* const mg = SvMAGIC(sv);
6035      MAGIC* mgt;
6036      PL_tainted = 1;
6037      SvMAGIC_set(sv, mg->mg_moremagic);
6038      SvTAINT(sv);
6039      if ((mgt = SvMAGIC(sv))) {
6040       mg->mg_moremagic = mgt;
6041       SvMAGIC_set(sv, mg);
6042      }
6043     } else {
6044      PL_tainted = 1;
6045      SvTAINT(sv);
6046     }
6047    } else
6048     SvTAINTED_off(sv);
6049   }
6050  } else {
6051   sv_setsv(sv,&PL_sv_undef);
6052   return;
6053  }
6054 }
6055
6056 void
6057 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
6058               SV const * const value)
6059 {
6060  PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
6061
6062  PERL_UNUSED_ARG(rx);
6063  PERL_UNUSED_ARG(paren);
6064  PERL_UNUSED_ARG(value);
6065
6066  if (!PL_localizing)
6067   Perl_croak_no_modify(aTHX);
6068 }
6069
6070 I32
6071 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
6072        const I32 paren)
6073 {
6074  struct regexp *const rx = (struct regexp *)SvANY(r);
6075  I32 i;
6076  I32 s1, t1;
6077
6078  PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
6079
6080  /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
6081   switch (paren) {
6082  /* $` / ${^PREMATCH} */
6083  case RX_BUFF_IDX_PREMATCH:
6084   if (rx->offs[0].start != -1) {
6085       i = rx->offs[0].start;
6086       if (i > 0) {
6087         s1 = 0;
6088         t1 = i;
6089         goto getlen;
6090       }
6091    }
6092   return 0;
6093  /* $' / ${^POSTMATCH} */
6094  case RX_BUFF_IDX_POSTMATCH:
6095    if (rx->offs[0].end != -1) {
6096       i = rx->sublen - rx->offs[0].end;
6097       if (i > 0) {
6098         s1 = rx->offs[0].end;
6099         t1 = rx->sublen;
6100         goto getlen;
6101       }
6102    }
6103   return 0;
6104  /* $& / ${^MATCH}, $1, $2, ... */
6105  default:
6106    if (paren <= (I32)rx->nparens &&
6107    (s1 = rx->offs[paren].start) != -1 &&
6108    (t1 = rx->offs[paren].end) != -1)
6109    {
6110    i = t1 - s1;
6111    goto getlen;
6112   } else {
6113    if (ckWARN(WARN_UNINITIALIZED))
6114     report_uninit((const SV *)sv);
6115    return 0;
6116   }
6117  }
6118   getlen:
6119  if (i > 0 && RXp_MATCH_UTF8(rx)) {
6120   const char * const s = rx->subbeg + s1;
6121   const U8 *ep;
6122   STRLEN el;
6123
6124   i = t1 - s1;
6125   if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
6126       i = el;
6127  }
6128  return i;
6129 }
6130
6131 SV*
6132 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
6133 {
6134  PERL_ARGS_ASSERT_REG_QR_PACKAGE;
6135   PERL_UNUSED_ARG(rx);
6136   if (0)
6137    return NULL;
6138   else
6139    return newSVpvs("Regexp");
6140 }
6141
6142 /* Scans the name of a named buffer from the pattern.
6143  * If flags is REG_RSN_RETURN_NULL returns null.
6144  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
6145  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
6146  * to the parsed name as looked up in the RExC_paren_names hash.
6147  * If there is an error throws a vFAIL().. type exception.
6148  */
6149
6150 #define REG_RSN_RETURN_NULL    0
6151 #define REG_RSN_RETURN_NAME    1
6152 #define REG_RSN_RETURN_DATA    2
6153
6154 STATIC SV*
6155 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
6156 {
6157  char *name_start = RExC_parse;
6158
6159  PERL_ARGS_ASSERT_REG_SCAN_NAME;
6160
6161  if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
6162   /* skip IDFIRST by using do...while */
6163   if (UTF)
6164    do {
6165     RExC_parse += UTF8SKIP(RExC_parse);
6166    } while (isALNUM_utf8((U8*)RExC_parse));
6167   else
6168    do {
6169     RExC_parse++;
6170    } while (isALNUM(*RExC_parse));
6171  }
6172
6173  if ( flags ) {
6174   SV* sv_name
6175    = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
6176        SVs_TEMP | (UTF ? SVf_UTF8 : 0));
6177   if ( flags == REG_RSN_RETURN_NAME)
6178    return sv_name;
6179   else if (flags==REG_RSN_RETURN_DATA) {
6180    HE *he_str = NULL;
6181    SV *sv_dat = NULL;
6182    if ( ! sv_name )      /* should not happen*/
6183     Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
6184    if (RExC_paren_names)
6185     he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
6186    if ( he_str )
6187     sv_dat = HeVAL(he_str);
6188    if ( ! sv_dat )
6189     vFAIL("Reference to nonexistent named group");
6190    return sv_dat;
6191   }
6192   else {
6193    Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
6194      (unsigned long) flags);
6195   }
6196   /* NOT REACHED */
6197  }
6198  return NULL;
6199 }
6200
6201 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
6202  int rem=(int)(RExC_end - RExC_parse);                       \
6203  int cut;                                                    \
6204  int num;                                                    \
6205  int iscut=0;                                                \
6206  if (rem>10) {                                               \
6207   rem=10;                                                 \
6208   iscut=1;                                                \
6209  }                                                           \
6210  cut=10-rem;                                                 \
6211  if (RExC_lastparse!=RExC_parse)                             \
6212   PerlIO_printf(Perl_debug_log," >%.*s%-*s",              \
6213    rem, RExC_parse,                                    \
6214    cut + 4,                                            \
6215    iscut ? "..." : "<"                                 \
6216   );                                                      \
6217  else                                                        \
6218   PerlIO_printf(Perl_debug_log,"%16s","");                \
6219                 \
6220  if (SIZE_ONLY)                                              \
6221  num = RExC_size + 1;                                     \
6222  else                                                        \
6223  num=REG_NODE_NUM(RExC_emit);                             \
6224  if (RExC_lastnum!=num)                                      \
6225  PerlIO_printf(Perl_debug_log,"|%4d",num);                \
6226  else                                                        \
6227  PerlIO_printf(Perl_debug_log,"|%4s","");                 \
6228  PerlIO_printf(Perl_debug_log,"|%*s%-4s",                    \
6229   (int)((depth*2)), "",                                   \
6230   (funcname)                                              \
6231  );                                                          \
6232  RExC_lastnum=num;                                           \
6233  RExC_lastparse=RExC_parse;                                  \
6234 })
6235
6236
6237
6238 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
6239  DEBUG_PARSE_MSG((funcname));                            \
6240  PerlIO_printf(Perl_debug_log,"%4s","\n");               \
6241 })
6242 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({           \
6243  DEBUG_PARSE_MSG((funcname));                            \
6244  PerlIO_printf(Perl_debug_log,fmt "\n",args);               \
6245 })
6246
6247 /* This section of code defines the inversion list object and its methods.  The
6248  * interfaces are highly subject to change, so as much as possible is static to
6249  * this file.  An inversion list is here implemented as a malloc'd C UV array
6250  * with some added info that is placed as UVs at the beginning in a header
6251  * portion.  An inversion list for Unicode is an array of code points, sorted
6252  * by ordinal number.  The zeroth element is the first code point in the list.
6253  * The 1th element is the first element beyond that not in the list.  In other
6254  * words, the first range is
6255  *  invlist[0]..(invlist[1]-1)
6256  * The other ranges follow.  Thus every element whose index is divisible by two
6257  * marks the beginning of a range that is in the list, and every element not
6258  * divisible by two marks the beginning of a range not in the list.  A single
6259  * element inversion list that contains the single code point N generally
6260  * consists of two elements
6261  *  invlist[0] == N
6262  *  invlist[1] == N+1
6263  * (The exception is when N is the highest representable value on the
6264  * machine, in which case the list containing just it would be a single
6265  * element, itself.  By extension, if the last range in the list extends to
6266  * infinity, then the first element of that range will be in the inversion list
6267  * at a position that is divisible by two, and is the final element in the
6268  * list.)
6269  * Taking the complement (inverting) an inversion list is quite simple, if the
6270  * first element is 0, remove it; otherwise add a 0 element at the beginning.
6271  * This implementation reserves an element at the beginning of each inversion list
6272  * to contain 0 when the list contains 0, and contains 1 otherwise.  The actual
6273  * beginning of the list is either that element if 0, or the next one if 1.
6274  *
6275  * More about inversion lists can be found in "Unicode Demystified"
6276  * Chapter 13 by Richard Gillam, published by Addison-Wesley.
6277  * More will be coming when functionality is added later.
6278  *
6279  * The inversion list data structure is currently implemented as an SV pointing
6280  * to an array of UVs that the SV thinks are bytes.  This allows us to have an
6281  * array of UV whose memory management is automatically handled by the existing
6282  * facilities for SV's.
6283  *
6284  * Some of the methods should always be private to the implementation, and some
6285  * should eventually be made public */
6286
6287 #define INVLIST_LEN_OFFSET 0 /* Number of elements in the inversion list */
6288 #define INVLIST_ITER_OFFSET 1 /* Current iteration position */
6289
6290 /* This is a combination of a version and data structure type, so that one
6291  * being passed in can be validated to be an inversion list of the correct
6292  * vintage.  When the structure of the header is changed, a new random number
6293  * in the range 2**31-1 should be generated and the new() method changed to
6294  * insert that at this location.  Then, if an auxiliary program doesn't change
6295  * correspondingly, it will be discovered immediately */
6296 #define INVLIST_VERSION_ID_OFFSET 2
6297 #define INVLIST_VERSION_ID 1064334010
6298
6299 /* For safety, when adding new elements, remember to #undef them at the end of
6300  * the inversion list code section */
6301
6302 #define INVLIST_ZERO_OFFSET 3 /* 0 or 1; must be last element in header */
6303 /* The UV at position ZERO contains either 0 or 1.  If 0, the inversion list
6304  * contains the code point U+00000, and begins here.  If 1, the inversion list
6305  * doesn't contain U+0000, and it begins at the next UV in the array.
6306  * Inverting an inversion list consists of adding or removing the 0 at the
6307  * beginning of it.  By reserving a space for that 0, inversion can be made
6308  * very fast */
6309
6310 #define HEADER_LENGTH (INVLIST_ZERO_OFFSET + 1)
6311
6312 /* Internally things are UVs */
6313 #define TO_INTERNAL_SIZE(x) ((x + HEADER_LENGTH) * sizeof(UV))
6314 #define FROM_INTERNAL_SIZE(x) ((x / sizeof(UV)) - HEADER_LENGTH)
6315
6316 #define INVLIST_INITIAL_LEN 10
6317
6318 PERL_STATIC_INLINE UV*
6319 S__invlist_array_init(pTHX_ SV* const invlist, const bool will_have_0)
6320 {
6321  /* Returns a pointer to the first element in the inversion list's array.
6322  * This is called upon initialization of an inversion list.  Where the
6323  * array begins depends on whether the list has the code point U+0000
6324  * in it or not.  The other parameter tells it whether the code that
6325  * follows this call is about to put a 0 in the inversion list or not.
6326  * The first element is either the element with 0, if 0, or the next one,
6327  * if 1 */
6328
6329  UV* zero = get_invlist_zero_addr(invlist);
6330
6331  PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
6332
6333  /* Must be empty */
6334  assert(! *get_invlist_len_addr(invlist));
6335
6336  /* 1^1 = 0; 1^0 = 1 */
6337  *zero = 1 ^ will_have_0;
6338  return zero + *zero;
6339 }
6340
6341 PERL_STATIC_INLINE UV*
6342 S_invlist_array(pTHX_ SV* const invlist)
6343 {
6344  /* Returns the pointer to the inversion list's array.  Every time the
6345  * length changes, this needs to be called in case malloc or realloc moved
6346  * it */
6347
6348  PERL_ARGS_ASSERT_INVLIST_ARRAY;
6349
6350  /* Must not be empty.  If these fail, you probably didn't check for <len>
6351  * being non-zero before trying to get the array */
6352  assert(*get_invlist_len_addr(invlist));
6353  assert(*get_invlist_zero_addr(invlist) == 0
6354   || *get_invlist_zero_addr(invlist) == 1);
6355
6356  /* The array begins either at the element reserved for zero if the
6357  * list contains 0 (that element will be set to 0), or otherwise the next
6358  * element (in which case the reserved element will be set to 1). */
6359  return (UV *) (get_invlist_zero_addr(invlist)
6360     + *get_invlist_zero_addr(invlist));
6361 }
6362
6363 PERL_STATIC_INLINE UV*
6364 S_get_invlist_len_addr(pTHX_ SV* invlist)
6365 {
6366  /* Return the address of the UV that contains the current number
6367  * of used elements in the inversion list */
6368
6369  PERL_ARGS_ASSERT_GET_INVLIST_LEN_ADDR;
6370
6371  return (UV *) (SvPVX(invlist) + (INVLIST_LEN_OFFSET * sizeof (UV)));
6372 }
6373
6374 PERL_STATIC_INLINE UV
6375 S_invlist_len(pTHX_ SV* const invlist)
6376 {
6377  /* Returns the current number of elements stored in the inversion list's
6378  * array */
6379
6380  PERL_ARGS_ASSERT_INVLIST_LEN;
6381
6382  return *get_invlist_len_addr(invlist);
6383 }
6384
6385 PERL_STATIC_INLINE void
6386 S_invlist_set_len(pTHX_ SV* const invlist, const UV len)
6387 {
6388  /* Sets the current number of elements stored in the inversion list */
6389
6390  PERL_ARGS_ASSERT_INVLIST_SET_LEN;
6391
6392  *get_invlist_len_addr(invlist) = len;
6393
6394  assert(len <= SvLEN(invlist));
6395
6396  SvCUR_set(invlist, TO_INTERNAL_SIZE(len));
6397  /* If the list contains U+0000, that element is part of the header,
6398  * and should not be counted as part of the array.  It will contain
6399  * 0 in that case, and 1 otherwise.  So we could flop 0=>1, 1=>0 and
6400  * subtract:
6401  * SvCUR_set(invlist,
6402  *    TO_INTERNAL_SIZE(len
6403  *       - (*get_invlist_zero_addr(inv_list) ^ 1)));
6404  * But, this is only valid if len is not 0.  The consequences of not doing
6405  * this is that the memory allocation code may think that 1 more UV is
6406  * being used than actually is, and so might do an unnecessary grow.  That
6407  * seems worth not bothering to make this the precise amount.
6408  *
6409  * Note that when inverting, SvCUR shouldn't change */
6410 }
6411
6412 PERL_STATIC_INLINE UV
6413 S_invlist_max(pTHX_ SV* const invlist)
6414 {
6415  /* Returns the maximum number of elements storable in the inversion list's
6416  * array, without having to realloc() */
6417
6418  PERL_ARGS_ASSERT_INVLIST_MAX;
6419
6420  return FROM_INTERNAL_SIZE(SvLEN(invlist));
6421 }
6422
6423 PERL_STATIC_INLINE UV*
6424 S_get_invlist_zero_addr(pTHX_ SV* invlist)
6425 {
6426  /* Return the address of the UV that is reserved to hold 0 if the inversion
6427  * list contains 0.  This has to be the last element of the heading, as the
6428  * list proper starts with either it if 0, or the next element if not.
6429  * (But we force it to contain either 0 or 1) */
6430
6431  PERL_ARGS_ASSERT_GET_INVLIST_ZERO_ADDR;
6432
6433  return (UV *) (SvPVX(invlist) + (INVLIST_ZERO_OFFSET * sizeof (UV)));
6434 }
6435
6436 #ifndef PERL_IN_XSUB_RE
6437 SV*
6438 Perl__new_invlist(pTHX_ IV initial_size)
6439 {
6440
6441  /* Return a pointer to a newly constructed inversion list, with enough
6442  * space to store 'initial_size' elements.  If that number is negative, a
6443  * system default is used instead */
6444
6445  SV* new_list;
6446
6447  if (initial_size < 0) {
6448   initial_size = INVLIST_INITIAL_LEN;
6449  }
6450
6451  /* Allocate the initial space */
6452  new_list = newSV(TO_INTERNAL_SIZE(initial_size));
6453  invlist_set_len(new_list, 0);
6454
6455  /* Force iterinit() to be used to get iteration to work */
6456  *get_invlist_iter_addr(new_list) = UV_MAX;
6457
6458  /* This should force a segfault if a method doesn't initialize this
6459  * properly */
6460  *get_invlist_zero_addr(new_list) = UV_MAX;
6461
6462  *get_invlist_version_id_addr(new_list) = INVLIST_VERSION_ID;
6463 #if HEADER_LENGTH != 4
6464 #   error Need to regenerate VERSION_ID by running perl -E 'say int(rand 2**31-1)', and then changing the #if to the new length
6465 #endif
6466
6467  return new_list;
6468 }
6469 #endif
6470
6471 STATIC SV*
6472 S__new_invlist_C_array(pTHX_ UV* list)
6473 {
6474  /* Return a pointer to a newly constructed inversion list, initialized to
6475  * point to <list>, which has to be in the exact correct inversion list
6476  * form, including internal fields.  Thus this is a dangerous routine that
6477  * should not be used in the wrong hands */
6478
6479  SV* invlist = newSV_type(SVt_PV);
6480
6481  PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY;
6482
6483  SvPV_set(invlist, (char *) list);
6484  SvLEN_set(invlist, 0);  /* Means we own the contents, and the system
6485        shouldn't touch it */
6486  SvCUR_set(invlist, TO_INTERNAL_SIZE(invlist_len(invlist)));
6487
6488  if (*get_invlist_version_id_addr(invlist) != INVLIST_VERSION_ID) {
6489   Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list");
6490  }
6491
6492  return invlist;
6493 }
6494
6495 STATIC void
6496 S_invlist_extend(pTHX_ SV* const invlist, const UV new_max)
6497 {
6498  /* Grow the maximum size of an inversion list */
6499
6500  PERL_ARGS_ASSERT_INVLIST_EXTEND;
6501
6502  SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max));
6503 }
6504
6505 PERL_STATIC_INLINE void
6506 S_invlist_trim(pTHX_ SV* const invlist)
6507 {
6508  PERL_ARGS_ASSERT_INVLIST_TRIM;
6509
6510  /* Change the length of the inversion list to how many entries it currently
6511  * has */
6512
6513  SvPV_shrink_to_cur((SV *) invlist);
6514 }
6515
6516 /* An element is in an inversion list iff its index is even numbered: 0, 2, 4,
6517  * etc */
6518 #define ELEMENT_RANGE_MATCHES_INVLIST(i) (! ((i) & 1))
6519 #define PREV_RANGE_MATCHES_INVLIST(i) (! ELEMENT_RANGE_MATCHES_INVLIST(i))
6520
6521 #define _invlist_union_complement_2nd(a, b, output) _invlist_union_maybe_complement_2nd(a, b, TRUE, output)
6522
6523 STATIC void
6524 S__append_range_to_invlist(pTHX_ SV* const invlist, const UV start, const UV end)
6525 {
6526    /* Subject to change or removal.  Append the range from 'start' to 'end' at
6527  * the end of the inversion list.  The range must be above any existing
6528  * ones. */
6529
6530  UV* array;
6531  UV max = invlist_max(invlist);
6532  UV len = invlist_len(invlist);
6533
6534  PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
6535
6536  if (len == 0) { /* Empty lists must be initialized */
6537   array = _invlist_array_init(invlist, start == 0);
6538  }
6539  else {
6540   /* Here, the existing list is non-empty. The current max entry in the
6541   * list is generally the first value not in the set, except when the
6542   * set extends to the end of permissible values, in which case it is
6543   * the first entry in that final set, and so this call is an attempt to
6544   * append out-of-order */
6545
6546   UV final_element = len - 1;
6547   array = invlist_array(invlist);
6548   if (array[final_element] > start
6549    || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
6550   {
6551    Perl_croak(aTHX_ "panic: attempting to append to an inversion list, but wasn't at the end of the list, final=%"UVuf", start=%"UVuf", match=%c",
6552      array[final_element], start,
6553      ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
6554   }
6555
6556   /* Here, it is a legal append.  If the new range begins with the first
6557   * value not in the set, it is extending the set, so the new first
6558   * value not in the set is one greater than the newly extended range.
6559   * */
6560   if (array[final_element] == start) {
6561    if (end != UV_MAX) {
6562     array[final_element] = end + 1;
6563    }
6564    else {
6565     /* But if the end is the maximum representable on the machine,
6566     * just let the range that this would extend to have no end */
6567     invlist_set_len(invlist, len - 1);
6568    }
6569    return;
6570   }
6571  }
6572
6573  /* Here the new range doesn't extend any existing set.  Add it */
6574
6575  len += 2; /* Includes an element each for the start and end of range */
6576
6577  /* If overflows the existing space, extend, which may cause the array to be
6578  * moved */
6579  if (max < len) {
6580   invlist_extend(invlist, len);
6581   invlist_set_len(invlist, len); /* Have to set len here to avoid assert
6582           failure in invlist_array() */
6583   array = invlist_array(invlist);
6584  }
6585  else {
6586   invlist_set_len(invlist, len);
6587  }
6588
6589  /* The next item on the list starts the range, the one after that is
6590  * one past the new range.  */
6591  array[len - 2] = start;
6592  if (end != UV_MAX) {
6593   array[len - 1] = end + 1;
6594  }
6595  else {
6596   /* But if the end is the maximum representable on the machine, just let
6597   * the range have no end */
6598   invlist_set_len(invlist, len - 1);
6599  }
6600 }
6601
6602 #ifndef PERL_IN_XSUB_RE
6603
6604 STATIC IV
6605 S_invlist_search(pTHX_ SV* const invlist, const UV cp)
6606 {
6607  /* Searches the inversion list for the entry that contains the input code
6608  * point <cp>.  If <cp> is not in the list, -1 is returned.  Otherwise, the
6609  * return value is the index into the list's array of the range that
6610  * contains <cp> */
6611
6612  IV low = 0;
6613  IV high = invlist_len(invlist);
6614  const UV * const array = invlist_array(invlist);
6615
6616  PERL_ARGS_ASSERT_INVLIST_SEARCH;
6617
6618  /* If list is empty or the code point is before the first element, return
6619  * failure. */
6620  if (high == 0 || cp < array[0]) {
6621   return -1;
6622  }
6623
6624  /* Binary search.  What we are looking for is <i> such that
6625  * array[i] <= cp < array[i+1]
6626  * The loop below converges on the i+1. */
6627  while (low < high) {
6628   IV mid = (low + high) / 2;
6629   if (array[mid] <= cp) {
6630    low = mid + 1;
6631
6632    /* We could do this extra test to exit the loop early.
6633    if (cp < array[low]) {
6634     return mid;
6635    }
6636    */
6637   }
6638   else { /* cp < array[mid] */
6639    high = mid;
6640   }
6641  }
6642
6643  return high - 1;
6644 }
6645
6646 void
6647 Perl__invlist_populate_swatch(pTHX_ SV* const invlist, const UV start, const UV end, U8* swatch)
6648 {
6649  /* populates a swatch of a swash the same way swatch_get() does in utf8.c,
6650  * but is used when the swash has an inversion list.  This makes this much
6651  * faster, as it uses a binary search instead of a linear one.  This is
6652  * intimately tied to that function, and perhaps should be in utf8.c,
6653  * except it is intimately tied to inversion lists as well.  It assumes
6654  * that <swatch> is all 0's on input */
6655
6656  UV current = start;
6657  const IV len = invlist_len(invlist);
6658  IV i;
6659  const UV * array;
6660
6661  PERL_ARGS_ASSERT__INVLIST_POPULATE_SWATCH;
6662
6663  if (len == 0) { /* Empty inversion list */
6664   return;
6665  }
6666
6667  array = invlist_array(invlist);
6668
6669  /* Find which element it is */
6670  i = invlist_search(invlist, start);
6671
6672  /* We populate from <start> to <end> */
6673  while (current < end) {
6674   UV upper;
6675
6676   /* The inversion list gives the results for every possible code point
6677   * after the first one in the list.  Only those ranges whose index is
6678   * even are ones that the inversion list matches.  For the odd ones,
6679   * and if the initial code point is not in the list, we have to skip
6680   * forward to the next element */
6681   if (i == -1 || ! ELEMENT_RANGE_MATCHES_INVLIST(i)) {
6682    i++;
6683    if (i >= len) { /* Finished if beyond the end of the array */
6684     return;
6685    }
6686    current = array[i];
6687    if (current >= end) {   /* Finished if beyond the end of what we
6688          are populating */
6689     return;
6690    }
6691   }
6692   assert(current >= start);
6693
6694   /* The current range ends one below the next one, except don't go past
6695   * <end> */
6696   i++;
6697   upper = (i < len && array[i] < end) ? array[i] : end;
6698
6699   /* Here we are in a range that matches.  Populate a bit in the 3-bit U8
6700   * for each code point in it */
6701   for (; current < upper; current++) {
6702    const STRLEN offset = (STRLEN)(current - start);
6703    swatch[offset >> 3] |= 1 << (offset & 7);
6704   }
6705
6706   /* Quit if at the end of the list */
6707   if (i >= len) {
6708
6709    /* But first, have to deal with the highest possible code point on
6710    * the platform.  The previous code assumes that <end> is one
6711    * beyond where we want to populate, but that is impossible at the
6712    * platform's infinity, so have to handle it specially */
6713    if (UNLIKELY(end == UV_MAX && ELEMENT_RANGE_MATCHES_INVLIST(len-1)))
6714    {
6715     const STRLEN offset = (STRLEN)(end - start);
6716     swatch[offset >> 3] |= 1 << (offset & 7);
6717    }
6718    return;
6719   }
6720
6721   /* Advance to the next range, which will be for code points not in the
6722   * inversion list */
6723   current = array[i];
6724  }
6725
6726  return;
6727 }
6728
6729
6730 void
6731 Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, bool complement_b, SV** output)
6732 {
6733  /* Take the union of two inversion lists and point <output> to it.  *output
6734  * should be defined upon input, and if it points to one of the two lists,
6735  * the reference count to that list will be decremented.  The first list,
6736  * <a>, may be NULL, in which case a copy of the second list is returned.
6737  * If <complement_b> is TRUE, the union is taken of the complement
6738  * (inversion) of <b> instead of b itself.
6739  *
6740  * The basis for this comes from "Unicode Demystified" Chapter 13 by
6741  * Richard Gillam, published by Addison-Wesley, and explained at some
6742  * length there.  The preface says to incorporate its examples into your
6743  * code at your own risk.
6744  *
6745  * The algorithm is like a merge sort.
6746  *
6747  * XXX A potential performance improvement is to keep track as we go along
6748  * if only one of the inputs contributes to the result, meaning the other
6749  * is a subset of that one.  In that case, we can skip the final copy and
6750  * return the larger of the input lists, but then outside code might need
6751  * to keep track of whether to free the input list or not */
6752
6753  UV* array_a;    /* a's array */
6754  UV* array_b;
6755  UV len_a;     /* length of a's array */
6756  UV len_b;
6757
6758  SV* u;   /* the resulting union */
6759  UV* array_u;
6760  UV len_u;
6761
6762  UV i_a = 0;      /* current index into a's array */
6763  UV i_b = 0;
6764  UV i_u = 0;
6765
6766  /* running count, as explained in the algorithm source book; items are
6767  * stopped accumulating and are output when the count changes to/from 0.
6768  * The count is incremented when we start a range that's in the set, and
6769  * decremented when we start a range that's not in the set.  So its range
6770  * is 0 to 2.  Only when the count is zero is something not in the set.
6771  */
6772  UV count = 0;
6773
6774  PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
6775  assert(a != b);
6776
6777  /* If either one is empty, the union is the other one */
6778  if (a == NULL || ((len_a = invlist_len(a)) == 0)) {
6779   if (*output == a) {
6780    if (a != NULL) {
6781     SvREFCNT_dec(a);
6782    }
6783   }
6784   if (*output != b) {
6785    *output = invlist_clone(b);
6786    if (complement_b) {
6787     _invlist_invert(*output);
6788    }
6789   } /* else *output already = b; */
6790   return;
6791  }
6792  else if ((len_b = invlist_len(b)) == 0) {
6793   if (*output == b) {
6794    SvREFCNT_dec(b);
6795   }
6796
6797   /* The complement of an empty list is a list that has everything in it,
6798   * so the union with <a> includes everything too */
6799   if (complement_b) {
6800    if (a == *output) {
6801     SvREFCNT_dec(a);
6802    }
6803    *output = _new_invlist(1);
6804    _append_range_to_invlist(*output, 0, UV_MAX);
6805   }
6806   else if (*output != a) {
6807    *output = invlist_clone(a);
6808   }
6809   /* else *output already = a; */
6810   return;
6811  }
6812
6813  /* Here both lists exist and are non-empty */
6814  array_a = invlist_array(a);
6815  array_b = invlist_array(b);
6816
6817  /* If are to take the union of 'a' with the complement of b, set it
6818  * up so are looking at b's complement. */
6819  if (complement_b) {
6820
6821   /* To complement, we invert: if the first element is 0, remove it.  To
6822   * do this, we just pretend the array starts one later, and clear the
6823   * flag as we don't have to do anything else later */
6824   if (array_b[0] == 0) {
6825    array_b++;
6826    len_b--;
6827    complement_b = FALSE;
6828   }
6829   else {
6830
6831    /* But if the first element is not zero, we unshift a 0 before the
6832    * array.  The data structure reserves a space for that 0 (which
6833    * should be a '1' right now), so physical shifting is unneeded,
6834    * but temporarily change that element to 0.  Before exiting the
6835    * routine, we must restore the element to '1' */
6836    array_b--;
6837    len_b++;
6838    array_b[0] = 0;
6839   }
6840  }
6841
6842  /* Size the union for the worst case: that the sets are completely
6843  * disjoint */
6844  u = _new_invlist(len_a + len_b);
6845
6846  /* Will contain U+0000 if either component does */
6847  array_u = _invlist_array_init(u, (len_a > 0 && array_a[0] == 0)
6848          || (len_b > 0 && array_b[0] == 0));
6849
6850  /* Go through each list item by item, stopping when exhausted one of
6851  * them */
6852  while (i_a < len_a && i_b < len_b) {
6853   UV cp;     /* The element to potentially add to the union's array */
6854   bool cp_in_set;   /* is it in the the input list's set or not */
6855
6856   /* We need to take one or the other of the two inputs for the union.
6857   * Since we are merging two sorted lists, we take the smaller of the
6858   * next items.  In case of a tie, we take the one that is in its set
6859   * first.  If we took one not in the set first, it would decrement the
6860   * count, possibly to 0 which would cause it to be output as ending the
6861   * range, and the next time through we would take the same number, and
6862   * output it again as beginning the next range.  By doing it the
6863   * opposite way, there is no possibility that the count will be
6864   * momentarily decremented to 0, and thus the two adjoining ranges will
6865   * be seamlessly merged.  (In a tie and both are in the set or both not
6866   * in the set, it doesn't matter which we take first.) */
6867   if (array_a[i_a] < array_b[i_b]
6868    || (array_a[i_a] == array_b[i_b]
6869     && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
6870   {
6871    cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
6872    cp= array_a[i_a++];
6873   }
6874   else {
6875    cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
6876    cp= array_b[i_b++];
6877   }
6878
6879   /* Here, have chosen which of the two inputs to look at.  Only output
6880   * if the running count changes to/from 0, which marks the
6881   * beginning/end of a range in that's in the set */
6882   if (cp_in_set) {
6883    if (count == 0) {
6884     array_u[i_u++] = cp;
6885    }
6886    count++;
6887   }
6888   else {
6889    count--;
6890    if (count == 0) {
6891     array_u[i_u++] = cp;
6892    }
6893   }
6894  }
6895
6896  /* Here, we are finished going through at least one of the lists, which
6897  * means there is something remaining in at most one.  We check if the list
6898  * that hasn't been exhausted is positioned such that we are in the middle
6899  * of a range in its set or not.  (i_a and i_b point to the element beyond
6900  * the one we care about.) If in the set, we decrement 'count'; if 0, there
6901  * is potentially more to output.
6902  * There are four cases:
6903  * 1) Both weren't in their sets, count is 0, and remains 0.  What's left
6904  *    in the union is entirely from the non-exhausted set.
6905  * 2) Both were in their sets, count is 2.  Nothing further should
6906  *    be output, as everything that remains will be in the exhausted
6907  *    list's set, hence in the union; decrementing to 1 but not 0 insures
6908  *    that
6909  * 3) the exhausted was in its set, non-exhausted isn't, count is 1.
6910  *    Nothing further should be output because the union includes
6911  *    everything from the exhausted set.  Not decrementing ensures that.
6912  * 4) the exhausted wasn't in its set, non-exhausted is, count is 1;
6913  *    decrementing to 0 insures that we look at the remainder of the
6914  *    non-exhausted set */
6915  if ((i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
6916   || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
6917  {
6918   count--;
6919  }
6920
6921  /* The final length is what we've output so far, plus what else is about to
6922  * be output.  (If 'count' is non-zero, then the input list we exhausted
6923  * has everything remaining up to the machine's limit in its set, and hence
6924  * in the union, so there will be no further output. */
6925  len_u = i_u;
6926  if (count == 0) {
6927   /* At most one of the subexpressions will be non-zero */
6928   len_u += (len_a - i_a) + (len_b - i_b);
6929  }
6930
6931  /* Set result to final length, which can change the pointer to array_u, so
6932  * re-find it */
6933  if (len_u != invlist_len(u)) {
6934   invlist_set_len(u, len_u);
6935   invlist_trim(u);
6936   array_u = invlist_array(u);
6937  }
6938
6939  /* When 'count' is 0, the list that was exhausted (if one was shorter than
6940  * the other) ended with everything above it not in its set.  That means
6941  * that the remaining part of the union is precisely the same as the
6942  * non-exhausted list, so can just copy it unchanged.  (If both list were
6943  * exhausted at the same time, then the operations below will be both 0.)
6944  */
6945  if (count == 0) {
6946   IV copy_count; /* At most one will have a non-zero copy count */
6947   if ((copy_count = len_a - i_a) > 0) {
6948    Copy(array_a + i_a, array_u + i_u, copy_count, UV);
6949   }
6950   else if ((copy_count = len_b - i_b) > 0) {
6951    Copy(array_b + i_b, array_u + i_u, copy_count, UV);
6952   }
6953  }
6954
6955  /*  We may be removing a reference to one of the inputs */
6956  if (a == *output || b == *output) {
6957   SvREFCNT_dec(*output);
6958  }
6959
6960  /* If we've changed b, restore it */
6961  if (complement_b) {
6962   array_b[0] = 1;
6963  }
6964
6965  *output = u;
6966  return;
6967 }
6968
6969 void
6970 Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, bool complement_b, SV** i)
6971 {
6972  /* Take the intersection of two inversion lists and point <i> to it.  *i
6973  * should be defined upon input, and if it points to one of the two lists,
6974  * the reference count to that list will be decremented.
6975  * If <complement_b> is TRUE, the result will be the intersection of <a>
6976  * and the complement (or inversion) of <b> instead of <b> directly.
6977  *
6978  * The basis for this comes from "Unicode Demystified" Chapter 13 by
6979  * Richard Gillam, published by Addison-Wesley, and explained at some
6980  * length there.  The preface says to incorporate its examples into your
6981  * code at your own risk.  In fact, it had bugs
6982  *
6983  * The algorithm is like a merge sort, and is essentially the same as the
6984  * union above
6985  */
6986
6987  UV* array_a;  /* a's array */
6988  UV* array_b;
6989  UV len_a; /* length of a's array */
6990  UV len_b;
6991
6992  SV* r;       /* the resulting intersection */
6993  UV* array_r;
6994  UV len_r;
6995
6996  UV i_a = 0;      /* current index into a's array */
6997  UV i_b = 0;
6998  UV i_r = 0;
6999
7000  /* running count, as explained in the algorithm source book; items are
7001  * stopped accumulating and are output when the count changes to/from 2.
7002  * The count is incremented when we start a range that's in the set, and
7003  * decremented when we start a range that's not in the set.  So its range
7004  * is 0 to 2.  Only when the count is 2 is something in the intersection.
7005  */
7006  UV count = 0;
7007
7008  PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
7009  assert(a != b);
7010
7011  /* Special case if either one is empty */
7012  len_a = invlist_len(a);
7013  if ((len_a == 0) || ((len_b = invlist_len(b)) == 0)) {
7014
7015   if (len_a != 0 && complement_b) {
7016
7017    /* Here, 'a' is not empty, therefore from the above 'if', 'b' must
7018    * be empty.  Here, also we are using 'b's complement, which hence
7019    * must be every possible code point.  Thus the intersection is
7020    * simply 'a'. */
7021    if (*i != a) {
7022     *i = invlist_clone(a);
7023
7024     if (*i == b) {
7025      SvREFCNT_dec(b);
7026     }
7027    }
7028    /* else *i is already 'a' */
7029    return;
7030   }
7031
7032   /* Here, 'a' or 'b' is empty and not using the complement of 'b'.  The
7033   * intersection must be empty */
7034   if (*i == a) {
7035    SvREFCNT_dec(a);
7036   }
7037   else if (*i == b) {
7038    SvREFCNT_dec(b);
7039   }
7040   *i = _new_invlist(0);
7041   return;
7042  }
7043
7044  /* Here both lists exist and are non-empty */
7045  array_a = invlist_array(a);
7046  array_b = invlist_array(b);
7047
7048  /* If are to take the intersection of 'a' with the complement of b, set it
7049  * up so are looking at b's complement. */
7050  if (complement_b) {
7051
7052   /* To complement, we invert: if the first element is 0, remove it.  To
7053   * do this, we just pretend the array starts one later, and clear the
7054   * flag as we don't have to do anything else later */
7055   if (array_b[0] == 0) {
7056    array_b++;
7057    len_b--;
7058    complement_b = FALSE;
7059   }
7060   else {
7061
7062    /* But if the first element is not zero, we unshift a 0 before the
7063    * array.  The data structure reserves a space for that 0 (which
7064    * should be a '1' right now), so physical shifting is unneeded,
7065    * but temporarily change that element to 0.  Before exiting the
7066    * routine, we must restore the element to '1' */
7067    array_b--;
7068    len_b++;
7069    array_b[0] = 0;
7070   }
7071  }
7072
7073  /* Size the intersection for the worst case: that the intersection ends up
7074  * fragmenting everything to be completely disjoint */
7075  r= _new_invlist(len_a + len_b);
7076
7077  /* Will contain U+0000 iff both components do */
7078  array_r = _invlist_array_init(r, len_a > 0 && array_a[0] == 0
7079          && len_b > 0 && array_b[0] == 0);
7080
7081  /* Go through each list item by item, stopping when exhausted one of
7082  * them */
7083  while (i_a < len_a && i_b < len_b) {
7084   UV cp;     /* The element to potentially add to the intersection's
7085      array */
7086   bool cp_in_set; /* Is it in the input list's set or not */
7087
7088   /* We need to take one or the other of the two inputs for the
7089   * intersection.  Since we are merging two sorted lists, we take the
7090   * smaller of the next items.  In case of a tie, we take the one that
7091   * is not in its set first (a difference from the union algorithm).  If
7092   * we took one in the set first, it would increment the count, possibly
7093   * to 2 which would cause it to be output as starting a range in the
7094   * intersection, and the next time through we would take that same
7095   * number, and output it again as ending the set.  By doing it the
7096   * opposite of this, there is no possibility that the count will be
7097   * momentarily incremented to 2.  (In a tie and both are in the set or
7098   * both not in the set, it doesn't matter which we take first.) */
7099   if (array_a[i_a] < array_b[i_b]
7100    || (array_a[i_a] == array_b[i_b]
7101     && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
7102   {
7103    cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
7104    cp= array_a[i_a++];
7105   }
7106   else {
7107    cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
7108    cp= array_b[i_b++];
7109   }
7110
7111   /* Here, have chosen which of the two inputs to look at.  Only output
7112   * if the running count changes to/from 2, which marks the
7113   * beginning/end of a range that's in the intersection */
7114   if (cp_in_set) {
7115    count++;
7116    if (count == 2) {
7117     array_r[i_r++] = cp;
7118    }
7119   }
7120   else {
7121    if (count == 2) {
7122     array_r[i_r++] = cp;
7123    }
7124    count--;
7125   }
7126  }
7127
7128  /* Here, we are finished going through at least one of the lists, which
7129  * means there is something remaining in at most one.  We check if the list
7130  * that has been exhausted is positioned such that we are in the middle
7131  * of a range in its set or not.  (i_a and i_b point to elements 1 beyond
7132  * the ones we care about.)  There are four cases:
7133  * 1) Both weren't in their sets, count is 0, and remains 0.  There's
7134  *    nothing left in the intersection.
7135  * 2) Both were in their sets, count is 2 and perhaps is incremented to
7136  *    above 2.  What should be output is exactly that which is in the
7137  *    non-exhausted set, as everything it has is also in the intersection
7138  *    set, and everything it doesn't have can't be in the intersection
7139  * 3) The exhausted was in its set, non-exhausted isn't, count is 1, and
7140  *    gets incremented to 2.  Like the previous case, the intersection is
7141  *    everything that remains in the non-exhausted set.
7142  * 4) the exhausted wasn't in its set, non-exhausted is, count is 1, and
7143  *    remains 1.  And the intersection has nothing more. */
7144  if ((i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
7145   || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
7146  {
7147   count++;
7148  }
7149
7150  /* The final length is what we've output so far plus what else is in the
7151  * intersection.  At most one of the subexpressions below will be non-zero */
7152  len_r = i_r;
7153  if (count >= 2) {
7154   len_r += (len_a - i_a) + (len_b - i_b);
7155  }
7156
7157  /* Set result to final length, which can change the pointer to array_r, so
7158  * re-find it */
7159  if (len_r != invlist_len(r)) {
7160   invlist_set_len(r, len_r);
7161   invlist_trim(r);
7162   array_r = invlist_array(r);
7163  }
7164
7165  /* Finish outputting any remaining */
7166  if (count >= 2) { /* At most one will have a non-zero copy count */
7167   IV copy_count;
7168   if ((copy_count = len_a - i_a) > 0) {
7169    Copy(array_a + i_a, array_r + i_r, copy_count, UV);
7170   }
7171   else if ((copy_count = len_b - i_b) > 0) {
7172    Copy(array_b + i_b, array_r + i_r, copy_count, UV);
7173   }
7174  }
7175
7176  /*  We may be removing a reference to one of the inputs */
7177  if (a == *i || b == *i) {
7178   SvREFCNT_dec(*i);
7179  }
7180
7181  /* If we've changed b, restore it */
7182  if (complement_b) {
7183   array_b[0] = 1;
7184  }
7185
7186  *i = r;
7187  return;
7188 }
7189
7190 SV*
7191 Perl__add_range_to_invlist(pTHX_ SV* invlist, const UV start, const UV end)
7192 {
7193  /* Add the range from 'start' to 'end' inclusive to the inversion list's
7194  * set.  A pointer to the inversion list is returned.  This may actually be
7195  * a new list, in which case the passed in one has been destroyed.  The
7196  * passed in inversion list can be NULL, in which case a new one is created
7197  * with just the one range in it */
7198
7199  SV* range_invlist;
7200  UV len;
7201
7202  if (invlist == NULL) {
7203   invlist = _new_invlist(2);
7204   len = 0;
7205  }
7206  else {
7207   len = invlist_len(invlist);
7208  }
7209
7210  /* If comes after the final entry, can just append it to the end */
7211  if (len == 0
7212   || start >= invlist_array(invlist)
7213          [invlist_len(invlist) - 1])
7214  {
7215   _append_range_to_invlist(invlist, start, end);
7216   return invlist;
7217  }
7218
7219  /* Here, can't just append things, create and return a new inversion list
7220  * which is the union of this range and the existing inversion list */
7221  range_invlist = _new_invlist(2);
7222  _append_range_to_invlist(range_invlist, start, end);
7223
7224  _invlist_union(invlist, range_invlist, &invlist);
7225
7226  /* The temporary can be freed */
7227  SvREFCNT_dec(range_invlist);
7228
7229  return invlist;
7230 }
7231
7232 #endif
7233
7234 PERL_STATIC_INLINE SV*
7235 S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) {
7236  return _add_range_to_invlist(invlist, cp, cp);
7237 }
7238
7239 #ifndef PERL_IN_XSUB_RE
7240 void
7241 Perl__invlist_invert(pTHX_ SV* const invlist)
7242 {
7243  /* Complement the input inversion list.  This adds a 0 if the list didn't
7244  * have a zero; removes it otherwise.  As described above, the data
7245  * structure is set up so that this is very efficient */
7246
7247  UV* len_pos = get_invlist_len_addr(invlist);
7248
7249  PERL_ARGS_ASSERT__INVLIST_INVERT;
7250
7251  /* The inverse of matching nothing is matching everything */
7252  if (*len_pos == 0) {
7253   _append_range_to_invlist(invlist, 0, UV_MAX);
7254   return;
7255  }
7256
7257  /* The exclusive or complents 0 to 1; and 1 to 0.  If the result is 1, the
7258  * zero element was a 0, so it is being removed, so the length decrements
7259  * by 1; and vice-versa.  SvCUR is unaffected */
7260  if (*get_invlist_zero_addr(invlist) ^= 1) {
7261   (*len_pos)--;
7262  }
7263  else {
7264   (*len_pos)++;
7265  }
7266 }
7267
7268 void
7269 Perl__invlist_invert_prop(pTHX_ SV* const invlist)
7270 {
7271  /* Complement the input inversion list (which must be a Unicode property,
7272  * all of which don't match above the Unicode maximum code point.)  And
7273  * Perl has chosen to not have the inversion match above that either.  This
7274  * adds a 0x110000 if the list didn't end with it, and removes it if it did
7275  */
7276
7277  UV len;
7278  UV* array;
7279
7280  PERL_ARGS_ASSERT__INVLIST_INVERT_PROP;
7281
7282  _invlist_invert(invlist);
7283
7284  len = invlist_len(invlist);
7285
7286  if (len != 0) { /* If empty do nothing */
7287   array = invlist_array(invlist);
7288   if (array[len - 1] != PERL_UNICODE_MAX + 1) {
7289    /* Add 0x110000.  First, grow if necessary */
7290    len++;
7291    if (invlist_max(invlist) < len) {
7292     invlist_extend(invlist, len);
7293     array = invlist_array(invlist);
7294    }
7295    invlist_set_len(invlist, len);
7296    array[len - 1] = PERL_UNICODE_MAX + 1;
7297   }
7298   else {  /* Remove the 0x110000 */
7299    invlist_set_len(invlist, len - 1);
7300   }
7301  }
7302
7303  return;
7304 }
7305 #endif
7306
7307 PERL_STATIC_INLINE SV*
7308 S_invlist_clone(pTHX_ SV* const invlist)
7309 {
7310
7311  /* Return a new inversion list that is a copy of the input one, which is
7312  * unchanged */
7313
7314  /* Need to allocate extra space to accommodate Perl's addition of a
7315  * trailing NUL to SvPV's, since it thinks they are always strings */
7316  SV* new_invlist = _new_invlist(invlist_len(invlist) + 1);
7317  STRLEN length = SvCUR(invlist);
7318
7319  PERL_ARGS_ASSERT_INVLIST_CLONE;
7320
7321  SvCUR_set(new_invlist, length); /* This isn't done automatically */
7322  Copy(SvPVX(invlist), SvPVX(new_invlist), length, char);
7323
7324  return new_invlist;
7325 }
7326
7327 PERL_STATIC_INLINE UV*
7328 S_get_invlist_iter_addr(pTHX_ SV* invlist)
7329 {
7330  /* Return the address of the UV that contains the current iteration
7331  * position */
7332
7333  PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR;
7334
7335  return (UV *) (SvPVX(invlist) + (INVLIST_ITER_OFFSET * sizeof (UV)));
7336 }
7337
7338 PERL_STATIC_INLINE UV*
7339 S_get_invlist_version_id_addr(pTHX_ SV* invlist)
7340 {
7341  /* Return the address of the UV that contains the version id. */
7342
7343  PERL_ARGS_ASSERT_GET_INVLIST_VERSION_ID_ADDR;
7344
7345  return (UV *) (SvPVX(invlist) + (INVLIST_VERSION_ID_OFFSET * sizeof (UV)));
7346 }
7347
7348 PERL_STATIC_INLINE void
7349 S_invlist_iterinit(pTHX_ SV* invlist) /* Initialize iterator for invlist */
7350 {
7351  PERL_ARGS_ASSERT_INVLIST_ITERINIT;
7352
7353  *get_invlist_iter_addr(invlist) = 0;
7354 }
7355
7356 STATIC bool
7357 S_invlist_iternext(pTHX_ SV* invlist, UV* start, UV* end)
7358 {
7359  /* An C<invlist_iterinit> call on <invlist> must be used to set this up.
7360  * This call sets in <*start> and <*end>, the next range in <invlist>.
7361  * Returns <TRUE> if successful and the next call will return the next
7362  * range; <FALSE> if was already at the end of the list.  If the latter,
7363  * <*start> and <*end> are unchanged, and the next call to this function
7364  * will start over at the beginning of the list */
7365
7366  UV* pos = get_invlist_iter_addr(invlist);
7367  UV len = invlist_len(invlist);
7368  UV *array;
7369
7370  PERL_ARGS_ASSERT_INVLIST_ITERNEXT;
7371
7372  if (*pos >= len) {
7373   *pos = UV_MAX; /* Force iternit() to be required next time */
7374   return FALSE;
7375  }
7376
7377  array = invlist_array(invlist);
7378
7379  *start = array[(*pos)++];
7380
7381  if (*pos >= len) {
7382   *end = UV_MAX;
7383  }
7384  else {
7385   *end = array[(*pos)++] - 1;
7386  }
7387
7388  return TRUE;
7389 }
7390
7391 #ifndef PERL_IN_XSUB_RE
7392 SV *
7393 Perl__invlist_contents(pTHX_ SV* const invlist)
7394 {
7395  /* Get the contents of an inversion list into a string SV so that they can
7396  * be printed out.  It uses the format traditionally done for debug tracing
7397  */
7398
7399  UV start, end;
7400  SV* output = newSVpvs("\n");
7401
7402  PERL_ARGS_ASSERT__INVLIST_CONTENTS;
7403
7404  invlist_iterinit(invlist);
7405  while (invlist_iternext(invlist, &start, &end)) {
7406   if (end == UV_MAX) {
7407    Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\tINFINITY\n", start);
7408   }
7409   else if (end != start) {
7410    Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\t%04"UVXf"\n",
7411      start,       end);
7412   }
7413   else {
7414    Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\n", start);
7415   }
7416  }
7417
7418  return output;
7419 }
7420 #endif
7421
7422 #if 0
7423 void
7424 S_invlist_dump(pTHX_ SV* const invlist, const char * const header)
7425 {
7426  /* Dumps out the ranges in an inversion list.  The string 'header'
7427  * if present is output on a line before the first range */
7428
7429  UV start, end;
7430
7431  if (header && strlen(header)) {
7432   PerlIO_printf(Perl_debug_log, "%s\n", header);
7433  }
7434  invlist_iterinit(invlist);
7435  while (invlist_iternext(invlist, &start, &end)) {
7436   if (end == UV_MAX) {
7437    PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. INFINITY\n", start);
7438   }
7439   else {
7440    PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. 0x%04"UVXf"\n", start, end);
7441   }
7442  }
7443 }
7444 #endif
7445
7446 #undef HEADER_LENGTH
7447 #undef INVLIST_INITIAL_LENGTH
7448 #undef TO_INTERNAL_SIZE
7449 #undef FROM_INTERNAL_SIZE
7450 #undef INVLIST_LEN_OFFSET
7451 #undef INVLIST_ZERO_OFFSET
7452 #undef INVLIST_ITER_OFFSET
7453 #undef INVLIST_VERSION_ID
7454
7455 /* End of inversion list object */
7456
7457 /*
7458  - reg - regular expression, i.e. main body or parenthesized thing
7459  *
7460  * Caller must absorb opening parenthesis.
7461  *
7462  * Combining parenthesis handling with the base level of regular expression
7463  * is a trifle forced, but the need to tie the tails of the branches to what
7464  * follows makes it hard to avoid.
7465  */
7466 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
7467 #ifdef DEBUGGING
7468 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
7469 #else
7470 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
7471 #endif
7472
7473 STATIC regnode *
7474 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
7475  /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
7476 {
7477  dVAR;
7478  register regnode *ret;  /* Will be the head of the group. */
7479  register regnode *br;
7480  register regnode *lastbr;
7481  register regnode *ender = NULL;
7482  register I32 parno = 0;
7483  I32 flags;
7484  U32 oregflags = RExC_flags;
7485  bool have_branch = 0;
7486  bool is_open = 0;
7487  I32 freeze_paren = 0;
7488  I32 after_freeze = 0;
7489
7490  /* for (?g), (?gc), and (?o) warnings; warning
7491  about (?c) will warn about (?g) -- japhy    */
7492
7493 #define WASTED_O  0x01
7494 #define WASTED_G  0x02
7495 #define WASTED_C  0x04
7496 #define WASTED_GC (0x02|0x04)
7497  I32 wastedflags = 0x00;
7498
7499  char * parse_start = RExC_parse; /* MJD */
7500  char * const oregcomp_parse = RExC_parse;
7501
7502  GET_RE_DEBUG_FLAGS_DECL;
7503
7504  PERL_ARGS_ASSERT_REG;
7505  DEBUG_PARSE("reg ");
7506
7507  *flagp = 0;    /* Tentatively. */
7508
7509
7510  /* Make an OPEN node, if parenthesized. */
7511  if (paren) {
7512   if ( *RExC_parse == '*') { /* (*VERB:ARG) */
7513    char *start_verb = RExC_parse;
7514    STRLEN verb_len = 0;
7515    char *start_arg = NULL;
7516    unsigned char op = 0;
7517    int argok = 1;
7518    int internal_argval = 0; /* internal_argval is only useful if !argok */
7519    while ( *RExC_parse && *RExC_parse != ')' ) {
7520     if ( *RExC_parse == ':' ) {
7521      start_arg = RExC_parse + 1;
7522      break;
7523     }
7524     RExC_parse++;
7525    }
7526    ++start_verb;
7527    verb_len = RExC_parse - start_verb;
7528    if ( start_arg ) {
7529     RExC_parse++;
7530     while ( *RExC_parse && *RExC_parse != ')' )
7531      RExC_parse++;
7532     if ( *RExC_parse != ')' )
7533      vFAIL("Unterminated verb pattern argument");
7534     if ( RExC_parse == start_arg )
7535      start_arg = NULL;
7536    } else {
7537     if ( *RExC_parse != ')' )
7538      vFAIL("Unterminated verb pattern");
7539    }
7540
7541    switch ( *start_verb ) {
7542    case 'A':  /* (*ACCEPT) */
7543     if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
7544      op = ACCEPT;
7545      internal_argval = RExC_nestroot;
7546     }
7547     break;
7548    case 'C':  /* (*COMMIT) */
7549     if ( memEQs(start_verb,verb_len,"COMMIT") )
7550      op = COMMIT;
7551     break;
7552    case 'F':  /* (*FAIL) */
7553     if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
7554      op = OPFAIL;
7555      argok = 0;
7556     }
7557     break;
7558    case ':':  /* (*:NAME) */
7559    case 'M':  /* (*MARK:NAME) */
7560     if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
7561      op = MARKPOINT;
7562      argok = -1;
7563     }
7564     break;
7565    case 'P':  /* (*PRUNE) */
7566     if ( memEQs(start_verb,verb_len,"PRUNE") )
7567      op = PRUNE;
7568     break;
7569    case 'S':   /* (*SKIP) */
7570     if ( memEQs(start_verb,verb_len,"SKIP") )
7571      op = SKIP;
7572     break;
7573    case 'T':  /* (*THEN) */
7574     /* [19:06] <TimToady> :: is then */
7575     if ( memEQs(start_verb,verb_len,"THEN") ) {
7576      op = CUTGROUP;
7577      RExC_seen |= REG_SEEN_CUTGROUP;
7578     }
7579     break;
7580    }
7581    if ( ! op ) {
7582     RExC_parse++;
7583     vFAIL3("Unknown verb pattern '%.*s'",
7584      verb_len, start_verb);
7585    }
7586    if ( argok ) {
7587     if ( start_arg && internal_argval ) {
7588      vFAIL3("Verb pattern '%.*s' may not have an argument",
7589       verb_len, start_verb);
7590     } else if ( argok < 0 && !start_arg ) {
7591      vFAIL3("Verb pattern '%.*s' has a mandatory argument",
7592       verb_len, start_verb);
7593     } else {
7594      ret = reganode(pRExC_state, op, internal_argval);
7595      if ( ! internal_argval && ! SIZE_ONLY ) {
7596       if (start_arg) {
7597        SV *sv = newSVpvn( start_arg, RExC_parse - start_arg);
7598        ARG(ret) = add_data( pRExC_state, 1, "S" );
7599        RExC_rxi->data->data[ARG(ret)]=(void*)sv;
7600        ret->flags = 0;
7601       } else {
7602        ret->flags = 1;
7603       }
7604      }
7605     }
7606     if (!internal_argval)
7607      RExC_seen |= REG_SEEN_VERBARG;
7608    } else if ( start_arg ) {
7609     vFAIL3("Verb pattern '%.*s' may not have an argument",
7610       verb_len, start_verb);
7611    } else {
7612     ret = reg_node(pRExC_state, op);
7613    }
7614    nextchar(pRExC_state);
7615    return ret;
7616   } else
7617   if (*RExC_parse == '?') { /* (?...) */
7618    bool is_logical = 0;
7619    const char * const seqstart = RExC_parse;
7620    bool has_use_defaults = FALSE;
7621
7622    RExC_parse++;
7623    paren = *RExC_parse++;
7624    ret = NULL;   /* For look-ahead/behind. */
7625    switch (paren) {
7626
7627    case 'P': /* (?P...) variants for those used to PCRE/Python */
7628     paren = *RExC_parse++;
7629     if ( paren == '<')         /* (?P<...>) named capture */
7630      goto named_capture;
7631     else if (paren == '>') {   /* (?P>name) named recursion */
7632      goto named_recursion;
7633     }
7634     else if (paren == '=') {   /* (?P=...)  named backref */
7635      /* this pretty much dupes the code for \k<NAME> in regatom(), if
7636      you change this make sure you change that */
7637      char* name_start = RExC_parse;
7638      U32 num = 0;
7639      SV *sv_dat = reg_scan_name(pRExC_state,
7640       SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
7641      if (RExC_parse == name_start || *RExC_parse != ')')
7642       vFAIL2("Sequence %.3s... not terminated",parse_start);
7643
7644      if (!SIZE_ONLY) {
7645       num = add_data( pRExC_state, 1, "S" );
7646       RExC_rxi->data->data[num]=(void*)sv_dat;
7647       SvREFCNT_inc_simple_void(sv_dat);
7648      }
7649      RExC_sawback = 1;
7650      ret = reganode(pRExC_state,
7651         ((! FOLD)
7652          ? NREF
7653          : (MORE_ASCII_RESTRICTED)
7654          ? NREFFA
7655          : (AT_LEAST_UNI_SEMANTICS)
7656           ? NREFFU
7657           : (LOC)
7658           ? NREFFL
7659           : NREFF),
7660          num);
7661      *flagp |= HASWIDTH;
7662
7663      Set_Node_Offset(ret, parse_start+1);
7664      Set_Node_Cur_Length(ret); /* MJD */
7665
7666      nextchar(pRExC_state);
7667      return ret;
7668     }
7669     RExC_parse++;
7670     vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
7671     /*NOTREACHED*/
7672    case '<':           /* (?<...) */
7673     if (*RExC_parse == '!')
7674      paren = ',';
7675     else if (*RExC_parse != '=')
7676    named_capture:
7677     {               /* (?<...>) */
7678      char *name_start;
7679      SV *svname;
7680      paren= '>';
7681    case '\'':          /* (?'...') */
7682       name_start= RExC_parse;
7683       svname = reg_scan_name(pRExC_state,
7684        SIZE_ONLY ?  /* reverse test from the others */
7685        REG_RSN_RETURN_NAME :
7686        REG_RSN_RETURN_NULL);
7687      if (RExC_parse == name_start) {
7688       RExC_parse++;
7689       vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
7690       /*NOTREACHED*/
7691      }
7692      if (*RExC_parse != paren)
7693       vFAIL2("Sequence (?%c... not terminated",
7694        paren=='>' ? '<' : paren);
7695      if (SIZE_ONLY) {
7696       HE *he_str;
7697       SV *sv_dat = NULL;
7698       if (!svname) /* shouldn't happen */
7699        Perl_croak(aTHX_
7700         "panic: reg_scan_name returned NULL");
7701       if (!RExC_paren_names) {
7702        RExC_paren_names= newHV();
7703        sv_2mortal(MUTABLE_SV(RExC_paren_names));
7704 #ifdef DEBUGGING
7705        RExC_paren_name_list= newAV();
7706        sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
7707 #endif
7708       }
7709       he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
7710       if ( he_str )
7711        sv_dat = HeVAL(he_str);
7712       if ( ! sv_dat ) {
7713        /* croak baby croak */
7714        Perl_croak(aTHX_
7715         "panic: paren_name hash element allocation failed");
7716       } else if ( SvPOK(sv_dat) ) {
7717        /* (?|...) can mean we have dupes so scan to check
7718        its already been stored. Maybe a flag indicating
7719        we are inside such a construct would be useful,
7720        but the arrays are likely to be quite small, so
7721        for now we punt -- dmq */
7722        IV count = SvIV(sv_dat);
7723        I32 *pv = (I32*)SvPVX(sv_dat);
7724        IV i;
7725        for ( i = 0 ; i < count ; i++ ) {
7726         if ( pv[i] == RExC_npar ) {
7727          count = 0;
7728          break;
7729         }
7730        }
7731        if ( count ) {
7732         pv = (I32*)SvGROW(sv_dat, SvCUR(sv_dat) + sizeof(I32)+1);
7733         SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
7734         pv[count] = RExC_npar;
7735         SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
7736        }
7737       } else {
7738        (void)SvUPGRADE(sv_dat,SVt_PVNV);
7739        sv_setpvn(sv_dat, (char *)&(RExC_npar), sizeof(I32));
7740        SvIOK_on(sv_dat);
7741        SvIV_set(sv_dat, 1);
7742       }
7743 #ifdef DEBUGGING
7744       /* Yes this does cause a memory leak in debugging Perls */
7745       if (!av_store(RExC_paren_name_list, RExC_npar, SvREFCNT_inc(svname)))
7746        SvREFCNT_dec(svname);
7747 #endif
7748
7749       /*sv_dump(sv_dat);*/
7750      }
7751      nextchar(pRExC_state);
7752      paren = 1;
7753      goto capturing_parens;
7754     }
7755     RExC_seen |= REG_SEEN_LOOKBEHIND;
7756     RExC_in_lookbehind++;
7757     RExC_parse++;
7758    case '=':           /* (?=...) */
7759     RExC_seen_zerolen++;
7760     break;
7761    case '!':           /* (?!...) */
7762     RExC_seen_zerolen++;
7763     if (*RExC_parse == ')') {
7764      ret=reg_node(pRExC_state, OPFAIL);
7765      nextchar(pRExC_state);
7766      return ret;
7767     }
7768     break;
7769    case '|':           /* (?|...) */
7770     /* branch reset, behave like a (?:...) except that
7771     buffers in alternations share the same numbers */
7772     paren = ':';
7773     after_freeze = freeze_paren = RExC_npar;
7774     break;
7775    case ':':           /* (?:...) */
7776    case '>':           /* (?>...) */
7777     break;
7778    case '$':           /* (?$...) */
7779    case '@':           /* (?@...) */
7780     vFAIL2("Sequence (?%c...) not implemented", (int)paren);
7781     break;
7782    case '#':           /* (?#...) */
7783     while (*RExC_parse && *RExC_parse != ')')
7784      RExC_parse++;
7785     if (*RExC_parse != ')')
7786      FAIL("Sequence (?#... not terminated");
7787     nextchar(pRExC_state);
7788     *flagp = TRYAGAIN;
7789     return NULL;
7790    case '0' :           /* (?0) */
7791    case 'R' :           /* (?R) */
7792     if (*RExC_parse != ')')
7793      FAIL("Sequence (?R) not terminated");
7794     ret = reg_node(pRExC_state, GOSTART);
7795     *flagp |= POSTPONED;
7796     nextchar(pRExC_state);
7797     return ret;
7798     /*notreached*/
7799    { /* named and numeric backreferences */
7800     I32 num;
7801    case '&':            /* (?&NAME) */
7802     parse_start = RExC_parse - 1;
7803    named_recursion:
7804     {
7805       SV *sv_dat = reg_scan_name(pRExC_state,
7806        SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
7807       num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
7808     }
7809     goto gen_recurse_regop;
7810     /* NOT REACHED */
7811    case '+':
7812     if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
7813      RExC_parse++;
7814      vFAIL("Illegal pattern");
7815     }
7816     goto parse_recursion;
7817     /* NOT REACHED*/
7818    case '-': /* (?-1) */
7819     if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
7820      RExC_parse--; /* rewind to let it be handled later */
7821      goto parse_flags;
7822     }
7823     /*FALLTHROUGH */
7824    case '1': case '2': case '3': case '4': /* (?1) */
7825    case '5': case '6': case '7': case '8': case '9':
7826     RExC_parse--;
7827    parse_recursion:
7828     num = atoi(RExC_parse);
7829     parse_start = RExC_parse - 1; /* MJD */
7830     if (*RExC_parse == '-')
7831      RExC_parse++;
7832     while (isDIGIT(*RExC_parse))
7833       RExC_parse++;
7834     if (*RExC_parse!=')')
7835      vFAIL("Expecting close bracket");
7836
7837    gen_recurse_regop:
7838     if ( paren == '-' ) {
7839      /*
7840      Diagram of capture buffer numbering.
7841      Top line is the normal capture buffer numbers
7842      Bottom line is the negative indexing as from
7843      the X (the (?-2))
7844
7845      +   1 2    3 4 5 X          6 7
7846      /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
7847      -   5 4    3 2 1 X          x x
7848
7849      */
7850      num = RExC_npar + num;
7851      if (num < 1)  {
7852       RExC_parse++;
7853       vFAIL("Reference to nonexistent group");
7854      }
7855     } else if ( paren == '+' ) {
7856      num = RExC_npar + num - 1;
7857     }
7858
7859     ret = reganode(pRExC_state, GOSUB, num);
7860     if (!SIZE_ONLY) {
7861      if (num > (I32)RExC_rx->nparens) {
7862       RExC_parse++;
7863       vFAIL("Reference to nonexistent group");
7864      }
7865      ARG2L_SET( ret, RExC_recurse_count++);
7866      RExC_emit++;
7867      DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
7868       "Recurse #%"UVuf" to %"IVdf"\n", (UV)ARG(ret), (IV)ARG2L(ret)));
7869     } else {
7870      RExC_size++;
7871      }
7872      RExC_seen |= REG_SEEN_RECURSE;
7873     Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
7874     Set_Node_Offset(ret, parse_start); /* MJD */
7875
7876     *flagp |= POSTPONED;
7877     nextchar(pRExC_state);
7878     return ret;
7879    } /* named and numeric backreferences */
7880    /* NOT REACHED */
7881
7882    case '?':           /* (??...) */
7883     is_logical = 1;
7884     if (*RExC_parse != '{') {
7885      RExC_parse++;
7886      vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
7887      /*NOTREACHED*/
7888     }
7889     *flagp |= POSTPONED;
7890     paren = *RExC_parse++;
7891     /* FALL THROUGH */
7892    case '{':           /* (?{...}) */
7893    {
7894     I32 count = 1;
7895     U32 n = 0;
7896     char c;
7897     char *s = RExC_parse;
7898
7899     RExC_seen_zerolen++;
7900     RExC_seen |= REG_SEEN_EVAL;
7901     while (count && (c = *RExC_parse)) {
7902      if (c == '\\') {
7903       if (RExC_parse[1])
7904        RExC_parse++;
7905      }
7906      else if (c == '{')
7907       count++;
7908      else if (c == '}')
7909       count--;
7910      RExC_parse++;
7911     }
7912     if (*RExC_parse != ')') {
7913      RExC_parse = s;
7914      vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
7915     }
7916     if (!SIZE_ONLY) {
7917      PAD *pad;
7918      OP_4tree *sop, *rop;
7919      SV * const sv = newSVpvn(s, RExC_parse - 1 - s);
7920
7921      ENTER;
7922      Perl_save_re_context(aTHX);
7923      rop = Perl_sv_compile_2op_is_broken(aTHX_ sv, &sop, "re", &pad);
7924      sop->op_private |= OPpREFCOUNTED;
7925      /* re_dup will OpREFCNT_inc */
7926      OpREFCNT_set(sop, 1);
7927      LEAVE;
7928
7929      n = add_data(pRExC_state, 3, "nop");
7930      RExC_rxi->data->data[n] = (void*)rop;
7931      RExC_rxi->data->data[n+1] = (void*)sop;
7932      RExC_rxi->data->data[n+2] = (void*)pad;
7933      SvREFCNT_dec(sv);
7934     }
7935     else {      /* First pass */
7936      if (PL_reginterp_cnt < ++RExC_seen_evals
7937       && IN_PERL_RUNTIME)
7938       /* No compiled RE interpolated, has runtime
7939       components ===> unsafe.  */
7940       FAIL("Eval-group not allowed at runtime, use re 'eval'");
7941      if (PL_tainting && PL_tainted)
7942       FAIL("Eval-group in insecure regular expression");
7943 #if PERL_VERSION > 8
7944      if (IN_PERL_COMPILETIME)
7945       PL_cv_has_eval = 1;
7946 #endif
7947     }
7948
7949     nextchar(pRExC_state);
7950     if (is_logical) {
7951      ret = reg_node(pRExC_state, LOGICAL);
7952      if (!SIZE_ONLY)
7953       ret->flags = 2;
7954      REGTAIL(pRExC_state, ret, reganode(pRExC_state, EVAL, n));
7955      /* deal with the length of this later - MJD */
7956      return ret;
7957     }
7958     ret = reganode(pRExC_state, EVAL, n);
7959     Set_Node_Length(ret, RExC_parse - parse_start + 1);
7960     Set_Node_Offset(ret, parse_start);
7961     return ret;
7962    }
7963    case '(':           /* (?(?{...})...) and (?(?=...)...) */
7964    {
7965     int is_define= 0;
7966     if (RExC_parse[0] == '?') {        /* (?(?...)) */
7967      if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
7968       || RExC_parse[1] == '<'
7969       || RExC_parse[1] == '{') { /* Lookahead or eval. */
7970       I32 flag;
7971
7972       ret = reg_node(pRExC_state, LOGICAL);
7973       if (!SIZE_ONLY)
7974        ret->flags = 1;
7975       REGTAIL(pRExC_state, ret, reg(pRExC_state, 1, &flag,depth+1));
7976       goto insert_if;
7977      }
7978     }
7979     else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
7980       || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
7981     {
7982      char ch = RExC_parse[0] == '<' ? '>' : '\'';
7983      char *name_start= RExC_parse++;
7984      U32 num = 0;
7985      SV *sv_dat=reg_scan_name(pRExC_state,
7986       SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
7987      if (RExC_parse == name_start || *RExC_parse != ch)
7988       vFAIL2("Sequence (?(%c... not terminated",
7989        (ch == '>' ? '<' : ch));
7990      RExC_parse++;
7991      if (!SIZE_ONLY) {
7992       num = add_data( pRExC_state, 1, "S" );
7993       RExC_rxi->data->data[num]=(void*)sv_dat;
7994       SvREFCNT_inc_simple_void(sv_dat);
7995      }
7996      ret = reganode(pRExC_state,NGROUPP,num);
7997      goto insert_if_check_paren;
7998     }
7999     else if (RExC_parse[0] == 'D' &&
8000       RExC_parse[1] == 'E' &&
8001       RExC_parse[2] == 'F' &&
8002       RExC_parse[3] == 'I' &&
8003       RExC_parse[4] == 'N' &&
8004       RExC_parse[5] == 'E')
8005     {
8006      ret = reganode(pRExC_state,DEFINEP,0);
8007      RExC_parse +=6 ;
8008      is_define = 1;
8009      goto insert_if_check_paren;
8010     }
8011     else if (RExC_parse[0] == 'R') {
8012      RExC_parse++;
8013      parno = 0;
8014      if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
8015       parno = atoi(RExC_parse++);
8016       while (isDIGIT(*RExC_parse))
8017        RExC_parse++;
8018      } else if (RExC_parse[0] == '&') {
8019       SV *sv_dat;
8020       RExC_parse++;
8021       sv_dat = reg_scan_name(pRExC_state,
8022         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8023        parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
8024      }
8025      ret = reganode(pRExC_state,INSUBP,parno);
8026      goto insert_if_check_paren;
8027     }
8028     else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
8029      /* (?(1)...) */
8030      char c;
8031      parno = atoi(RExC_parse++);
8032
8033      while (isDIGIT(*RExC_parse))
8034       RExC_parse++;
8035      ret = reganode(pRExC_state, GROUPP, parno);
8036
8037     insert_if_check_paren:
8038      if ((c = *nextchar(pRExC_state)) != ')')
8039       vFAIL("Switch condition not recognized");
8040     insert_if:
8041      REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
8042      br = regbranch(pRExC_state, &flags, 1,depth+1);
8043      if (br == NULL)
8044       br = reganode(pRExC_state, LONGJMP, 0);
8045      else
8046       REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
8047      c = *nextchar(pRExC_state);
8048      if (flags&HASWIDTH)
8049       *flagp |= HASWIDTH;
8050      if (c == '|') {
8051       if (is_define)
8052        vFAIL("(?(DEFINE)....) does not allow branches");
8053       lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
8054       regbranch(pRExC_state, &flags, 1,depth+1);
8055       REGTAIL(pRExC_state, ret, lastbr);
8056       if (flags&HASWIDTH)
8057        *flagp |= HASWIDTH;
8058       c = *nextchar(pRExC_state);
8059      }
8060      else
8061       lastbr = NULL;
8062      if (c != ')')
8063       vFAIL("Switch (?(condition)... contains too many branches");
8064      ender = reg_node(pRExC_state, TAIL);
8065      REGTAIL(pRExC_state, br, ender);
8066      if (lastbr) {
8067       REGTAIL(pRExC_state, lastbr, ender);
8068       REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
8069      }
8070      else
8071       REGTAIL(pRExC_state, ret, ender);
8072      RExC_size++; /* XXX WHY do we need this?!!
8073          For large programs it seems to be required
8074          but I can't figure out why. -- dmq*/
8075      return ret;
8076     }
8077     else {
8078      vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
8079     }
8080    }
8081    case 0:
8082     RExC_parse--; /* for vFAIL to print correctly */
8083     vFAIL("Sequence (? incomplete");
8084     break;
8085    case DEFAULT_PAT_MOD:   /* Use default flags with the exceptions
8086          that follow */
8087     has_use_defaults = TRUE;
8088     STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
8089     set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
8090             ? REGEX_UNICODE_CHARSET
8091             : REGEX_DEPENDS_CHARSET);
8092     goto parse_flags;
8093    default:
8094     --RExC_parse;
8095     parse_flags:      /* (?i) */
8096    {
8097     U32 posflags = 0, negflags = 0;
8098     U32 *flagsp = &posflags;
8099     char has_charset_modifier = '\0';
8100     regex_charset cs = get_regex_charset(RExC_flags);
8101     if (cs == REGEX_DEPENDS_CHARSET
8102      && (RExC_utf8 || RExC_uni_semantics))
8103     {
8104      cs = REGEX_UNICODE_CHARSET;
8105     }
8106
8107     while (*RExC_parse) {
8108      /* && strchr("iogcmsx", *RExC_parse) */
8109      /* (?g), (?gc) and (?o) are useless here
8110      and must be globally applied -- japhy */
8111      switch (*RExC_parse) {
8112      CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp);
8113      case LOCALE_PAT_MOD:
8114       if (has_charset_modifier) {
8115        goto excess_modifier;
8116       }
8117       else if (flagsp == &negflags) {
8118        goto neg_modifier;
8119       }
8120       cs = REGEX_LOCALE_CHARSET;
8121       has_charset_modifier = LOCALE_PAT_MOD;
8122       RExC_contains_locale = 1;
8123       break;
8124      case UNICODE_PAT_MOD:
8125       if (has_charset_modifier) {
8126        goto excess_modifier;
8127       }
8128       else if (flagsp == &negflags) {
8129        goto neg_modifier;
8130       }
8131       cs = REGEX_UNICODE_CHARSET;
8132       has_charset_modifier = UNICODE_PAT_MOD;
8133       break;
8134      case ASCII_RESTRICT_PAT_MOD:
8135       if (flagsp == &negflags) {
8136        goto neg_modifier;
8137       }
8138       if (has_charset_modifier) {
8139        if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
8140         goto excess_modifier;
8141        }
8142        /* Doubled modifier implies more restricted */
8143        cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
8144       }
8145       else {
8146        cs = REGEX_ASCII_RESTRICTED_CHARSET;
8147       }
8148       has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
8149       break;
8150      case DEPENDS_PAT_MOD:
8151       if (has_use_defaults) {
8152        goto fail_modifiers;
8153       }
8154       else if (flagsp == &negflags) {
8155        goto neg_modifier;
8156       }
8157       else if (has_charset_modifier) {
8158        goto excess_modifier;
8159       }
8160
8161       /* The dual charset means unicode semantics if the
8162       * pattern (or target, not known until runtime) are
8163       * utf8, or something in the pattern indicates unicode
8164       * semantics */
8165       cs = (RExC_utf8 || RExC_uni_semantics)
8166        ? REGEX_UNICODE_CHARSET
8167        : REGEX_DEPENDS_CHARSET;
8168       has_charset_modifier = DEPENDS_PAT_MOD;
8169       break;
8170      excess_modifier:
8171       RExC_parse++;
8172       if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
8173        vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
8174       }
8175       else if (has_charset_modifier == *(RExC_parse - 1)) {
8176        vFAIL2("Regexp modifier \"%c\" may not appear twice", *(RExC_parse - 1));
8177       }
8178       else {
8179        vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
8180       }
8181       /*NOTREACHED*/
8182      neg_modifier:
8183       RExC_parse++;
8184       vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"", *(RExC_parse - 1));
8185       /*NOTREACHED*/
8186      case ONCE_PAT_MOD: /* 'o' */
8187      case GLOBAL_PAT_MOD: /* 'g' */
8188       if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
8189        const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
8190        if (! (wastedflags & wflagbit) ) {
8191         wastedflags |= wflagbit;
8192         vWARN5(
8193          RExC_parse + 1,
8194          "Useless (%s%c) - %suse /%c modifier",
8195          flagsp == &negflags ? "?-" : "?",
8196          *RExC_parse,
8197          flagsp == &negflags ? "don't " : "",
8198          *RExC_parse
8199         );
8200        }
8201       }
8202       break;
8203
8204      case CONTINUE_PAT_MOD: /* 'c' */
8205       if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
8206        if (! (wastedflags & WASTED_C) ) {
8207         wastedflags |= WASTED_GC;
8208         vWARN3(
8209          RExC_parse + 1,
8210          "Useless (%sc) - %suse /gc modifier",
8211          flagsp == &negflags ? "?-" : "?",
8212          flagsp == &negflags ? "don't " : ""
8213         );
8214        }
8215       }
8216       break;
8217      case KEEPCOPY_PAT_MOD: /* 'p' */
8218       if (flagsp == &negflags) {
8219        if (SIZE_ONLY)
8220         ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
8221       } else {
8222        *flagsp |= RXf_PMf_KEEPCOPY;
8223       }
8224       break;
8225      case '-':
8226       /* A flag is a default iff it is following a minus, so
8227       * if there is a minus, it means will be trying to
8228       * re-specify a default which is an error */
8229       if (has_use_defaults || flagsp == &negflags) {
8230    fail_modifiers:
8231        RExC_parse++;
8232        vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8233        /*NOTREACHED*/
8234       }
8235       flagsp = &negflags;
8236       wastedflags = 0;  /* reset so (?g-c) warns twice */
8237       break;
8238      case ':':
8239       paren = ':';
8240       /*FALLTHROUGH*/
8241      case ')':
8242       RExC_flags |= posflags;
8243       RExC_flags &= ~negflags;
8244       set_regex_charset(&RExC_flags, cs);
8245       if (paren != ':') {
8246        oregflags |= posflags;
8247        oregflags &= ~negflags;
8248        set_regex_charset(&oregflags, cs);
8249       }
8250       nextchar(pRExC_state);
8251       if (paren != ':') {
8252        *flagp = TRYAGAIN;
8253        return NULL;
8254       } else {
8255        ret = NULL;
8256        goto parse_rest;
8257       }
8258       /*NOTREACHED*/
8259      default:
8260       RExC_parse++;
8261       vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8262       /*NOTREACHED*/
8263      }
8264      ++RExC_parse;
8265     }
8266    }} /* one for the default block, one for the switch */
8267   }
8268   else {                  /* (...) */
8269   capturing_parens:
8270    parno = RExC_npar;
8271    RExC_npar++;
8272
8273    ret = reganode(pRExC_state, OPEN, parno);
8274    if (!SIZE_ONLY ){
8275     if (!RExC_nestroot)
8276      RExC_nestroot = parno;
8277     if (RExC_seen & REG_SEEN_RECURSE
8278      && !RExC_open_parens[parno-1])
8279     {
8280      DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
8281       "Setting open paren #%"IVdf" to %d\n",
8282       (IV)parno, REG_NODE_NUM(ret)));
8283      RExC_open_parens[parno-1]= ret;
8284     }
8285    }
8286    Set_Node_Length(ret, 1); /* MJD */
8287    Set_Node_Offset(ret, RExC_parse); /* MJD */
8288    is_open = 1;
8289   }
8290  }
8291  else                        /* ! paren */
8292   ret = NULL;
8293
8294    parse_rest:
8295  /* Pick up the branches, linking them together. */
8296  parse_start = RExC_parse;   /* MJD */
8297  br = regbranch(pRExC_state, &flags, 1,depth+1);
8298
8299  /*     branch_len = (paren != 0); */
8300
8301  if (br == NULL)
8302   return(NULL);
8303  if (*RExC_parse == '|') {
8304   if (!SIZE_ONLY && RExC_extralen) {
8305    reginsert(pRExC_state, BRANCHJ, br, depth+1);
8306   }
8307   else {                  /* MJD */
8308    reginsert(pRExC_state, BRANCH, br, depth+1);
8309    Set_Node_Length(br, paren != 0);
8310    Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
8311   }
8312   have_branch = 1;
8313   if (SIZE_ONLY)
8314    RExC_extralen += 1;  /* For BRANCHJ-BRANCH. */
8315  }
8316  else if (paren == ':') {
8317   *flagp |= flags&SIMPLE;
8318  }
8319  if (is_open) {    /* Starts with OPEN. */
8320   REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
8321  }
8322  else if (paren != '?')  /* Not Conditional */
8323   ret = br;
8324  *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
8325  lastbr = br;
8326  while (*RExC_parse == '|') {
8327   if (!SIZE_ONLY && RExC_extralen) {
8328    ender = reganode(pRExC_state, LONGJMP,0);
8329    REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
8330   }
8331   if (SIZE_ONLY)
8332    RExC_extralen += 2;  /* Account for LONGJMP. */
8333   nextchar(pRExC_state);
8334   if (freeze_paren) {
8335    if (RExC_npar > after_freeze)
8336     after_freeze = RExC_npar;
8337    RExC_npar = freeze_paren;
8338   }
8339   br = regbranch(pRExC_state, &flags, 0, depth+1);
8340
8341   if (br == NULL)
8342    return(NULL);
8343   REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
8344   lastbr = br;
8345   *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
8346  }
8347
8348  if (have_branch || paren != ':') {
8349   /* Make a closing node, and hook it on the end. */
8350   switch (paren) {
8351   case ':':
8352    ender = reg_node(pRExC_state, TAIL);
8353    break;
8354   case 1:
8355    ender = reganode(pRExC_state, CLOSE, parno);
8356    if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) {
8357     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
8358       "Setting close paren #%"IVdf" to %d\n",
8359       (IV)parno, REG_NODE_NUM(ender)));
8360     RExC_close_parens[parno-1]= ender;
8361     if (RExC_nestroot == parno)
8362      RExC_nestroot = 0;
8363    }
8364    Set_Node_Offset(ender,RExC_parse+1); /* MJD */
8365    Set_Node_Length(ender,1); /* MJD */
8366    break;
8367   case '<':
8368   case ',':
8369   case '=':
8370   case '!':
8371    *flagp &= ~HASWIDTH;
8372    /* FALL THROUGH */
8373   case '>':
8374    ender = reg_node(pRExC_state, SUCCEED);
8375    break;
8376   case 0:
8377    ender = reg_node(pRExC_state, END);
8378    if (!SIZE_ONLY) {
8379     assert(!RExC_opend); /* there can only be one! */
8380     RExC_opend = ender;
8381    }
8382    break;
8383   }
8384   REGTAIL(pRExC_state, lastbr, ender);
8385
8386   if (have_branch && !SIZE_ONLY) {
8387    if (depth==1)
8388     RExC_seen |= REG_TOP_LEVEL_BRANCHES;
8389
8390    /* Hook the tails of the branches to the closing node. */
8391    for (br = ret; br; br = regnext(br)) {
8392     const U8 op = PL_regkind[OP(br)];
8393     if (op == BRANCH) {
8394      REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
8395     }
8396     else if (op == BRANCHJ) {
8397      REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
8398     }
8399    }
8400   }
8401  }
8402
8403  {
8404   const char *p;
8405   static const char parens[] = "=!<,>";
8406
8407   if (paren && (p = strchr(parens, paren))) {
8408    U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
8409    int flag = (p - parens) > 1;
8410
8411    if (paren == '>')
8412     node = SUSPEND, flag = 0;
8413    reginsert(pRExC_state, node,ret, depth+1);
8414    Set_Node_Cur_Length(ret);
8415    Set_Node_Offset(ret, parse_start + 1);
8416    ret->flags = flag;
8417    REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
8418   }
8419  }
8420
8421  /* Check for proper termination. */
8422  if (paren) {
8423   RExC_flags = oregflags;
8424   if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
8425    RExC_parse = oregcomp_parse;
8426    vFAIL("Unmatched (");
8427   }
8428  }
8429  else if (!paren && RExC_parse < RExC_end) {
8430   if (*RExC_parse == ')') {
8431    RExC_parse++;
8432    vFAIL("Unmatched )");
8433   }
8434   else
8435    FAIL("Junk on end of regexp"); /* "Can't happen". */
8436   /* NOTREACHED */
8437  }
8438
8439  if (RExC_in_lookbehind) {
8440   RExC_in_lookbehind--;
8441  }
8442  if (after_freeze > RExC_npar)
8443   RExC_npar = after_freeze;
8444  return(ret);
8445 }
8446
8447 /*
8448  - regbranch - one alternative of an | operator
8449  *
8450  * Implements the concatenation operator.
8451  */
8452 STATIC regnode *
8453 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
8454 {
8455  dVAR;
8456  register regnode *ret;
8457  register regnode *chain = NULL;
8458  register regnode *latest;
8459  I32 flags = 0, c = 0;
8460  GET_RE_DEBUG_FLAGS_DECL;
8461
8462  PERL_ARGS_ASSERT_REGBRANCH;
8463
8464  DEBUG_PARSE("brnc");
8465
8466  if (first)
8467   ret = NULL;
8468  else {
8469   if (!SIZE_ONLY && RExC_extralen)
8470    ret = reganode(pRExC_state, BRANCHJ,0);
8471   else {
8472    ret = reg_node(pRExC_state, BRANCH);
8473    Set_Node_Length(ret, 1);
8474   }
8475  }
8476
8477  if (!first && SIZE_ONLY)
8478   RExC_extralen += 1;   /* BRANCHJ */
8479
8480  *flagp = WORST;   /* Tentatively. */
8481
8482  RExC_parse--;
8483  nextchar(pRExC_state);
8484  while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
8485   flags &= ~TRYAGAIN;
8486   latest = regpiece(pRExC_state, &flags,depth+1);
8487   if (latest == NULL) {
8488    if (flags & TRYAGAIN)
8489     continue;
8490    return(NULL);
8491   }
8492   else if (ret == NULL)
8493    ret = latest;
8494   *flagp |= flags&(HASWIDTH|POSTPONED);
8495   if (chain == NULL)  /* First piece. */
8496    *flagp |= flags&SPSTART;
8497   else {
8498    RExC_naughty++;
8499    REGTAIL(pRExC_state, chain, latest);
8500   }
8501   chain = latest;
8502   c++;
8503  }
8504  if (chain == NULL) { /* Loop ran zero times. */
8505   chain = reg_node(pRExC_state, NOTHING);
8506   if (ret == NULL)
8507    ret = chain;
8508  }
8509  if (c == 1) {
8510   *flagp |= flags&SIMPLE;
8511  }
8512
8513  return ret;
8514 }
8515
8516 /*
8517  - regpiece - something followed by possible [*+?]
8518  *
8519  * Note that the branching code sequences used for ? and the general cases
8520  * of * and + are somewhat optimized:  they use the same NOTHING node as
8521  * both the endmarker for their branch list and the body of the last branch.
8522  * It might seem that this node could be dispensed with entirely, but the
8523  * endmarker role is not redundant.
8524  */
8525 STATIC regnode *
8526 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
8527 {
8528  dVAR;
8529  register regnode *ret;
8530  register char op;
8531  register char *next;
8532  I32 flags;
8533  const char * const origparse = RExC_parse;
8534  I32 min;
8535  I32 max = REG_INFTY;
8536 #ifdef RE_TRACK_PATTERN_OFFSETS
8537  char *parse_start;
8538 #endif
8539  const char *maxpos = NULL;
8540  GET_RE_DEBUG_FLAGS_DECL;
8541
8542  PERL_ARGS_ASSERT_REGPIECE;
8543
8544  DEBUG_PARSE("piec");
8545
8546  ret = regatom(pRExC_state, &flags,depth+1);
8547  if (ret == NULL) {
8548   if (flags & TRYAGAIN)
8549    *flagp |= TRYAGAIN;
8550   return(NULL);
8551  }
8552
8553  op = *RExC_parse;
8554
8555  if (op == '{' && regcurly(RExC_parse)) {
8556   maxpos = NULL;
8557 #ifdef RE_TRACK_PATTERN_OFFSETS
8558   parse_start = RExC_parse; /* MJD */
8559 #endif
8560   next = RExC_parse + 1;
8561   while (isDIGIT(*next) || *next == ',') {
8562    if (*next == ',') {
8563     if (maxpos)
8564      break;
8565     else
8566      maxpos = next;
8567    }
8568    next++;
8569   }
8570   if (*next == '}') {  /* got one */
8571    if (!maxpos)
8572     maxpos = next;
8573    RExC_parse++;
8574    min = atoi(RExC_parse);
8575    if (*maxpos == ',')
8576     maxpos++;
8577    else
8578     maxpos = RExC_parse;
8579    max = atoi(maxpos);
8580    if (!max && *maxpos != '0')
8581     max = REG_INFTY;  /* meaning "infinity" */
8582    else if (max >= REG_INFTY)
8583     vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
8584    RExC_parse = next;
8585    nextchar(pRExC_state);
8586
8587   do_curly:
8588    if ((flags&SIMPLE)) {
8589     RExC_naughty += 2 + RExC_naughty / 2;
8590     reginsert(pRExC_state, CURLY, ret, depth+1);
8591     Set_Node_Offset(ret, parse_start+1); /* MJD */
8592     Set_Node_Cur_Length(ret);
8593    }
8594    else {
8595     regnode * const w = reg_node(pRExC_state, WHILEM);
8596
8597     w->flags = 0;
8598     REGTAIL(pRExC_state, ret, w);
8599     if (!SIZE_ONLY && RExC_extralen) {
8600      reginsert(pRExC_state, LONGJMP,ret, depth+1);
8601      reginsert(pRExC_state, NOTHING,ret, depth+1);
8602      NEXT_OFF(ret) = 3; /* Go over LONGJMP. */
8603     }
8604     reginsert(pRExC_state, CURLYX,ret, depth+1);
8605         /* MJD hk */
8606     Set_Node_Offset(ret, parse_start+1);
8607     Set_Node_Length(ret,
8608         op == '{' ? (RExC_parse - parse_start) : 1);
8609
8610     if (!SIZE_ONLY && RExC_extralen)
8611      NEXT_OFF(ret) = 3; /* Go over NOTHING to LONGJMP. */
8612     REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
8613     if (SIZE_ONLY)
8614      RExC_whilem_seen++, RExC_extralen += 3;
8615     RExC_naughty += 4 + RExC_naughty; /* compound interest */
8616    }
8617    ret->flags = 0;
8618
8619    if (min > 0)
8620     *flagp = WORST;
8621    if (max > 0)
8622     *flagp |= HASWIDTH;
8623    if (max < min)
8624     vFAIL("Can't do {n,m} with n > m");
8625    if (!SIZE_ONLY) {
8626     ARG1_SET(ret, (U16)min);
8627     ARG2_SET(ret, (U16)max);
8628    }
8629
8630    goto nest_check;
8631   }
8632  }
8633
8634  if (!ISMULT1(op)) {
8635   *flagp = flags;
8636   return(ret);
8637  }
8638
8639 #if 0    /* Now runtime fix should be reliable. */
8640
8641  /* if this is reinstated, don't forget to put this back into perldiag:
8642
8643    =item Regexp *+ operand could be empty at {#} in regex m/%s/
8644
8645   (F) The part of the regexp subject to either the * or + quantifier
8646   could match an empty string. The {#} shows in the regular
8647   expression about where the problem was discovered.
8648
8649  */
8650
8651  if (!(flags&HASWIDTH) && op != '?')
8652  vFAIL("Regexp *+ operand could be empty");
8653 #endif
8654
8655 #ifdef RE_TRACK_PATTERN_OFFSETS
8656  parse_start = RExC_parse;
8657 #endif
8658  nextchar(pRExC_state);
8659
8660  *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
8661
8662  if (op == '*' && (flags&SIMPLE)) {
8663   reginsert(pRExC_state, STAR, ret, depth+1);
8664   ret->flags = 0;
8665   RExC_naughty += 4;
8666  }
8667  else if (op == '*') {
8668   min = 0;
8669   goto do_curly;
8670  }
8671  else if (op == '+' && (flags&SIMPLE)) {
8672   reginsert(pRExC_state, PLUS, ret, depth+1);
8673   ret->flags = 0;
8674   RExC_naughty += 3;
8675  }
8676  else if (op == '+') {
8677   min = 1;
8678   goto do_curly;
8679  }
8680  else if (op == '?') {
8681   min = 0; max = 1;
8682   goto do_curly;
8683  }
8684   nest_check:
8685  if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
8686   ckWARN3reg(RExC_parse,
8687     "%.*s matches null string many times",
8688     (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0),
8689     origparse);
8690  }
8691
8692  if (RExC_parse < RExC_end && *RExC_parse == '?') {
8693   nextchar(pRExC_state);
8694   reginsert(pRExC_state, MINMOD, ret, depth+1);
8695   REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
8696  }
8697 #ifndef REG_ALLOW_MINMOD_SUSPEND
8698  else
8699 #endif
8700  if (RExC_parse < RExC_end && *RExC_parse == '+') {
8701   regnode *ender;
8702   nextchar(pRExC_state);
8703   ender = reg_node(pRExC_state, SUCCEED);
8704   REGTAIL(pRExC_state, ret, ender);
8705   reginsert(pRExC_state, SUSPEND, ret, depth+1);
8706   ret->flags = 0;
8707   ender = reg_node(pRExC_state, TAIL);
8708   REGTAIL(pRExC_state, ret, ender);
8709   /*ret= ender;*/
8710  }
8711
8712  if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) {
8713   RExC_parse++;
8714   vFAIL("Nested quantifiers");
8715  }
8716
8717  return(ret);
8718 }
8719
8720
8721 /* reg_namedseq(pRExC_state,UVp, UV depth)
8722
8723    This is expected to be called by a parser routine that has
8724    recognized '\N' and needs to handle the rest. RExC_parse is
8725    expected to point at the first char following the N at the time
8726    of the call.
8727
8728    The \N may be inside (indicated by valuep not being NULL) or outside a
8729    character class.
8730
8731    \N may begin either a named sequence, or if outside a character class, mean
8732    to match a non-newline.  For non single-quoted regexes, the tokenizer has
8733    attempted to decide which, and in the case of a named sequence converted it
8734    into one of the forms: \N{} (if the sequence is null), or \N{U+c1.c2...},
8735    where c1... are the characters in the sequence.  For single-quoted regexes,
8736    the tokenizer passes the \N sequence through unchanged; this code will not
8737    attempt to determine this nor expand those.  The net effect is that if the
8738    beginning of the passed-in pattern isn't '{U+' or there is no '}', it
8739    signals that this \N occurrence means to match a non-newline.
8740
8741    Only the \N{U+...} form should occur in a character class, for the same
8742    reason that '.' inside a character class means to just match a period: it
8743    just doesn't make sense.
8744
8745    If valuep is non-null then it is assumed that we are parsing inside
8746    of a charclass definition and the first codepoint in the resolved
8747    string is returned via *valuep and the routine will return NULL.
8748    In this mode if a multichar string is returned from the charnames
8749    handler, a warning will be issued, and only the first char in the
8750    sequence will be examined. If the string returned is zero length
8751    then the value of *valuep is undefined and NON-NULL will
8752    be returned to indicate failure. (This will NOT be a valid pointer
8753    to a regnode.)
8754
8755    If valuep is null then it is assumed that we are parsing normal text and a
8756    new EXACT node is inserted into the program containing the resolved string,
8757    and a pointer to the new node is returned.  But if the string is zero length
8758    a NOTHING node is emitted instead.
8759
8760    On success RExC_parse is set to the char following the endbrace.
8761    Parsing failures will generate a fatal error via vFAIL(...)
8762  */
8763 STATIC regnode *
8764 S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep, I32 *flagp, U32 depth)
8765 {
8766  char * endbrace;    /* '}' following the name */
8767  regnode *ret = NULL;
8768  char* p;
8769
8770  GET_RE_DEBUG_FLAGS_DECL;
8771
8772  PERL_ARGS_ASSERT_REG_NAMEDSEQ;
8773
8774  GET_RE_DEBUG_FLAGS;
8775
8776  /* The [^\n] meaning of \N ignores spaces and comments under the /x
8777  * modifier.  The other meaning does not */
8778  p = (RExC_flags & RXf_PMf_EXTENDED)
8779   ? regwhite( pRExC_state, RExC_parse )
8780   : RExC_parse;
8781
8782  /* Disambiguate between \N meaning a named character versus \N meaning
8783  * [^\n].  The former is assumed when it can't be the latter. */
8784  if (*p != '{' || regcurly(p)) {
8785   RExC_parse = p;
8786   if (valuep) {
8787    /* no bare \N in a charclass */
8788    vFAIL("\\N in a character class must be a named character: \\N{...}");
8789   }
8790   nextchar(pRExC_state);
8791   ret = reg_node(pRExC_state, REG_ANY);
8792   *flagp |= HASWIDTH|SIMPLE;
8793   RExC_naughty++;
8794   RExC_parse--;
8795   Set_Node_Length(ret, 1); /* MJD */
8796   return ret;
8797  }
8798
8799  /* Here, we have decided it should be a named sequence */
8800
8801  /* The test above made sure that the next real character is a '{', but
8802  * under the /x modifier, it could be separated by space (or a comment and
8803  * \n) and this is not allowed (for consistency with \x{...} and the
8804  * tokenizer handling of \N{NAME}). */
8805  if (*RExC_parse != '{') {
8806   vFAIL("Missing braces on \\N{}");
8807  }
8808
8809  RExC_parse++; /* Skip past the '{' */
8810
8811  if (! (endbrace = strchr(RExC_parse, '}')) /* no trailing brace */
8812   || ! (endbrace == RExC_parse  /* nothing between the {} */
8813    || (endbrace - RExC_parse >= 2 /* U+ (bad hex is checked below */
8814     && strnEQ(RExC_parse, "U+", 2)))) /* for a better error msg) */
8815  {
8816   if (endbrace) RExC_parse = endbrace; /* position msg's '<--HERE' */
8817   vFAIL("\\N{NAME} must be resolved by the lexer");
8818  }
8819
8820  if (endbrace == RExC_parse) {   /* empty: \N{} */
8821   if (! valuep) {
8822    RExC_parse = endbrace + 1;
8823    return reg_node(pRExC_state,NOTHING);
8824   }
8825
8826   if (SIZE_ONLY) {
8827    ckWARNreg(RExC_parse,
8828      "Ignoring zero length \\N{} in character class"
8829    );
8830    RExC_parse = endbrace + 1;
8831   }
8832   *valuep = 0;
8833   return (regnode *) &RExC_parse; /* Invalid regnode pointer */
8834  }
8835
8836  REQUIRE_UTF8; /* named sequences imply Unicode semantics */
8837  RExC_parse += 2; /* Skip past the 'U+' */
8838
8839  if (valuep) {   /* In a bracketed char class */
8840   /* We only pay attention to the first char of
8841   multichar strings being returned. I kinda wonder
8842   if this makes sense as it does change the behaviour
8843   from earlier versions, OTOH that behaviour was broken
8844   as well. XXX Solution is to recharacterize as
8845   [rest-of-class]|multi1|multi2... */
8846
8847   STRLEN length_of_hex;
8848   I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
8849    | PERL_SCAN_DISALLOW_PREFIX
8850    | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
8851
8852   char * endchar = RExC_parse + strcspn(RExC_parse, ".}");
8853   if (endchar < endbrace) {
8854    ckWARNreg(endchar, "Using just the first character returned by \\N{} in character class");
8855   }
8856
8857   length_of_hex = (STRLEN)(endchar - RExC_parse);
8858   *valuep = grok_hex(RExC_parse, &length_of_hex, &flags, NULL);
8859
8860   /* The tokenizer should have guaranteed validity, but it's possible to
8861   * bypass it by using single quoting, so check */
8862   if (length_of_hex == 0
8863    || length_of_hex != (STRLEN)(endchar - RExC_parse) )
8864   {
8865    RExC_parse += length_of_hex; /* Includes all the valid */
8866    RExC_parse += (RExC_orig_utf8) /* point to after 1st invalid */
8867        ? UTF8SKIP(RExC_parse)
8868        : 1;
8869    /* Guard against malformed utf8 */
8870    if (RExC_parse >= endchar) RExC_parse = endchar;
8871    vFAIL("Invalid hexadecimal number in \\N{U+...}");
8872   }
8873
8874   RExC_parse = endbrace + 1;
8875   if (endchar == endbrace) return NULL;
8876
8877   ret = (regnode *) &RExC_parse; /* Invalid regnode pointer */
8878  }
8879  else { /* Not a char class */
8880
8881   /* What is done here is to convert this to a sub-pattern of the form
8882   * (?:\x{char1}\x{char2}...)
8883   * and then call reg recursively.  That way, it retains its atomicness,
8884   * while not having to worry about special handling that some code
8885   * points may have.  toke.c has converted the original Unicode values
8886   * to native, so that we can just pass on the hex values unchanged.  We
8887   * do have to set a flag to keep recoding from happening in the
8888   * recursion */
8889
8890   SV * substitute_parse = newSVpvn_flags("?:", 2, SVf_UTF8|SVs_TEMP);
8891   STRLEN len;
8892   char *endchar;     /* Points to '.' or '}' ending cur char in the input
8893        stream */
8894   char *orig_end = RExC_end;
8895
8896   while (RExC_parse < endbrace) {
8897
8898    /* Code points are separated by dots.  If none, there is only one
8899    * code point, and is terminated by the brace */
8900    endchar = RExC_parse + strcspn(RExC_parse, ".}");
8901
8902    /* Convert to notation the rest of the code understands */
8903    sv_catpv(substitute_parse, "\\x{");
8904    sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
8905    sv_catpv(substitute_parse, "}");
8906
8907    /* Point to the beginning of the next character in the sequence. */
8908    RExC_parse = endchar + 1;
8909   }
8910   sv_catpv(substitute_parse, ")");
8911
8912   RExC_parse = SvPV(substitute_parse, len);
8913
8914   /* Don't allow empty number */
8915   if (len < 8) {
8916    vFAIL("Invalid hexadecimal number in \\N{U+...}");
8917   }
8918   RExC_end = RExC_parse + len;
8919
8920   /* The values are Unicode, and therefore not subject to recoding */
8921   RExC_override_recoding = 1;
8922
8923   ret = reg(pRExC_state, 1, flagp, depth+1);
8924
8925   RExC_parse = endbrace;
8926   RExC_end = orig_end;
8927   RExC_override_recoding = 0;
8928
8929   nextchar(pRExC_state);
8930  }
8931
8932  return ret;
8933 }
8934
8935
8936 /*
8937  * reg_recode
8938  *
8939  * It returns the code point in utf8 for the value in *encp.
8940  *    value: a code value in the source encoding
8941  *    encp:  a pointer to an Encode object
8942  *
8943  * If the result from Encode is not a single character,
8944  * it returns U+FFFD (Replacement character) and sets *encp to NULL.
8945  */
8946 STATIC UV
8947 S_reg_recode(pTHX_ const char value, SV **encp)
8948 {
8949  STRLEN numlen = 1;
8950  SV * const sv = newSVpvn_flags(&value, numlen, SVs_TEMP);
8951  const char * const s = *encp ? sv_recode_to_utf8(sv, *encp) : SvPVX(sv);
8952  const STRLEN newlen = SvCUR(sv);
8953  UV uv = UNICODE_REPLACEMENT;
8954
8955  PERL_ARGS_ASSERT_REG_RECODE;
8956
8957  if (newlen)
8958   uv = SvUTF8(sv)
8959    ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
8960    : *(U8*)s;
8961
8962  if (!newlen || numlen != newlen) {
8963   uv = UNICODE_REPLACEMENT;
8964   *encp = NULL;
8965  }
8966  return uv;
8967 }
8968
8969
8970 /*
8971  - regatom - the lowest level
8972
8973    Try to identify anything special at the start of the pattern. If there
8974    is, then handle it as required. This may involve generating a single regop,
8975    such as for an assertion; or it may involve recursing, such as to
8976    handle a () structure.
8977
8978    If the string doesn't start with something special then we gobble up
8979    as much literal text as we can.
8980
8981    Once we have been able to handle whatever type of thing started the
8982    sequence, we return.
8983
8984    Note: we have to be careful with escapes, as they can be both literal
8985    and special, and in the case of \10 and friends can either, depending
8986    on context. Specifically there are two separate switches for handling
8987    escape sequences, with the one for handling literal escapes requiring
8988    a dummy entry for all of the special escapes that are actually handled
8989    by the other.
8990 */
8991
8992 STATIC regnode *
8993 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
8994 {
8995  dVAR;
8996  register regnode *ret = NULL;
8997  I32 flags;
8998  char *parse_start = RExC_parse;
8999  U8 op;
9000  GET_RE_DEBUG_FLAGS_DECL;
9001  DEBUG_PARSE("atom");
9002  *flagp = WORST;  /* Tentatively. */
9003
9004  PERL_ARGS_ASSERT_REGATOM;
9005
9006 tryagain:
9007  switch ((U8)*RExC_parse) {
9008  case '^':
9009   RExC_seen_zerolen++;
9010   nextchar(pRExC_state);
9011   if (RExC_flags & RXf_PMf_MULTILINE)
9012    ret = reg_node(pRExC_state, MBOL);
9013   else if (RExC_flags & RXf_PMf_SINGLELINE)
9014    ret = reg_node(pRExC_state, SBOL);
9015   else
9016    ret = reg_node(pRExC_state, BOL);
9017   Set_Node_Length(ret, 1); /* MJD */
9018   break;
9019  case '$':
9020   nextchar(pRExC_state);
9021   if (*RExC_parse)
9022    RExC_seen_zerolen++;
9023   if (RExC_flags & RXf_PMf_MULTILINE)
9024    ret = reg_node(pRExC_state, MEOL);
9025   else if (RExC_flags & RXf_PMf_SINGLELINE)
9026    ret = reg_node(pRExC_state, SEOL);
9027   else
9028    ret = reg_node(pRExC_state, EOL);
9029   Set_Node_Length(ret, 1); /* MJD */
9030   break;
9031  case '.':
9032   nextchar(pRExC_state);
9033   if (RExC_flags & RXf_PMf_SINGLELINE)
9034    ret = reg_node(pRExC_state, SANY);
9035   else
9036    ret = reg_node(pRExC_state, REG_ANY);
9037   *flagp |= HASWIDTH|SIMPLE;
9038   RExC_naughty++;
9039   Set_Node_Length(ret, 1); /* MJD */
9040   break;
9041  case '[':
9042  {
9043   char * const oregcomp_parse = ++RExC_parse;
9044   ret = regclass(pRExC_state,depth+1);
9045   if (*RExC_parse != ']') {
9046    RExC_parse = oregcomp_parse;
9047    vFAIL("Unmatched [");
9048   }
9049   nextchar(pRExC_state);
9050   *flagp |= HASWIDTH|SIMPLE;
9051   Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
9052   break;
9053  }
9054  case '(':
9055   nextchar(pRExC_state);
9056   ret = reg(pRExC_state, 1, &flags,depth+1);
9057   if (ret == NULL) {
9058     if (flags & TRYAGAIN) {
9059      if (RExC_parse == RExC_end) {
9060       /* Make parent create an empty node if needed. */
9061       *flagp |= TRYAGAIN;
9062       return(NULL);
9063      }
9064      goto tryagain;
9065     }
9066     return(NULL);
9067   }
9068   *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
9069   break;
9070  case '|':
9071  case ')':
9072   if (flags & TRYAGAIN) {
9073    *flagp |= TRYAGAIN;
9074    return NULL;
9075   }
9076   vFAIL("Internal urp");
9077         /* Supposed to be caught earlier. */
9078   break;
9079  case '{':
9080   if (!regcurly(RExC_parse)) {
9081    RExC_parse++;
9082    goto defchar;
9083   }
9084   /* FALL THROUGH */
9085  case '?':
9086  case '+':
9087  case '*':
9088   RExC_parse++;
9089   vFAIL("Quantifier follows nothing");
9090   break;
9091  case '\\':
9092   /* Special Escapes
9093
9094   This switch handles escape sequences that resolve to some kind
9095   of special regop and not to literal text. Escape sequnces that
9096   resolve to literal text are handled below in the switch marked
9097   "Literal Escapes".
9098
9099   Every entry in this switch *must* have a corresponding entry
9100   in the literal escape switch. However, the opposite is not
9101   required, as the default for this switch is to jump to the
9102   literal text handling code.
9103   */
9104   switch ((U8)*++RExC_parse) {
9105   /* Special Escapes */
9106   case 'A':
9107    RExC_seen_zerolen++;
9108    ret = reg_node(pRExC_state, SBOL);
9109    *flagp |= SIMPLE;
9110    goto finish_meta_pat;
9111   case 'G':
9112    ret = reg_node(pRExC_state, GPOS);
9113    RExC_seen |= REG_SEEN_GPOS;
9114    *flagp |= SIMPLE;
9115    goto finish_meta_pat;
9116   case 'K':
9117    RExC_seen_zerolen++;
9118    ret = reg_node(pRExC_state, KEEPS);
9119    *flagp |= SIMPLE;
9120    /* XXX:dmq : disabling in-place substitution seems to
9121    * be necessary here to avoid cases of memory corruption, as
9122    * with: C<$_="x" x 80; s/x\K/y/> -- rgs
9123    */
9124    RExC_seen |= REG_SEEN_LOOKBEHIND;
9125    goto finish_meta_pat;
9126   case 'Z':
9127    ret = reg_node(pRExC_state, SEOL);
9128    *flagp |= SIMPLE;
9129    RExC_seen_zerolen++;  /* Do not optimize RE away */
9130    goto finish_meta_pat;
9131   case 'z':
9132    ret = reg_node(pRExC_state, EOS);
9133    *flagp |= SIMPLE;
9134    RExC_seen_zerolen++;  /* Do not optimize RE away */
9135    goto finish_meta_pat;
9136   case 'C':
9137    ret = reg_node(pRExC_state, CANY);
9138    RExC_seen |= REG_SEEN_CANY;
9139    *flagp |= HASWIDTH|SIMPLE;
9140    goto finish_meta_pat;
9141   case 'X':
9142    ret = reg_node(pRExC_state, CLUMP);
9143    *flagp |= HASWIDTH;
9144    goto finish_meta_pat;
9145   case 'w':
9146    switch (get_regex_charset(RExC_flags)) {
9147     case REGEX_LOCALE_CHARSET:
9148      op = ALNUML;
9149      break;
9150     case REGEX_UNICODE_CHARSET:
9151      op = ALNUMU;
9152      break;
9153     case REGEX_ASCII_RESTRICTED_CHARSET:
9154     case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9155      op = ALNUMA;
9156      break;
9157     case REGEX_DEPENDS_CHARSET:
9158      op = ALNUM;
9159      break;
9160     default:
9161      goto bad_charset;
9162    }
9163    ret = reg_node(pRExC_state, op);
9164    *flagp |= HASWIDTH|SIMPLE;
9165    goto finish_meta_pat;
9166   case 'W':
9167    switch (get_regex_charset(RExC_flags)) {
9168     case REGEX_LOCALE_CHARSET:
9169      op = NALNUML;
9170      break;
9171     case REGEX_UNICODE_CHARSET:
9172      op = NALNUMU;
9173      break;
9174     case REGEX_ASCII_RESTRICTED_CHARSET:
9175     case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9176      op = NALNUMA;
9177      break;
9178     case REGEX_DEPENDS_CHARSET:
9179      op = NALNUM;
9180      break;
9181     default:
9182      goto bad_charset;
9183    }
9184    ret = reg_node(pRExC_state, op);
9185    *flagp |= HASWIDTH|SIMPLE;
9186    goto finish_meta_pat;
9187   case 'b':
9188    RExC_seen_zerolen++;
9189    RExC_seen |= REG_SEEN_LOOKBEHIND;
9190    switch (get_regex_charset(RExC_flags)) {
9191     case REGEX_LOCALE_CHARSET:
9192      op = BOUNDL;
9193      break;
9194     case REGEX_UNICODE_CHARSET:
9195      op = BOUNDU;
9196      break;
9197     case REGEX_ASCII_RESTRICTED_CHARSET:
9198     case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9199      op = BOUNDA;
9200      break;
9201     case REGEX_DEPENDS_CHARSET:
9202      op = BOUND;
9203      break;
9204     default:
9205      goto bad_charset;
9206    }
9207    ret = reg_node(pRExC_state, op);
9208    FLAGS(ret) = get_regex_charset(RExC_flags);
9209    *flagp |= SIMPLE;
9210    if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
9211     ckWARNregdep(RExC_parse, "\"\\b{\" is deprecated; use \"\\b\\{\" instead");
9212    }
9213    goto finish_meta_pat;
9214   case 'B':
9215    RExC_seen_zerolen++;
9216    RExC_seen |= REG_SEEN_LOOKBEHIND;
9217    switch (get_regex_charset(RExC_flags)) {
9218     case REGEX_LOCALE_CHARSET:
9219      op = NBOUNDL;
9220      break;
9221     case REGEX_UNICODE_CHARSET:
9222      op = NBOUNDU;
9223      break;
9224     case REGEX_ASCII_RESTRICTED_CHARSET:
9225     case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9226      op = NBOUNDA;
9227      break;
9228     case REGEX_DEPENDS_CHARSET:
9229      op = NBOUND;
9230      break;
9231     default:
9232      goto bad_charset;
9233    }
9234    ret = reg_node(pRExC_state, op);
9235    FLAGS(ret) = get_regex_charset(RExC_flags);
9236    *flagp |= SIMPLE;
9237    if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
9238     ckWARNregdep(RExC_parse, "\"\\B{\" is deprecated; use \"\\B\\{\" instead");
9239    }
9240    goto finish_meta_pat;
9241   case 's':
9242    switch (get_regex_charset(RExC_flags)) {
9243     case REGEX_LOCALE_CHARSET:
9244      op = SPACEL;
9245      break;
9246     case REGEX_UNICODE_CHARSET:
9247      op = SPACEU;
9248      break;
9249     case REGEX_ASCII_RESTRICTED_CHARSET:
9250     case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9251      op = SPACEA;
9252      break;
9253     case REGEX_DEPENDS_CHARSET:
9254      op = SPACE;
9255      break;
9256     default:
9257      goto bad_charset;
9258    }
9259    ret = reg_node(pRExC_state, op);
9260    *flagp |= HASWIDTH|SIMPLE;
9261    goto finish_meta_pat;
9262   case 'S':
9263    switch (get_regex_charset(RExC_flags)) {
9264     case REGEX_LOCALE_CHARSET:
9265      op = NSPACEL;
9266      break;
9267     case REGEX_UNICODE_CHARSET:
9268      op = NSPACEU;
9269      break;
9270     case REGEX_ASCII_RESTRICTED_CHARSET:
9271     case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9272      op = NSPACEA;
9273      break;
9274     case REGEX_DEPENDS_CHARSET:
9275      op = NSPACE;
9276      break;
9277     default:
9278      goto bad_charset;
9279    }
9280    ret = reg_node(pRExC_state, op);
9281    *flagp |= HASWIDTH|SIMPLE;
9282    goto finish_meta_pat;
9283   case 'd':
9284    switch (get_regex_charset(RExC_flags)) {
9285     case REGEX_LOCALE_CHARSET:
9286      op = DIGITL;
9287      break;
9288     case REGEX_ASCII_RESTRICTED_CHARSET:
9289     case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9290      op = DIGITA;
9291      break;
9292     case REGEX_DEPENDS_CHARSET: /* No difference between these */
9293     case REGEX_UNICODE_CHARSET:
9294      op = DIGIT;
9295      break;
9296     default:
9297      goto bad_charset;
9298    }
9299    ret = reg_node(pRExC_state, op);
9300    *flagp |= HASWIDTH|SIMPLE;
9301    goto finish_meta_pat;
9302   case 'D':
9303    switch (get_regex_charset(RExC_flags)) {
9304     case REGEX_LOCALE_CHARSET:
9305      op = NDIGITL;
9306      break;
9307     case REGEX_ASCII_RESTRICTED_CHARSET:
9308     case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9309      op = NDIGITA;
9310      break;
9311     case REGEX_DEPENDS_CHARSET: /* No difference between these */
9312     case REGEX_UNICODE_CHARSET:
9313      op = NDIGIT;
9314      break;
9315     default:
9316      goto bad_charset;
9317    }
9318    ret = reg_node(pRExC_state, op);
9319    *flagp |= HASWIDTH|SIMPLE;
9320    goto finish_meta_pat;
9321   case 'R':
9322    ret = reg_node(pRExC_state, LNBREAK);
9323    *flagp |= HASWIDTH|SIMPLE;
9324    goto finish_meta_pat;
9325   case 'h':
9326    ret = reg_node(pRExC_state, HORIZWS);
9327    *flagp |= HASWIDTH|SIMPLE;
9328    goto finish_meta_pat;
9329   case 'H':
9330    ret = reg_node(pRExC_state, NHORIZWS);
9331    *flagp |= HASWIDTH|SIMPLE;
9332    goto finish_meta_pat;
9333   case 'v':
9334    ret = reg_node(pRExC_state, VERTWS);
9335    *flagp |= HASWIDTH|SIMPLE;
9336    goto finish_meta_pat;
9337   case 'V':
9338    ret = reg_node(pRExC_state, NVERTWS);
9339    *flagp |= HASWIDTH|SIMPLE;
9340   finish_meta_pat:
9341    nextchar(pRExC_state);
9342    Set_Node_Length(ret, 2); /* MJD */
9343    break;
9344   case 'p':
9345   case 'P':
9346    {
9347     char* const oldregxend = RExC_end;
9348 #ifdef DEBUGGING
9349     char* parse_start = RExC_parse - 2;
9350 #endif
9351
9352     if (RExC_parse[1] == '{') {
9353     /* a lovely hack--pretend we saw [\pX] instead */
9354      RExC_end = strchr(RExC_parse, '}');
9355      if (!RExC_end) {
9356       const U8 c = (U8)*RExC_parse;
9357       RExC_parse += 2;
9358       RExC_end = oldregxend;
9359       vFAIL2("Missing right brace on \\%c{}", c);
9360      }
9361      RExC_end++;
9362     }
9363     else {
9364      RExC_end = RExC_parse + 2;
9365      if (RExC_end > oldregxend)
9366       RExC_end = oldregxend;
9367     }
9368     RExC_parse--;
9369
9370     ret = regclass(pRExC_state,depth+1);
9371
9372     RExC_end = oldregxend;
9373     RExC_parse--;
9374
9375     Set_Node_Offset(ret, parse_start + 2);
9376     Set_Node_Cur_Length(ret);
9377     nextchar(pRExC_state);
9378     *flagp |= HASWIDTH|SIMPLE;
9379    }
9380    break;
9381   case 'N':
9382    /* Handle \N and \N{NAME} here and not below because it can be
9383    multicharacter. join_exact() will join them up later on.
9384    Also this makes sure that things like /\N{BLAH}+/ and
9385    \N{BLAH} being multi char Just Happen. dmq*/
9386    ++RExC_parse;
9387    ret= reg_namedseq(pRExC_state, NULL, flagp, depth);
9388    break;
9389   case 'k':    /* Handle \k<NAME> and \k'NAME' */
9390   parse_named_seq:
9391   {
9392    char ch= RExC_parse[1];
9393    if (ch != '<' && ch != '\'' && ch != '{') {
9394     RExC_parse++;
9395     vFAIL2("Sequence %.2s... not terminated",parse_start);
9396    } else {
9397     /* this pretty much dupes the code for (?P=...) in reg(), if
9398     you change this make sure you change that */
9399     char* name_start = (RExC_parse += 2);
9400     U32 num = 0;
9401     SV *sv_dat = reg_scan_name(pRExC_state,
9402      SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
9403     ch= (ch == '<') ? '>' : (ch == '{') ? '}' : '\'';
9404     if (RExC_parse == name_start || *RExC_parse != ch)
9405      vFAIL2("Sequence %.3s... not terminated",parse_start);
9406
9407     if (!SIZE_ONLY) {
9408      num = add_data( pRExC_state, 1, "S" );
9409      RExC_rxi->data->data[num]=(void*)sv_dat;
9410      SvREFCNT_inc_simple_void(sv_dat);
9411     }
9412
9413     RExC_sawback = 1;
9414     ret = reganode(pRExC_state,
9415        ((! FOLD)
9416         ? NREF
9417         : (MORE_ASCII_RESTRICTED)
9418         ? NREFFA
9419         : (AT_LEAST_UNI_SEMANTICS)
9420          ? NREFFU
9421          : (LOC)
9422          ? NREFFL
9423          : NREFF),
9424         num);
9425     *flagp |= HASWIDTH;
9426
9427     /* override incorrect value set in reganode MJD */
9428     Set_Node_Offset(ret, parse_start+1);
9429     Set_Node_Cur_Length(ret); /* MJD */
9430     nextchar(pRExC_state);
9431
9432    }
9433    break;
9434   }
9435   case 'g':
9436   case '1': case '2': case '3': case '4':
9437   case '5': case '6': case '7': case '8': case '9':
9438    {
9439     I32 num;
9440     bool isg = *RExC_parse == 'g';
9441     bool isrel = 0;
9442     bool hasbrace = 0;
9443     if (isg) {
9444      RExC_parse++;
9445      if (*RExC_parse == '{') {
9446       RExC_parse++;
9447       hasbrace = 1;
9448      }
9449      if (*RExC_parse == '-') {
9450       RExC_parse++;
9451       isrel = 1;
9452      }
9453      if (hasbrace && !isDIGIT(*RExC_parse)) {
9454       if (isrel) RExC_parse--;
9455       RExC_parse -= 2;
9456       goto parse_named_seq;
9457     }   }
9458     num = atoi(RExC_parse);
9459     if (isg && num == 0)
9460      vFAIL("Reference to invalid group 0");
9461     if (isrel) {
9462      num = RExC_npar - num;
9463      if (num < 1)
9464       vFAIL("Reference to nonexistent or unclosed group");
9465     }
9466     if (!isg && num > 9 && num >= RExC_npar)
9467      goto defchar;
9468     else {
9469      char * const parse_start = RExC_parse - 1; /* MJD */
9470      while (isDIGIT(*RExC_parse))
9471       RExC_parse++;
9472      if (parse_start == RExC_parse - 1)
9473       vFAIL("Unterminated \\g... pattern");
9474      if (hasbrace) {
9475       if (*RExC_parse != '}')
9476        vFAIL("Unterminated \\g{...} pattern");
9477       RExC_parse++;
9478      }
9479      if (!SIZE_ONLY) {
9480       if (num > (I32)RExC_rx->nparens)
9481        vFAIL("Reference to nonexistent group");
9482      }
9483      RExC_sawback = 1;
9484      ret = reganode(pRExC_state,
9485         ((! FOLD)
9486          ? REF
9487          : (MORE_ASCII_RESTRICTED)
9488          ? REFFA
9489          : (AT_LEAST_UNI_SEMANTICS)
9490           ? REFFU
9491           : (LOC)
9492           ? REFFL
9493           : REFF),
9494          num);
9495      *flagp |= HASWIDTH;
9496
9497      /* override incorrect value set in reganode MJD */
9498      Set_Node_Offset(ret, parse_start+1);
9499      Set_Node_Cur_Length(ret); /* MJD */
9500      RExC_parse--;
9501      nextchar(pRExC_state);
9502     }
9503    }
9504    break;
9505   case '\0':
9506    if (RExC_parse >= RExC_end)
9507     FAIL("Trailing \\");
9508    /* FALL THROUGH */
9509   default:
9510    /* Do not generate "unrecognized" warnings here, we fall
9511    back into the quick-grab loop below */
9512    parse_start--;
9513    goto defchar;
9514   }
9515   break;
9516
9517  case '#':
9518   if (RExC_flags & RXf_PMf_EXTENDED) {
9519    if ( reg_skipcomment( pRExC_state ) )
9520     goto tryagain;
9521   }
9522   /* FALL THROUGH */
9523
9524  default:
9525
9526    parse_start = RExC_parse - 1;
9527
9528    RExC_parse++;
9529
9530   defchar: {
9531    register STRLEN len;
9532    register UV ender;
9533    register char *p;
9534    char *s;
9535    STRLEN foldlen;
9536    U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
9537    U8 node_type;
9538
9539    /* Is this a LATIN LOWER CASE SHARP S in an EXACTFU node?  If so,
9540    * it is folded to 'ss' even if not utf8 */
9541    bool is_exactfu_sharp_s;
9542
9543    ender = 0;
9544    node_type = ((! FOLD) ? EXACT
9545       : (LOC)
9546       ? EXACTFL
9547       : (MORE_ASCII_RESTRICTED)
9548        ? EXACTFA
9549        : (AT_LEAST_UNI_SEMANTICS)
9550        ? EXACTFU
9551        : EXACTF);
9552    ret = reg_node(pRExC_state, node_type);
9553    s = STRING(ret);
9554
9555    /* XXX The node can hold up to 255 bytes, yet this only goes to
9556    * 127.  I (khw) do not know why.  Keeping it somewhat less than
9557    * 255 allows us to not have to worry about overflow due to
9558    * converting to utf8 and fold expansion, but that value is
9559    * 255-UTF8_MAXBYTES_CASE.  join_exact() may join adjacent nodes
9560    * split up by this limit into a single one using the real max of
9561    * 255.  Even at 127, this breaks under rare circumstances.  If
9562    * folding, we do not want to split a node at a character that is a
9563    * non-final in a multi-char fold, as an input string could just
9564    * happen to want to match across the node boundary.  The join
9565    * would solve that problem if the join actually happens.  But a
9566    * series of more than two nodes in a row each of 127 would cause
9567    * the first join to succeed to get to 254, but then there wouldn't
9568    * be room for the next one, which could at be one of those split
9569    * multi-char folds.  I don't know of any fool-proof solution.  One
9570    * could back off to end with only a code point that isn't such a
9571    * non-final, but it is possible for there not to be any in the
9572    * entire node. */
9573    for (len = 0, p = RExC_parse - 1;
9574     len < 127 && p < RExC_end;
9575     len++)
9576    {
9577     char * const oldp = p;
9578
9579     if (RExC_flags & RXf_PMf_EXTENDED)
9580      p = regwhite( pRExC_state, p );
9581     switch ((U8)*p) {
9582     case '^':
9583     case '$':
9584     case '.':
9585     case '[':
9586     case '(':
9587     case ')':
9588     case '|':
9589      goto loopdone;
9590     case '\\':
9591      /* Literal Escapes Switch
9592
9593      This switch is meant to handle escape sequences that
9594      resolve to a literal character.
9595
9596      Every escape sequence that represents something
9597      else, like an assertion or a char class, is handled
9598      in the switch marked 'Special Escapes' above in this
9599      routine, but also has an entry here as anything that
9600      isn't explicitly mentioned here will be treated as
9601      an unescaped equivalent literal.
9602      */
9603
9604      switch ((U8)*++p) {
9605      /* These are all the special escapes. */
9606      case 'A':             /* Start assertion */
9607      case 'b': case 'B':   /* Word-boundary assertion*/
9608      case 'C':             /* Single char !DANGEROUS! */
9609      case 'd': case 'D':   /* digit class */
9610      case 'g': case 'G':   /* generic-backref, pos assertion */
9611      case 'h': case 'H':   /* HORIZWS */
9612      case 'k': case 'K':   /* named backref, keep marker */
9613      case 'N':             /* named char sequence */
9614      case 'p': case 'P':   /* Unicode property */
9615        case 'R':   /* LNBREAK */
9616      case 's': case 'S':   /* space class */
9617      case 'v': case 'V':   /* VERTWS */
9618      case 'w': case 'W':   /* word class */
9619      case 'X':             /* eXtended Unicode "combining character sequence" */
9620      case 'z': case 'Z':   /* End of line/string assertion */
9621       --p;
9622       goto loopdone;
9623
9624      /* Anything after here is an escape that resolves to a
9625      literal. (Except digits, which may or may not)
9626      */
9627      case 'n':
9628       ender = '\n';
9629       p++;
9630       break;
9631      case 'r':
9632       ender = '\r';
9633       p++;
9634       break;
9635      case 't':
9636       ender = '\t';
9637       p++;
9638       break;
9639      case 'f':
9640       ender = '\f';
9641       p++;
9642       break;
9643      case 'e':
9644       ender = ASCII_TO_NATIVE('\033');
9645       p++;
9646       break;
9647      case 'a':
9648       ender = ASCII_TO_NATIVE('\007');
9649       p++;
9650       break;
9651      case 'o':
9652       {
9653        STRLEN brace_len = len;
9654        UV result;
9655        const char* error_msg;
9656
9657        bool valid = grok_bslash_o(p,
9658              &result,
9659              &brace_len,
9660              &error_msg,
9661              1);
9662        p += brace_len;
9663        if (! valid) {
9664         RExC_parse = p; /* going to die anyway; point
9665             to exact spot of failure */
9666         vFAIL(error_msg);
9667        }
9668        else
9669        {
9670         ender = result;
9671        }
9672        if (PL_encoding && ender < 0x100) {
9673         goto recode_encoding;
9674        }
9675        if (ender > 0xff) {
9676         REQUIRE_UTF8;
9677        }
9678        break;
9679       }
9680      case 'x':
9681       if (*++p == '{') {
9682        char* const e = strchr(p, '}');
9683
9684        if (!e) {
9685         RExC_parse = p + 1;
9686         vFAIL("Missing right brace on \\x{}");
9687        }
9688        else {
9689         I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
9690          | PERL_SCAN_DISALLOW_PREFIX;
9691         STRLEN numlen = e - p - 1;
9692         ender = grok_hex(p + 1, &numlen, &flags, NULL);
9693         if (ender > 0xff)
9694          REQUIRE_UTF8;
9695         p = e + 1;
9696        }
9697       }
9698       else {
9699        I32 flags = PERL_SCAN_DISALLOW_PREFIX;
9700        STRLEN numlen = 2;
9701        ender = grok_hex(p, &numlen, &flags, NULL);
9702        p += numlen;
9703       }
9704       if (PL_encoding && ender < 0x100)
9705        goto recode_encoding;
9706       break;
9707      case 'c':
9708       p++;
9709       ender = grok_bslash_c(*p++, UTF, SIZE_ONLY);
9710       break;
9711      case '0': case '1': case '2': case '3':case '4':
9712      case '5': case '6': case '7': case '8':case '9':
9713       if (*p == '0' ||
9714        (isDIGIT(p[1]) && atoi(p) >= RExC_npar))
9715       {
9716        I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
9717        STRLEN numlen = 3;
9718        ender = grok_oct(p, &numlen, &flags, NULL);
9719        if (ender > 0xff) {
9720         REQUIRE_UTF8;
9721        }
9722        p += numlen;
9723       }
9724       else {
9725        --p;
9726        goto loopdone;
9727       }
9728       if (PL_encoding && ender < 0x100)
9729        goto recode_encoding;
9730       break;
9731      recode_encoding:
9732       if (! RExC_override_recoding) {
9733        SV* enc = PL_encoding;
9734        ender = reg_recode((const char)(U8)ender, &enc);
9735        if (!enc && SIZE_ONLY)
9736         ckWARNreg(p, "Invalid escape in the specified encoding");
9737        REQUIRE_UTF8;
9738       }
9739       break;
9740      case '\0':
9741       if (p >= RExC_end)
9742        FAIL("Trailing \\");
9743       /* FALL THROUGH */
9744      default:
9745       if (!SIZE_ONLY&& isALPHA(*p)) {
9746        /* Include any { following the alpha to emphasize
9747        * that it could be part of an escape at some point
9748        * in the future */
9749        int len = (*(p + 1) == '{') ? 2 : 1;
9750        ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p);
9751       }
9752       goto normal_default;
9753      }
9754      break;
9755     default:
9756     normal_default:
9757      if (UTF8_IS_START(*p) && UTF) {
9758       STRLEN numlen;
9759       ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
9760            &numlen, UTF8_ALLOW_DEFAULT);
9761       p += numlen;
9762      }
9763      else
9764       ender = (U8) *p++;
9765      break;
9766     } /* End of switch on the literal */
9767
9768     is_exactfu_sharp_s = (node_type == EXACTFU
9769          && ender == LATIN_SMALL_LETTER_SHARP_S);
9770     if ( RExC_flags & RXf_PMf_EXTENDED)
9771      p = regwhite( pRExC_state, p );
9772     if ((UTF && FOLD) || is_exactfu_sharp_s) {
9773      /* Prime the casefolded buffer.  Locale rules, which apply
9774      * only to code points < 256, aren't known until execution,
9775      * so for them, just output the original character using
9776      * utf8.  If we start to fold non-UTF patterns, be sure to
9777      * update join_exact() */
9778      if (LOC && ender < 256) {
9779       if (UNI_IS_INVARIANT(ender)) {
9780        *tmpbuf = (U8) ender;
9781        foldlen = 1;
9782       } else {
9783        *tmpbuf = UTF8_TWO_BYTE_HI(ender);
9784        *(tmpbuf + 1) = UTF8_TWO_BYTE_LO(ender);
9785        foldlen = 2;
9786       }
9787      }
9788      else if (isASCII(ender)) { /* Note: Here can't also be LOC
9789             */
9790       ender = toLOWER(ender);
9791       *tmpbuf = (U8) ender;
9792       foldlen = 1;
9793      }
9794      else if (! MORE_ASCII_RESTRICTED && ! LOC) {
9795
9796       /* Locale and /aa require more selectivity about the
9797       * fold, so are handled below.  Otherwise, here, just
9798       * use the fold */
9799       ender = toFOLD_uni(ender, tmpbuf, &foldlen);
9800      }
9801      else {
9802       /* Under locale rules or /aa we are not to mix,
9803       * respectively, ords < 256 or ASCII with non-.  So
9804       * reject folds that mix them, using only the
9805       * non-folded code point.  So do the fold to a
9806       * temporary, and inspect each character in it. */
9807       U8 trialbuf[UTF8_MAXBYTES_CASE+1];
9808       U8* s = trialbuf;
9809       UV tmpender = toFOLD_uni(ender, trialbuf, &foldlen);
9810       U8* e = s + foldlen;
9811       bool fold_ok = TRUE;
9812
9813       while (s < e) {
9814        if (isASCII(*s)
9815         || (LOC && (UTF8_IS_INVARIANT(*s)
9816           || UTF8_IS_DOWNGRADEABLE_START(*s))))
9817        {
9818         fold_ok = FALSE;
9819         break;
9820        }
9821        s += UTF8SKIP(s);
9822       }
9823       if (fold_ok) {
9824        Copy(trialbuf, tmpbuf, foldlen, U8);
9825        ender = tmpender;
9826       }
9827       else {
9828        uvuni_to_utf8(tmpbuf, ender);
9829        foldlen = UNISKIP(ender);
9830       }
9831      }
9832     }
9833     if (p < RExC_end && ISMULT2(p)) { /* Back off on ?+*. */
9834      if (len)
9835       p = oldp;
9836      else if (UTF || is_exactfu_sharp_s) {
9837       if (FOLD) {
9838        /* Emit all the Unicode characters. */
9839        STRLEN numlen;
9840        for (foldbuf = tmpbuf;
9841         foldlen;
9842         foldlen -= numlen) {
9843
9844         /* tmpbuf has been constructed by us, so we
9845          * know it is valid utf8 */
9846         ender = valid_utf8_to_uvchr(foldbuf, &numlen);
9847         if (numlen > 0) {
9848           const STRLEN unilen = reguni(pRExC_state, ender, s);
9849           s       += unilen;
9850           len     += unilen;
9851           /* In EBCDIC the numlen
9852           * and unilen can differ. */
9853           foldbuf += numlen;
9854           if (numlen >= foldlen)
9855            break;
9856         }
9857         else
9858           break; /* "Can't happen." */
9859        }
9860       }
9861       else {
9862        const STRLEN unilen = reguni(pRExC_state, ender, s);
9863        if (unilen > 0) {
9864         s   += unilen;
9865         len += unilen;
9866        }
9867       }
9868      }
9869      else {
9870       len++;
9871       REGC((char)ender, s++);
9872      }
9873      break;
9874     }
9875     if (UTF || is_exactfu_sharp_s) {
9876      if (FOLD) {
9877       /* Emit all the Unicode characters. */
9878       STRLEN numlen;
9879       for (foldbuf = tmpbuf;
9880        foldlen;
9881        foldlen -= numlen) {
9882        ender = valid_utf8_to_uvchr(foldbuf, &numlen);
9883        if (numlen > 0) {
9884          const STRLEN unilen = reguni(pRExC_state, ender, s);
9885          len     += unilen;
9886          s       += unilen;
9887          /* In EBCDIC the numlen
9888          * and unilen can differ. */
9889          foldbuf += numlen;
9890          if (numlen >= foldlen)
9891           break;
9892        }
9893        else
9894          break;
9895       }
9896      }
9897      else {
9898       const STRLEN unilen = reguni(pRExC_state, ender, s);
9899       if (unilen > 0) {
9900        s   += unilen;
9901        len += unilen;
9902       }
9903      }
9904      len--;
9905     }
9906     else {
9907      REGC((char)ender, s++);
9908     }
9909    }
9910   loopdone:   /* Jumped to when encounters something that shouldn't be in
9911      the node */
9912    RExC_parse = p - 1;
9913    Set_Node_Cur_Length(ret); /* MJD */
9914    nextchar(pRExC_state);
9915    {
9916     /* len is STRLEN which is unsigned, need to copy to signed */
9917     IV iv = len;
9918     if (iv < 0)
9919      vFAIL("Internal disaster");
9920    }
9921    if (len > 0)
9922     *flagp |= HASWIDTH;
9923    if (len == 1 && UNI_IS_INVARIANT(ender))
9924     *flagp |= SIMPLE;
9925
9926    if (SIZE_ONLY)
9927     RExC_size += STR_SZ(len);
9928    else {
9929     STR_LEN(ret) = len;
9930     RExC_emit += STR_SZ(len);
9931    }
9932   }
9933   break;
9934  }
9935
9936  return(ret);
9937
9938 /* Jumped to when an unrecognized character set is encountered */
9939 bad_charset:
9940  Perl_croak(aTHX_ "panic: Unknown regex character set encoding: %u", get_regex_charset(RExC_flags));
9941  return(NULL);
9942 }
9943
9944 STATIC char *
9945 S_regwhite( RExC_state_t *pRExC_state, char *p )
9946 {
9947  const char *e = RExC_end;
9948
9949  PERL_ARGS_ASSERT_REGWHITE;
9950
9951  while (p < e) {
9952   if (isSPACE(*p))
9953    ++p;
9954   else if (*p == '#') {
9955    bool ended = 0;
9956    do {
9957     if (*p++ == '\n') {
9958      ended = 1;
9959      break;
9960     }
9961    } while (p < e);
9962    if (!ended)
9963     RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
9964   }
9965   else
9966    break;
9967  }
9968  return p;
9969 }
9970
9971 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
9972    Character classes ([:foo:]) can also be negated ([:^foo:]).
9973    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
9974    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
9975    but trigger failures because they are currently unimplemented. */
9976
9977 #define POSIXCC_DONE(c)   ((c) == ':')
9978 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
9979 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
9980
9981 STATIC I32
9982 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
9983 {
9984  dVAR;
9985  I32 namedclass = OOB_NAMEDCLASS;
9986
9987  PERL_ARGS_ASSERT_REGPPOSIXCC;
9988
9989  if (value == '[' && RExC_parse + 1 < RExC_end &&
9990   /* I smell either [: or [= or [. -- POSIX has been here, right? */
9991   POSIXCC(UCHARAT(RExC_parse))) {
9992   const char c = UCHARAT(RExC_parse);
9993   char* const s = RExC_parse++;
9994
9995   while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
9996    RExC_parse++;
9997   if (RExC_parse == RExC_end)
9998    /* Grandfather lone [:, [=, [. */
9999    RExC_parse = s;
10000   else {
10001    const char* const t = RExC_parse++; /* skip over the c */
10002    assert(*t == c);
10003
10004    if (UCHARAT(RExC_parse) == ']') {
10005     const char *posixcc = s + 1;
10006     RExC_parse++; /* skip over the ending ] */
10007
10008     if (*s == ':') {
10009      const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
10010      const I32 skip = t - posixcc;
10011
10012      /* Initially switch on the length of the name.  */
10013      switch (skip) {
10014      case 4:
10015       if (memEQ(posixcc, "word", 4)) /* this is not POSIX, this is the Perl \w */
10016        namedclass = complement ? ANYOF_NALNUM : ANYOF_ALNUM;
10017       break;
10018      case 5:
10019       /* Names all of length 5.  */
10020       /* alnum alpha ascii blank cntrl digit graph lower
10021       print punct space upper  */
10022       /* Offset 4 gives the best switch position.  */
10023       switch (posixcc[4]) {
10024       case 'a':
10025        if (memEQ(posixcc, "alph", 4)) /* alpha */
10026         namedclass = complement ? ANYOF_NALPHA : ANYOF_ALPHA;
10027        break;
10028       case 'e':
10029        if (memEQ(posixcc, "spac", 4)) /* space */
10030         namedclass = complement ? ANYOF_NPSXSPC : ANYOF_PSXSPC;
10031        break;
10032       case 'h':
10033        if (memEQ(posixcc, "grap", 4)) /* graph */
10034         namedclass = complement ? ANYOF_NGRAPH : ANYOF_GRAPH;
10035        break;
10036       case 'i':
10037        if (memEQ(posixcc, "asci", 4)) /* ascii */
10038         namedclass = complement ? ANYOF_NASCII : ANYOF_ASCII;
10039        break;
10040       case 'k':
10041        if (memEQ(posixcc, "blan", 4)) /* blank */
10042         namedclass = complement ? ANYOF_NBLANK : ANYOF_BLANK;
10043        break;
10044       case 'l':
10045        if (memEQ(posixcc, "cntr", 4)) /* cntrl */
10046         namedclass = complement ? ANYOF_NCNTRL : ANYOF_CNTRL;
10047        break;
10048       case 'm':
10049        if (memEQ(posixcc, "alnu", 4)) /* alnum */
10050         namedclass = complement ? ANYOF_NALNUMC : ANYOF_ALNUMC;
10051        break;
10052       case 'r':
10053        if (memEQ(posixcc, "lowe", 4)) /* lower */
10054         namedclass = complement ? ANYOF_NLOWER : ANYOF_LOWER;
10055        else if (memEQ(posixcc, "uppe", 4)) /* upper */
10056         namedclass = complement ? ANYOF_NUPPER : ANYOF_UPPER;
10057        break;
10058       case 't':
10059        if (memEQ(posixcc, "digi", 4)) /* digit */
10060         namedclass = complement ? ANYOF_NDIGIT : ANYOF_DIGIT;
10061        else if (memEQ(posixcc, "prin", 4)) /* print */
10062         namedclass = complement ? ANYOF_NPRINT : ANYOF_PRINT;
10063        else if (memEQ(posixcc, "punc", 4)) /* punct */
10064         namedclass = complement ? ANYOF_NPUNCT : ANYOF_PUNCT;
10065        break;
10066       }
10067       break;
10068      case 6:
10069       if (memEQ(posixcc, "xdigit", 6))
10070        namedclass = complement ? ANYOF_NXDIGIT : ANYOF_XDIGIT;
10071       break;
10072      }
10073
10074      if (namedclass == OOB_NAMEDCLASS)
10075       Simple_vFAIL3("POSIX class [:%.*s:] unknown",
10076          t - s - 1, s + 1);
10077      assert (posixcc[skip] == ':');
10078      assert (posixcc[skip+1] == ']');
10079     } else if (!SIZE_ONLY) {
10080      /* [[=foo=]] and [[.foo.]] are still future. */
10081
10082      /* adjust RExC_parse so the warning shows after
10083      the class closes */
10084      while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
10085       RExC_parse++;
10086      Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
10087     }
10088    } else {
10089     /* Maternal grandfather:
10090     * "[:" ending in ":" but not in ":]" */
10091     RExC_parse = s;
10092    }
10093   }
10094  }
10095
10096  return namedclass;
10097 }
10098
10099 STATIC void
10100 S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
10101 {
10102  dVAR;
10103
10104  PERL_ARGS_ASSERT_CHECKPOSIXCC;
10105
10106  if (POSIXCC(UCHARAT(RExC_parse))) {
10107   const char *s = RExC_parse;
10108   const char  c = *s++;
10109
10110   while (isALNUM(*s))
10111    s++;
10112   if (*s && c == *s && s[1] == ']') {
10113    ckWARN3reg(s+2,
10114      "POSIX syntax [%c %c] belongs inside character classes",
10115      c, c);
10116
10117    /* [[=foo=]] and [[.foo.]] are still future. */
10118    if (POSIXCC_NOTYET(c)) {
10119     /* adjust RExC_parse so the error shows after
10120     the class closes */
10121     while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
10122      NOOP;
10123     Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
10124    }
10125   }
10126  }
10127 }
10128
10129 /* Generate the code to add a full posix character <class> to the bracketed
10130  * character class given by <node>.  (<node> is needed only under locale rules)
10131  * destlist     is the inversion list for non-locale rules that this class is
10132  *              to be added to
10133  * sourcelist   is the ASCII-range inversion list to add under /a rules
10134  * Xsourcelist  is the full Unicode range list to use otherwise. */
10135 #define DO_POSIX(node, class, destlist, sourcelist, Xsourcelist)           \
10136  if (LOC) {                                                             \
10137   SV* scratch_list = NULL;                                           \
10138                   \
10139   /* Set this class in the node for runtime matching */              \
10140   ANYOF_CLASS_SET(node, class);                                      \
10141                   \
10142   /* For above Latin1 code points, we use the full Unicode range */  \
10143   _invlist_intersection(PL_AboveLatin1,                              \
10144        Xsourcelist,                                 \
10145        &scratch_list);                              \
10146   /* And set the output to it, adding instead if there already is an \
10147   * output.  Checking if <destlist> is NULL first saves an extra    \
10148   * clone.  Its reference count will be decremented at the next     \
10149   * union, etc, or if this is the only instance, at the end of the  \
10150   * routine */                                                      \
10151   if (! destlist) {                                                  \
10152    destlist = scratch_list;                                       \
10153   }                                                                  \
10154   else {                                                             \
10155    _invlist_union(destlist, scratch_list, &destlist);             \
10156    SvREFCNT_dec(scratch_list);                                    \
10157   }                                                                  \
10158  }                                                                      \
10159  else {                                                                 \
10160   /* For non-locale, just add it to any existing list */             \
10161   _invlist_union(destlist,                                           \
10162      (AT_LEAST_ASCII_RESTRICTED)                         \
10163       ? sourcelist                                    \
10164       : Xsourcelist,                                  \
10165      &destlist);                                         \
10166  }
10167
10168 /* Like DO_POSIX, but matches the complement of <sourcelist> and <Xsourcelist>.
10169  */
10170 #define DO_N_POSIX(node, class, destlist, sourcelist, Xsourcelist)         \
10171  if (LOC) {                                                             \
10172   SV* scratch_list = NULL;                                           \
10173   ANYOF_CLASS_SET(node, class);        \
10174   _invlist_subtract(PL_AboveLatin1, Xsourcelist, &scratch_list);    \
10175   if (! destlist) {                \
10176    destlist = scratch_list;        \
10177   }                                                                  \
10178   else {                                                             \
10179    _invlist_union(destlist, scratch_list, &destlist);             \
10180    SvREFCNT_dec(scratch_list);                                    \
10181   }                                                                  \
10182  }                                                                      \
10183  else {                                                                 \
10184   _invlist_union_complement_2nd(destlist,                            \
10185          (AT_LEAST_ASCII_RESTRICTED)            \
10186           ? sourcelist                       \
10187           : Xsourcelist,                     \
10188          &destlist);                            \
10189   /* Under /d, everything in the upper half of the Latin1 range      \
10190   * matches this complement */                                      \
10191   if (DEPENDS_SEMANTICS) {                                           \
10192    ANYOF_FLAGS(node) |= ANYOF_NON_UTF8_LATIN1_ALL;                \
10193   }                                                                  \
10194  }
10195
10196 /* Generate the code to add a posix character <class> to the bracketed
10197  * character class given by <node>.  (<node> is needed only under locale rules)
10198  * destlist       is the inversion list for non-locale rules that this class is
10199  *                to be added to
10200  * sourcelist     is the ASCII-range inversion list to add under /a rules
10201  * l1_sourcelist  is the Latin1 range list to use otherwise.
10202  * Xpropertyname  is the name to add to <run_time_list> of the property to
10203  *                specify the code points above Latin1 that will have to be
10204  *                determined at run-time
10205  * run_time_list  is a SV* that contains text names of properties that are to
10206  *                be computed at run time.  This concatenates <Xpropertyname>
10207  *                to it, apppropriately
10208  * This is essentially DO_POSIX, but we know only the Latin1 values at compile
10209  * time */
10210 #define DO_POSIX_LATIN1_ONLY_KNOWN(node, class, destlist, sourcelist,      \
10211        l1_sourcelist, Xpropertyname, run_time_list) \
10212  /* If not /a matching, there are going to be code points we will have  \
10213  * to defer to runtime to look-up */                                   \
10214  if (! AT_LEAST_ASCII_RESTRICTED) {                                     \
10215   Perl_sv_catpvf(aTHX_ run_time_list, "+utf8::%s\n", Xpropertyname); \
10216  }                                                                      \
10217  if (LOC) {                                                             \
10218   ANYOF_CLASS_SET(node, class);                                      \
10219  }                                                                      \
10220  else {                                                                 \
10221   _invlist_union(destlist,                                           \
10222      (AT_LEAST_ASCII_RESTRICTED)                         \
10223       ? sourcelist                                    \
10224       : l1_sourcelist,                                \
10225      &destlist);                                         \
10226  }
10227
10228 /* Like DO_POSIX_LATIN1_ONLY_KNOWN, but for the complement.  A combination of
10229  * this and DO_N_POSIX */
10230 #define DO_N_POSIX_LATIN1_ONLY_KNOWN(node, class, destlist, sourcelist,    \
10231        l1_sourcelist, Xpropertyname, run_time_list) \
10232  if (AT_LEAST_ASCII_RESTRICTED) {                                       \
10233   _invlist_union_complement_2nd(destlist, sourcelist, &destlist);    \
10234  }                                                                      \
10235  else {                                                                 \
10236   Perl_sv_catpvf(aTHX_ run_time_list, "!utf8::%s\n", Xpropertyname); \
10237   if (LOC) {                                                         \
10238    ANYOF_CLASS_SET(node, namedclass);       \
10239   }                                                                  \
10240   else {                                                             \
10241    SV* scratch_list = NULL;                                       \
10242    _invlist_subtract(PL_Latin1, l1_sourcelist, &scratch_list);    \
10243    if (! destlist) {                                              \
10244     destlist = scratch_list;                                   \
10245    }                                                              \
10246    else {                                                         \
10247     _invlist_union(destlist, scratch_list, &destlist);         \
10248     SvREFCNT_dec(scratch_list);                                \
10249    }                                                              \
10250    if (DEPENDS_SEMANTICS) {                                       \
10251     ANYOF_FLAGS(node) |= ANYOF_NON_UTF8_LATIN1_ALL;            \
10252    }                                                              \
10253   }                                                                  \
10254  }
10255
10256 STATIC U8
10257 S_set_regclass_bit_fold(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, SV** invlist_ptr, AV** alternate_ptr)
10258 {
10259
10260  /* Handle the setting of folds in the bitmap for non-locale ANYOF nodes.
10261  * Locale folding is done at run-time, so this function should not be
10262  * called for nodes that are for locales.
10263  *
10264  * This function sets the bit corresponding to the fold of the input
10265  * 'value', if not already set.  The fold of 'f' is 'F', and the fold of
10266  * 'F' is 'f'.
10267  *
10268  * It also knows about the characters that are in the bitmap that have
10269  * folds that are matchable only outside it, and sets the appropriate lists
10270  * and flags.
10271  *
10272  * It returns the number of bits that actually changed from 0 to 1 */
10273
10274  U8 stored = 0;
10275  U8 fold;
10276
10277  PERL_ARGS_ASSERT_SET_REGCLASS_BIT_FOLD;
10278
10279  fold = (AT_LEAST_UNI_SEMANTICS) ? PL_fold_latin1[value]
10280          : PL_fold[value];
10281
10282  /* It assumes the bit for 'value' has already been set */
10283  if (fold != value && ! ANYOF_BITMAP_TEST(node, fold)) {
10284   ANYOF_BITMAP_SET(node, fold);
10285   stored++;
10286  }
10287  if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(value) && (! isASCII(value) || ! MORE_ASCII_RESTRICTED)) {
10288   /* Certain Latin1 characters have matches outside the bitmap.  To get
10289   * here, 'value' is one of those characters.   None of these matches is
10290   * valid for ASCII characters under /aa, which have been excluded by
10291   * the 'if' above.  The matches fall into three categories:
10292   * 1) They are singly folded-to or -from an above 255 character, as
10293   *    LATIN SMALL LETTER Y WITH DIAERESIS and LATIN CAPITAL LETTER Y
10294   *    WITH DIAERESIS;
10295   * 2) They are part of a multi-char fold with another character in the
10296   *    bitmap, only LATIN SMALL LETTER SHARP S => "ss" fits that bill;
10297   * 3) They are part of a multi-char fold with a character not in the
10298   *    bitmap, such as various ligatures.
10299   * We aren't dealing fully with multi-char folds, except we do deal
10300   * with the pattern containing a character that has a multi-char fold
10301   * (not so much the inverse).
10302   * For types 1) and 3), the matches only happen when the target string
10303   * is utf8; that's not true for 2), and we set a flag for it.
10304   *
10305   * The code below adds to the passed in inversion list the single fold
10306   * closures for 'value'.  The values are hard-coded here so that an
10307   * innocent-looking character class, like /[ks]/i won't have to go out
10308   * to disk to find the possible matches.  XXX It would be better to
10309   * generate these via regen, in case a new version of the Unicode
10310   * standard adds new mappings, though that is not really likely. */
10311   switch (value) {
10312    case 'k':
10313    case 'K':
10314     /* KELVIN SIGN */
10315     *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x212A);
10316     break;
10317    case 's':
10318    case 'S':
10319     /* LATIN SMALL LETTER LONG S */
10320     *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x017F);
10321     break;
10322    case MICRO_SIGN:
10323     *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
10324             GREEK_SMALL_LETTER_MU);
10325     *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
10326             GREEK_CAPITAL_LETTER_MU);
10327     break;
10328    case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
10329    case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
10330     /* ANGSTROM SIGN */
10331     *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x212B);
10332     if (DEPENDS_SEMANTICS) {    /* See DEPENDS comment below */
10333      *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
10334              PL_fold_latin1[value]);
10335     }
10336     break;
10337    case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
10338     *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
10339           LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
10340     break;
10341    case LATIN_SMALL_LETTER_SHARP_S:
10342     *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
10343           LATIN_CAPITAL_LETTER_SHARP_S);
10344
10345     /* Under /a, /d, and /u, this can match the two chars "ss" */
10346     if (! MORE_ASCII_RESTRICTED) {
10347      add_alternate(alternate_ptr, (U8 *) "ss", 2);
10348
10349      /* And under /u or /a, it can match even if the target is
10350      * not utf8 */
10351      if (AT_LEAST_UNI_SEMANTICS) {
10352       ANYOF_FLAGS(node) |= ANYOF_NONBITMAP_NON_UTF8;
10353      }
10354     }
10355     break;
10356    case 'F': case 'f':
10357    case 'I': case 'i':
10358    case 'L': case 'l':
10359    case 'T': case 't':
10360    case 'A': case 'a':
10361    case 'H': case 'h':
10362    case 'J': case 'j':
10363    case 'N': case 'n':
10364    case 'W': case 'w':
10365    case 'Y': case 'y':
10366     /* These all are targets of multi-character folds from code
10367     * points that require UTF8 to express, so they can't match
10368     * unless the target string is in UTF-8, so no action here is
10369     * necessary, as regexec.c properly handles the general case
10370     * for UTF-8 matching */
10371     break;
10372    default:
10373     /* Use deprecated warning to increase the chances of this
10374     * being output */
10375     ckWARN2regdep(RExC_parse, "Perl folding rules are not up-to-date for 0x%x; please use the perlbug utility to report;", value);
10376     break;
10377   }
10378  }
10379  else if (DEPENDS_SEMANTICS
10380    && ! isASCII(value)
10381    && PL_fold_latin1[value] != value)
10382  {
10383   /* Under DEPENDS rules, non-ASCII Latin1 characters match their
10384    * folds only when the target string is in UTF-8.  We add the fold
10385    * here to the list of things to match outside the bitmap, which
10386    * won't be looked at unless it is UTF8 (or else if something else
10387    * says to look even if not utf8, but those things better not happen
10388    * under DEPENDS semantics. */
10389   *invlist_ptr = add_cp_to_invlist(*invlist_ptr, PL_fold_latin1[value]);
10390  }
10391
10392  return stored;
10393 }
10394
10395
10396 PERL_STATIC_INLINE U8
10397 S_set_regclass_bit(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, SV** invlist_ptr, AV** alternate_ptr)
10398 {
10399  /* This inline function sets a bit in the bitmap if not already set, and if
10400  * appropriate, its fold, returning the number of bits that actually
10401  * changed from 0 to 1 */
10402
10403  U8 stored;
10404
10405  PERL_ARGS_ASSERT_SET_REGCLASS_BIT;
10406
10407  if (ANYOF_BITMAP_TEST(node, value)) {   /* Already set */
10408   return 0;
10409  }
10410
10411  ANYOF_BITMAP_SET(node, value);
10412  stored = 1;
10413
10414  if (FOLD && ! LOC) { /* Locale folds aren't known until runtime */
10415   stored += set_regclass_bit_fold(pRExC_state, node, value, invlist_ptr, alternate_ptr);
10416  }
10417
10418  return stored;
10419 }
10420
10421 STATIC void
10422 S_add_alternate(pTHX_ AV** alternate_ptr, U8* string, STRLEN len)
10423 {
10424  /* Adds input 'string' with length 'len' to the ANYOF node's unicode
10425  * alternate list, pointed to by 'alternate_ptr'.  This is an array of
10426  * the multi-character folds of characters in the node */
10427  SV *sv;
10428
10429  PERL_ARGS_ASSERT_ADD_ALTERNATE;
10430
10431  if (! *alternate_ptr) {
10432   *alternate_ptr = newAV();
10433  }
10434  sv = newSVpvn_utf8((char*)string, len, TRUE);
10435  av_push(*alternate_ptr, sv);
10436  return;
10437 }
10438
10439 /*
10440    parse a class specification and produce either an ANYOF node that
10441    matches the pattern or perhaps will be optimized into an EXACTish node
10442    instead. The node contains a bit map for the first 256 characters, with the
10443    corresponding bit set if that character is in the list.  For characters
10444    above 255, a range list is used */
10445
10446 STATIC regnode *
10447 S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth)
10448 {
10449  dVAR;
10450  register UV nextvalue;
10451  register IV prevvalue = OOB_UNICODE;
10452  register IV range = 0;
10453  UV value = 0; /* XXX:dmq: needs to be referenceable (unfortunately) */
10454  register regnode *ret;
10455  STRLEN numlen;
10456  IV namedclass;
10457  char *rangebegin = NULL;
10458  bool need_class = 0;
10459  bool allow_full_fold = TRUE;   /* Assume wants multi-char folding */
10460  SV *listsv = NULL;
10461  STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
10462          than just initialized.  */
10463  SV* properties = NULL;    /* Code points that match \p{} \P{} */
10464  UV element_count = 0;   /* Number of distinct elements in the class.
10465        Optimizations may be possible if this is tiny */
10466  UV n;
10467
10468  /* Unicode properties are stored in a swash; this holds the current one
10469  * being parsed.  If this swash is the only above-latin1 component of the
10470  * character class, an optimization is to pass it directly on to the
10471  * execution engine.  Otherwise, it is set to NULL to indicate that there
10472  * are other things in the class that have to be dealt with at execution
10473  * time */
10474  SV* swash = NULL;  /* Code points that match \p{} \P{} */
10475
10476  /* Set if a component of this character class is user-defined; just passed
10477  * on to the engine */
10478  UV has_user_defined_property = 0;
10479
10480  /* code points this node matches that can't be stored in the bitmap */
10481  SV* nonbitmap = NULL;
10482
10483  /* The items that are to match that aren't stored in the bitmap, but are a
10484  * result of things that are stored there.  This is the fold closure of
10485  * such a character, either because it has DEPENDS semantics and shouldn't
10486  * be matched unless the target string is utf8, or is a code point that is
10487  * too large for the bit map, as for example, the fold of the MICRO SIGN is
10488  * above 255.  This all is solely for performance reasons.  By having this
10489  * code know the outside-the-bitmap folds that the bitmapped characters are
10490  * involved with, we don't have to go out to disk to find the list of
10491  * matches, unless the character class includes code points that aren't
10492  * storable in the bit map.  That means that a character class with an 's'
10493  * in it, for example, doesn't need to go out to disk to find everything
10494  * that matches.  A 2nd list is used so that the 'nonbitmap' list is kept
10495  * empty unless there is something whose fold we don't know about, and will
10496  * have to go out to the disk to find. */
10497  SV* l1_fold_invlist = NULL;
10498
10499  /* List of multi-character folds that are matched by this node */
10500  AV* unicode_alternate  = NULL;
10501 #ifdef EBCDIC
10502  UV literal_endpoint = 0;
10503 #endif
10504  UV stored = 0;  /* how many chars stored in the bitmap */
10505
10506  regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
10507   case we need to change the emitted regop to an EXACT. */
10508  const char * orig_parse = RExC_parse;
10509  GET_RE_DEBUG_FLAGS_DECL;
10510
10511  PERL_ARGS_ASSERT_REGCLASS;
10512 #ifndef DEBUGGING
10513  PERL_UNUSED_ARG(depth);
10514 #endif
10515
10516  DEBUG_PARSE("clas");
10517
10518  /* Assume we are going to generate an ANYOF node. */
10519  ret = reganode(pRExC_state, ANYOF, 0);
10520
10521
10522  if (!SIZE_ONLY) {
10523   ANYOF_FLAGS(ret) = 0;
10524  }
10525
10526  if (UCHARAT(RExC_parse) == '^') { /* Complement of range. */
10527   RExC_naughty++;
10528   RExC_parse++;
10529   if (!SIZE_ONLY)
10530    ANYOF_FLAGS(ret) |= ANYOF_INVERT;
10531
10532   /* We have decided to not allow multi-char folds in inverted character
10533   * classes, due to the confusion that can happen, especially with
10534   * classes that are designed for a non-Unicode world:  You have the
10535   * peculiar case that:
10536    "s s" =~ /^[^\xDF]+$/i => Y
10537    "ss"  =~ /^[^\xDF]+$/i => N
10538   *
10539   * See [perl #89750] */
10540   allow_full_fold = FALSE;
10541  }
10542
10543  if (SIZE_ONLY) {
10544   RExC_size += ANYOF_SKIP;
10545   listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
10546  }
10547  else {
10548   RExC_emit += ANYOF_SKIP;
10549   if (LOC) {
10550    ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
10551   }
10552   ANYOF_BITMAP_ZERO(ret);
10553   listsv = newSVpvs("# comment\n");
10554   initial_listsv_len = SvCUR(listsv);
10555  }
10556
10557  nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
10558
10559  if (!SIZE_ONLY && POSIXCC(nextvalue))
10560   checkposixcc(pRExC_state);
10561
10562  /* allow 1st char to be ] (allowing it to be - is dealt with later) */
10563  if (UCHARAT(RExC_parse) == ']')
10564   goto charclassloop;
10565
10566 parseit:
10567  while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
10568
10569  charclassloop:
10570
10571   namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
10572
10573   if (!range) {
10574    rangebegin = RExC_parse;
10575    element_count++;
10576   }
10577   if (UTF) {
10578    value = utf8n_to_uvchr((U8*)RExC_parse,
10579         RExC_end - RExC_parse,
10580         &numlen, UTF8_ALLOW_DEFAULT);
10581    RExC_parse += numlen;
10582   }
10583   else
10584    value = UCHARAT(RExC_parse++);
10585
10586   nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
10587   if (value == '[' && POSIXCC(nextvalue))
10588    namedclass = regpposixcc(pRExC_state, value);
10589   else if (value == '\\') {
10590    if (UTF) {
10591     value = utf8n_to_uvchr((U8*)RExC_parse,
10592         RExC_end - RExC_parse,
10593         &numlen, UTF8_ALLOW_DEFAULT);
10594     RExC_parse += numlen;
10595    }
10596    else
10597     value = UCHARAT(RExC_parse++);
10598    /* Some compilers cannot handle switching on 64-bit integer
10599    * values, therefore value cannot be an UV.  Yes, this will
10600    * be a problem later if we want switch on Unicode.
10601    * A similar issue a little bit later when switching on
10602    * namedclass. --jhi */
10603    switch ((I32)value) {
10604    case 'w': namedclass = ANYOF_ALNUM; break;
10605    case 'W': namedclass = ANYOF_NALNUM; break;
10606    case 's': namedclass = ANYOF_SPACE; break;
10607    case 'S': namedclass = ANYOF_NSPACE; break;
10608    case 'd': namedclass = ANYOF_DIGIT; break;
10609    case 'D': namedclass = ANYOF_NDIGIT; break;
10610    case 'v': namedclass = ANYOF_VERTWS; break;
10611    case 'V': namedclass = ANYOF_NVERTWS; break;
10612    case 'h': namedclass = ANYOF_HORIZWS; break;
10613    case 'H': namedclass = ANYOF_NHORIZWS; break;
10614    case 'N':  /* Handle \N{NAME} in class */
10615     {
10616      /* We only pay attention to the first char of
10617      multichar strings being returned. I kinda wonder
10618      if this makes sense as it does change the behaviour
10619      from earlier versions, OTOH that behaviour was broken
10620      as well. */
10621      UV v; /* value is register so we cant & it /grrr */
10622      if (reg_namedseq(pRExC_state, &v, NULL, depth)) {
10623       goto parseit;
10624      }
10625      value= v;
10626     }
10627     break;
10628    case 'p':
10629    case 'P':
10630     {
10631     char *e;
10632     if (RExC_parse >= RExC_end)
10633      vFAIL2("Empty \\%c{}", (U8)value);
10634     if (*RExC_parse == '{') {
10635      const U8 c = (U8)value;
10636      e = strchr(RExC_parse++, '}');
10637      if (!e)
10638       vFAIL2("Missing right brace on \\%c{}", c);
10639      while (isSPACE(UCHARAT(RExC_parse)))
10640       RExC_parse++;
10641      if (e == RExC_parse)
10642       vFAIL2("Empty \\%c{}", c);
10643      n = e - RExC_parse;
10644      while (isSPACE(UCHARAT(RExC_parse + n - 1)))
10645       n--;
10646     }
10647     else {
10648      e = RExC_parse;
10649      n = 1;
10650     }
10651     if (!SIZE_ONLY) {
10652      SV** invlistsvp;
10653      SV* invlist;
10654      char* name;
10655      if (UCHARAT(RExC_parse) == '^') {
10656       RExC_parse++;
10657       n--;
10658       value = value == 'p' ? 'P' : 'p'; /* toggle */
10659       while (isSPACE(UCHARAT(RExC_parse))) {
10660        RExC_parse++;
10661        n--;
10662       }
10663      }
10664      /* Try to get the definition of the property into
10665      * <invlist>.  If /i is in effect, the effective property
10666      * will have its name be <__NAME_i>.  The design is
10667      * discussed in commit
10668      * 2f833f5208e26b208886e51e09e2c072b5eabb46 */
10669      Newx(name, n + sizeof("_i__\n"), char);
10670
10671      sprintf(name, "%s%.*s%s\n",
10672          (FOLD) ? "__" : "",
10673          (int)n,
10674          RExC_parse,
10675          (FOLD) ? "_i" : ""
10676      );
10677
10678      /* Look up the property name, and get its swash and
10679      * inversion list, if the property is found  */
10680      if (swash) {
10681       SvREFCNT_dec(swash);
10682      }
10683      swash = _core_swash_init("utf8", name, &PL_sv_undef,
10684            1, /* binary */
10685            0, /* not tr/// */
10686            TRUE, /* this routine will handle
10687              undefined properties */
10688            NULL, FALSE /* No inversion list */
10689            );
10690      if (   ! swash
10691       || ! SvROK(swash)
10692       || ! SvTYPE(SvRV(swash)) == SVt_PVHV
10693       || ! (invlistsvp =
10694         hv_fetchs(MUTABLE_HV(SvRV(swash)),
10695         "INVLIST", FALSE))
10696       || ! (invlist = *invlistsvp))
10697      {
10698       if (swash) {
10699        SvREFCNT_dec(swash);
10700        swash = NULL;
10701       }
10702
10703       /* Here didn't find it.  It could be a user-defined
10704       * property that will be available at run-time.  Add it
10705       * to the list to look up then */
10706       Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s\n",
10707           (value == 'p' ? '+' : '!'),
10708           name);
10709       has_user_defined_property = 1;
10710
10711       /* We don't know yet, so have to assume that the
10712       * property could match something in the Latin1 range,
10713       * hence something that isn't utf8 */
10714       ANYOF_FLAGS(ret) |= ANYOF_NONBITMAP_NON_UTF8;
10715      }
10716      else {
10717
10718       /* Here, did get the swash and its inversion list.  If
10719       * the swash is from a user-defined property, then this
10720       * whole character class should be regarded as such */
10721       SV** user_defined_svp =
10722            hv_fetchs(MUTABLE_HV(SvRV(swash)),
10723               "USER_DEFINED", FALSE);
10724       if (user_defined_svp) {
10725        has_user_defined_property
10726              |= SvUV(*user_defined_svp);
10727       }
10728
10729       /* Invert if asking for the complement */
10730       if (value == 'P') {
10731        _invlist_union_complement_2nd(properties, invlist, &properties);
10732
10733        /* The swash can't be used as-is, because we've
10734        * inverted things; delay removing it to here after
10735        * have copied its invlist above */
10736        SvREFCNT_dec(swash);
10737        swash = NULL;
10738       }
10739       else {
10740        _invlist_union(properties, invlist, &properties);
10741       }
10742      }
10743      Safefree(name);
10744     }
10745     RExC_parse = e + 1;
10746     namedclass = ANYOF_MAX;  /* no official name, but it's named */
10747
10748     /* \p means they want Unicode semantics */
10749     RExC_uni_semantics = 1;
10750     }
10751     break;
10752    case 'n': value = '\n';   break;
10753    case 'r': value = '\r';   break;
10754    case 't': value = '\t';   break;
10755    case 'f': value = '\f';   break;
10756    case 'b': value = '\b';   break;
10757    case 'e': value = ASCII_TO_NATIVE('\033');break;
10758    case 'a': value = ASCII_TO_NATIVE('\007');break;
10759    case 'o':
10760     RExC_parse--; /* function expects to be pointed at the 'o' */
10761     {
10762      const char* error_msg;
10763      bool valid = grok_bslash_o(RExC_parse,
10764            &value,
10765            &numlen,
10766            &error_msg,
10767            SIZE_ONLY);
10768      RExC_parse += numlen;
10769      if (! valid) {
10770       vFAIL(error_msg);
10771      }
10772     }
10773     if (PL_encoding && value < 0x100) {
10774      goto recode_encoding;
10775     }
10776     break;
10777    case 'x':
10778     if (*RExC_parse == '{') {
10779      I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
10780       | PERL_SCAN_DISALLOW_PREFIX;
10781      char * const e = strchr(RExC_parse++, '}');
10782      if (!e)
10783       vFAIL("Missing right brace on \\x{}");
10784
10785      numlen = e - RExC_parse;
10786      value = grok_hex(RExC_parse, &numlen, &flags, NULL);
10787      RExC_parse = e + 1;
10788     }
10789     else {
10790      I32 flags = PERL_SCAN_DISALLOW_PREFIX;
10791      numlen = 2;
10792      value = grok_hex(RExC_parse, &numlen, &flags, NULL);
10793      RExC_parse += numlen;
10794     }
10795     if (PL_encoding && value < 0x100)
10796      goto recode_encoding;
10797     break;
10798    case 'c':
10799     value = grok_bslash_c(*RExC_parse++, UTF, SIZE_ONLY);
10800     break;
10801    case '0': case '1': case '2': case '3': case '4':
10802    case '5': case '6': case '7':
10803     {
10804      /* Take 1-3 octal digits */
10805      I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
10806      numlen = 3;
10807      value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
10808      RExC_parse += numlen;
10809      if (PL_encoding && value < 0x100)
10810       goto recode_encoding;
10811      break;
10812     }
10813    recode_encoding:
10814     if (! RExC_override_recoding) {
10815      SV* enc = PL_encoding;
10816      value = reg_recode((const char)(U8)value, &enc);
10817      if (!enc && SIZE_ONLY)
10818       ckWARNreg(RExC_parse,
10819         "Invalid escape in the specified encoding");
10820      break;
10821     }
10822    default:
10823     /* Allow \_ to not give an error */
10824     if (!SIZE_ONLY && isALNUM(value) && value != '_') {
10825      ckWARN2reg(RExC_parse,
10826        "Unrecognized escape \\%c in character class passed through",
10827        (int)value);
10828     }
10829     break;
10830    }
10831   } /* end of \blah */
10832 #ifdef EBCDIC
10833   else
10834    literal_endpoint++;
10835 #endif
10836
10837   if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
10838
10839    /* What matches in a locale is not known until runtime, so need to
10840    * (one time per class) allocate extra space to pass to regexec.
10841    * The space will contain a bit for each named class that is to be
10842    * matched against.  This isn't needed for \p{} and pseudo-classes,
10843    * as they are not affected by locale, and hence are dealt with
10844    * separately */
10845    if (LOC && namedclass < ANYOF_MAX && ! need_class) {
10846     need_class = 1;
10847     if (SIZE_ONLY) {
10848      RExC_size += ANYOF_CLASS_SKIP - ANYOF_SKIP;
10849     }
10850     else {
10851      RExC_emit += ANYOF_CLASS_SKIP - ANYOF_SKIP;
10852      ANYOF_CLASS_ZERO(ret);
10853     }
10854     ANYOF_FLAGS(ret) |= ANYOF_CLASS;
10855    }
10856
10857    /* a bad range like a-\d, a-[:digit:].  The '-' is taken as a
10858    * literal, as is the character that began the false range, i.e.
10859    * the 'a' in the examples */
10860    if (range) {
10861     if (!SIZE_ONLY) {
10862      const int w =
10863       RExC_parse >= rangebegin ?
10864       RExC_parse - rangebegin : 0;
10865      ckWARN4reg(RExC_parse,
10866        "False [] range \"%*.*s\"",
10867        w, w, rangebegin);
10868
10869      stored +=
10870       set_regclass_bit(pRExC_state, ret, '-', &l1_fold_invlist, &unicode_alternate);
10871      if (prevvalue < 256) {
10872       stored +=
10873       set_regclass_bit(pRExC_state, ret, (U8) prevvalue, &l1_fold_invlist, &unicode_alternate);
10874      }
10875      else {
10876       nonbitmap = add_cp_to_invlist(nonbitmap, prevvalue);
10877      }
10878     }
10879
10880     range = 0; /* this was not a true range */
10881    }
10882
10883    if (!SIZE_ONLY) {
10884
10885     /* Possible truncation here but in some 64-bit environments
10886     * the compiler gets heartburn about switch on 64-bit values.
10887     * A similar issue a little earlier when switching on value.
10888     * --jhi */
10889     switch ((I32)namedclass) {
10890      int i;  /* loop counter */
10891
10892     case ANYOF_ALNUMC: /* C's alnum, in contrast to \w */
10893      DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10894       PL_PosixAlnum, PL_L1PosixAlnum, "XPosixAlnum", listsv);
10895      break;
10896     case ANYOF_NALNUMC:
10897      DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10898       PL_PosixAlnum, PL_L1PosixAlnum, "XPosixAlnum", listsv);
10899      break;
10900     case ANYOF_ALPHA:
10901      DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10902       PL_PosixAlpha, PL_L1PosixAlpha, "XPosixAlpha", listsv);
10903      break;
10904     case ANYOF_NALPHA:
10905      DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10906       PL_PosixAlpha, PL_L1PosixAlpha, "XPosixAlpha", listsv);
10907      break;
10908     case ANYOF_ASCII:
10909      if (LOC) {
10910       ANYOF_CLASS_SET(ret, namedclass);
10911      }
10912      else {
10913       _invlist_union(properties, PL_ASCII, &properties);
10914      }
10915      break;
10916     case ANYOF_NASCII:
10917      if (LOC) {
10918       ANYOF_CLASS_SET(ret, namedclass);
10919      }
10920      else {
10921       _invlist_union_complement_2nd(properties,
10922              PL_ASCII, &properties);
10923       if (DEPENDS_SEMANTICS) {
10924        ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_LATIN1_ALL;
10925       }
10926      }
10927      break;
10928     case ANYOF_BLANK:
10929      DO_POSIX(ret, namedclass, properties,
10930            PL_PosixBlank, PL_XPosixBlank);
10931      break;
10932     case ANYOF_NBLANK:
10933      DO_N_POSIX(ret, namedclass, properties,
10934            PL_PosixBlank, PL_XPosixBlank);
10935      break;
10936     case ANYOF_CNTRL:
10937      DO_POSIX(ret, namedclass, properties,
10938            PL_PosixCntrl, PL_XPosixCntrl);
10939      break;
10940     case ANYOF_NCNTRL:
10941      DO_N_POSIX(ret, namedclass, properties,
10942            PL_PosixCntrl, PL_XPosixCntrl);
10943      break;
10944     case ANYOF_DIGIT:
10945      /* Ignore the compiler warning for this macro, planned to
10946      * be eliminated later */
10947      DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10948       PL_PosixDigit, PL_PosixDigit, "XPosixDigit", listsv);
10949      break;
10950     case ANYOF_NDIGIT:
10951      DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10952       PL_PosixDigit, PL_PosixDigit, "XPosixDigit", listsv);
10953      break;
10954     case ANYOF_GRAPH:
10955      DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10956       PL_PosixGraph, PL_L1PosixGraph, "XPosixGraph", listsv);
10957      break;
10958     case ANYOF_NGRAPH:
10959      DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10960       PL_PosixGraph, PL_L1PosixGraph, "XPosixGraph", listsv);
10961      break;
10962     case ANYOF_HORIZWS:
10963      /* NBSP matches this, and needs to be added unconditionally
10964      * to the bit map as it matches even under /d, unlike all
10965      * the rest of the Posix-like classes (\v doesn't have any
10966      * matches in the Latin1 range, so it is unaffected.) which
10967      * Otherwise, we use the nonbitmap, as /d doesn't make a
10968      * difference in what these match.  It turns out that \h is
10969      * just a synonym for XPosixBlank */
10970      _invlist_union(nonbitmap, PL_XPosixBlank, &nonbitmap);
10971      stored += set_regclass_bit(pRExC_state, ret,
10972            UNI_TO_NATIVE(0xA0),
10973            &l1_fold_invlist,
10974            &unicode_alternate);
10975
10976      break;
10977     case ANYOF_NHORIZWS:
10978      _invlist_union_complement_2nd(nonbitmap,
10979             PL_XPosixBlank, &nonbitmap);
10980      for (i = 128; i < 256; i++) {
10981       if (i == 0xA0) {
10982        continue;
10983       }
10984       stored += set_regclass_bit(pRExC_state, ret,
10985             UNI_TO_NATIVE(i),
10986             &l1_fold_invlist,
10987             &unicode_alternate);
10988      }
10989      break;
10990     case ANYOF_LOWER:
10991     case ANYOF_NLOWER:
10992     {   /* These require special handling, as they differ under
10993      folding, matching Cased there (which in the ASCII range
10994      is the same as Alpha */
10995
10996      SV* ascii_source;
10997      SV* l1_source;
10998      const char *Xname;
10999
11000      if (FOLD && ! LOC) {
11001       ascii_source = PL_PosixAlpha;
11002       l1_source = PL_L1Cased;
11003       Xname = "Cased";
11004      }
11005      else {
11006       ascii_source = PL_PosixLower;
11007       l1_source = PL_L1PosixLower;
11008       Xname = "XPosixLower";
11009      }
11010      if (namedclass == ANYOF_LOWER) {
11011       DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11012          ascii_source, l1_source, Xname, listsv);
11013      }
11014      else {
11015       DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass,
11016        properties, ascii_source, l1_source, Xname, listsv);
11017      }
11018      break;
11019     }
11020     case ANYOF_PRINT:
11021      DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11022       PL_PosixPrint, PL_L1PosixPrint, "XPosixPrint", listsv);
11023      break;
11024     case ANYOF_NPRINT:
11025      DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11026       PL_PosixPrint, PL_L1PosixPrint, "XPosixPrint", listsv);
11027      break;
11028     case ANYOF_PUNCT:
11029      DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11030       PL_PosixPunct, PL_L1PosixPunct, "XPosixPunct", listsv);
11031      break;
11032     case ANYOF_NPUNCT:
11033      DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11034       PL_PosixPunct, PL_L1PosixPunct, "XPosixPunct", listsv);
11035      break;
11036     case ANYOF_PSXSPC:
11037      DO_POSIX(ret, namedclass, properties,
11038            PL_PosixSpace, PL_XPosixSpace);
11039      break;
11040     case ANYOF_NPSXSPC:
11041      DO_N_POSIX(ret, namedclass, properties,
11042            PL_PosixSpace, PL_XPosixSpace);
11043      break;
11044     case ANYOF_SPACE:
11045      DO_POSIX(ret, namedclass, properties,
11046            PL_PerlSpace, PL_XPerlSpace);
11047      break;
11048     case ANYOF_NSPACE:
11049      DO_N_POSIX(ret, namedclass, properties,
11050            PL_PerlSpace, PL_XPerlSpace);
11051      break;
11052     case ANYOF_UPPER:   /* Same as LOWER, above */
11053     case ANYOF_NUPPER:
11054     {
11055      SV* ascii_source;
11056      SV* l1_source;
11057      const char *Xname;
11058
11059      if (FOLD && ! LOC) {
11060       ascii_source = PL_PosixAlpha;
11061       l1_source = PL_L1Cased;
11062       Xname = "Cased";
11063      }
11064      else {
11065       ascii_source = PL_PosixUpper;
11066       l1_source = PL_L1PosixUpper;
11067       Xname = "XPosixUpper";
11068      }
11069      if (namedclass == ANYOF_UPPER) {
11070       DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11071          ascii_source, l1_source, Xname, listsv);
11072      }
11073      else {
11074       DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass,
11075       properties, ascii_source, l1_source, Xname, listsv);
11076      }
11077      break;
11078     }
11079     case ANYOF_ALNUM:   /* Really is 'Word' */
11080      DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11081        PL_PosixWord, PL_L1PosixWord, "XPosixWord", listsv);
11082      break;
11083     case ANYOF_NALNUM:
11084      DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11085        PL_PosixWord, PL_L1PosixWord, "XPosixWord", listsv);
11086      break;
11087     case ANYOF_VERTWS:
11088      /* For these, we use the nonbitmap, as /d doesn't make a
11089      * difference in what these match.  There would be problems
11090      * if these characters had folds other than themselves, as
11091      * nonbitmap is subject to folding */
11092      _invlist_union(nonbitmap, PL_VertSpace, &nonbitmap);
11093      break;
11094     case ANYOF_NVERTWS:
11095      _invlist_union_complement_2nd(nonbitmap,
11096              PL_VertSpace, &nonbitmap);
11097      break;
11098     case ANYOF_XDIGIT:
11099      DO_POSIX(ret, namedclass, properties,
11100            PL_PosixXDigit, PL_XPosixXDigit);
11101      break;
11102     case ANYOF_NXDIGIT:
11103      DO_N_POSIX(ret, namedclass, properties,
11104            PL_PosixXDigit, PL_XPosixXDigit);
11105      break;
11106     case ANYOF_MAX:
11107      /* this is to handle \p and \P */
11108      break;
11109     default:
11110      vFAIL("Invalid [::] class");
11111      break;
11112     }
11113
11114     continue;
11115    }
11116   } /* end of namedclass \blah */
11117
11118   if (range) {
11119    if (prevvalue > (IV)value) /* b-a */ {
11120     const int w = RExC_parse - rangebegin;
11121     Simple_vFAIL4("Invalid [] range \"%*.*s\"", w, w, rangebegin);
11122     range = 0; /* not a valid range */
11123    }
11124   }
11125   else {
11126    prevvalue = value; /* save the beginning of the range */
11127    if (RExC_parse+1 < RExC_end
11128     && *RExC_parse == '-'
11129     && RExC_parse[1] != ']')
11130    {
11131     RExC_parse++;
11132
11133     /* a bad range like \w-, [:word:]- ? */
11134     if (namedclass > OOB_NAMEDCLASS) {
11135      if (ckWARN(WARN_REGEXP)) {
11136       const int w =
11137        RExC_parse >= rangebegin ?
11138        RExC_parse - rangebegin : 0;
11139       vWARN4(RExC_parse,
11140        "False [] range \"%*.*s\"",
11141        w, w, rangebegin);
11142      }
11143      if (!SIZE_ONLY)
11144       stored +=
11145        set_regclass_bit(pRExC_state, ret, '-', &l1_fold_invlist, &unicode_alternate);
11146     } else
11147      range = 1; /* yeah, it's a range! */
11148     continue; /* but do it the next time */
11149    }
11150   }
11151
11152   /* non-Latin1 code point implies unicode semantics.  Must be set in
11153   * pass1 so is there for the whole of pass 2 */
11154   if (value > 255) {
11155    RExC_uni_semantics = 1;
11156   }
11157
11158   /* now is the next time */
11159   if (!SIZE_ONLY) {
11160    if (prevvalue < 256) {
11161     const IV ceilvalue = value < 256 ? value : 255;
11162     IV i;
11163 #ifdef EBCDIC
11164     /* In EBCDIC [\x89-\x91] should include
11165     * the \x8e but [i-j] should not. */
11166     if (literal_endpoint == 2 &&
11167      ((isLOWER(prevvalue) && isLOWER(ceilvalue)) ||
11168      (isUPPER(prevvalue) && isUPPER(ceilvalue))))
11169     {
11170      if (isLOWER(prevvalue)) {
11171       for (i = prevvalue; i <= ceilvalue; i++)
11172        if (isLOWER(i) && !ANYOF_BITMAP_TEST(ret,i)) {
11173         stored +=
11174         set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
11175        }
11176      } else {
11177       for (i = prevvalue; i <= ceilvalue; i++)
11178        if (isUPPER(i) && !ANYOF_BITMAP_TEST(ret,i)) {
11179         stored +=
11180         set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
11181        }
11182      }
11183     }
11184     else
11185 #endif
11186      for (i = prevvalue; i <= ceilvalue; i++) {
11187       stored += set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
11188      }
11189   }
11190   if (value > 255) {
11191    const UV prevnatvalue  = NATIVE_TO_UNI(prevvalue);
11192    const UV natvalue      = NATIVE_TO_UNI(value);
11193    nonbitmap = _add_range_to_invlist(nonbitmap, prevnatvalue, natvalue);
11194   }
11195 #ifdef EBCDIC
11196    literal_endpoint = 0;
11197 #endif
11198   }
11199
11200   range = 0; /* this range (if it was one) is done now */
11201  }
11202
11203
11204
11205  if (SIZE_ONLY)
11206   return ret;
11207  /****** !SIZE_ONLY AFTER HERE *********/
11208
11209  /* If folding and there are code points above 255, we calculate all
11210  * characters that could fold to or from the ones already on the list */
11211  if (FOLD && nonbitmap) {
11212   UV start, end; /* End points of code point ranges */
11213
11214   SV* fold_intersection = NULL;
11215
11216   /* This is a list of all the characters that participate in folds
11217    * (except marks, etc in multi-char folds */
11218   if (! PL_utf8_foldable) {
11219    SV* swash = swash_init("utf8", "Cased", &PL_sv_undef, 1, 0);
11220    PL_utf8_foldable = _swash_to_invlist(swash);
11221    SvREFCNT_dec(swash);
11222   }
11223
11224   /* This is a hash that for a particular fold gives all characters
11225    * that are involved in it */
11226   if (! PL_utf8_foldclosures) {
11227
11228    /* If we were unable to find any folds, then we likely won't be
11229    * able to find the closures.  So just create an empty list.
11230    * Folding will effectively be restricted to the non-Unicode rules
11231    * hard-coded into Perl.  (This case happens legitimately during
11232    * compilation of Perl itself before the Unicode tables are
11233    * generated) */
11234    if (invlist_len(PL_utf8_foldable) == 0) {
11235     PL_utf8_foldclosures = newHV();
11236    } else {
11237     /* If the folds haven't been read in, call a fold function
11238      * to force that */
11239     if (! PL_utf8_tofold) {
11240      U8 dummy[UTF8_MAXBYTES+1];
11241      STRLEN dummy_len;
11242
11243      /* This particular string is above \xff in both UTF-8 and
11244      * UTFEBCDIC */
11245      to_utf8_fold((U8*) "\xC8\x80", dummy, &dummy_len);
11246      assert(PL_utf8_tofold); /* Verify that worked */
11247     }
11248     PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
11249    }
11250   }
11251
11252   /* Only the characters in this class that participate in folds need be
11253   * checked.  Get the intersection of this class and all the possible
11254   * characters that are foldable.  This can quickly narrow down a large
11255   * class */
11256   _invlist_intersection(PL_utf8_foldable, nonbitmap, &fold_intersection);
11257
11258   /* Now look at the foldable characters in this class individually */
11259   invlist_iterinit(fold_intersection);
11260   while (invlist_iternext(fold_intersection, &start, &end)) {
11261    UV j;
11262
11263    /* Look at every character in the range */
11264    for (j = start; j <= end; j++) {
11265
11266     /* Get its fold */
11267     U8 foldbuf[UTF8_MAXBYTES_CASE+1];
11268     STRLEN foldlen;
11269     const UV f =
11270      _to_uni_fold_flags(j, foldbuf, &foldlen, allow_full_fold);
11271
11272     if (foldlen > (STRLEN)UNISKIP(f)) {
11273
11274      /* Any multicharacter foldings (disallowed in lookbehind
11275      * patterns) require the following transform: [ABCDEF] ->
11276      * (?:[ABCabcDEFd]|pq|rst) where E folds into "pq" and F
11277      * folds into "rst", all other characters fold to single
11278      * characters.  We save away these multicharacter foldings,
11279      * to be later saved as part of the additional "s" data. */
11280      if (! RExC_in_lookbehind) {
11281       U8* loc = foldbuf;
11282       U8* e = foldbuf + foldlen;
11283
11284       /* If any of the folded characters of this are in the
11285       * Latin1 range, tell the regex engine that this can
11286       * match a non-utf8 target string.  The only multi-byte
11287       * fold whose source is in the Latin1 range (U+00DF)
11288       * applies only when the target string is utf8, or
11289       * under unicode rules */
11290       if (j > 255 || AT_LEAST_UNI_SEMANTICS) {
11291        while (loc < e) {
11292
11293         /* Can't mix ascii with non- under /aa */
11294         if (MORE_ASCII_RESTRICTED
11295          && (isASCII(*loc) != isASCII(j)))
11296         {
11297          goto end_multi_fold;
11298         }
11299         if (UTF8_IS_INVARIANT(*loc)
11300          || UTF8_IS_DOWNGRADEABLE_START(*loc))
11301         {
11302          /* Can't mix above and below 256 under LOC
11303          */
11304          if (LOC) {
11305           goto end_multi_fold;
11306          }
11307          ANYOF_FLAGS(ret)
11308            |= ANYOF_NONBITMAP_NON_UTF8;
11309          break;
11310         }
11311         loc += UTF8SKIP(loc);
11312        }
11313       }
11314
11315       add_alternate(&unicode_alternate, foldbuf, foldlen);
11316      end_multi_fold: ;
11317      }
11318
11319      /* This is special-cased, as it is the only letter which
11320      * has both a multi-fold and single-fold in Latin1.  All
11321      * the other chars that have single and multi-folds are
11322      * always in utf8, and the utf8 folding algorithm catches
11323      * them */
11324      if (! LOC && j == LATIN_CAPITAL_LETTER_SHARP_S) {
11325       stored += set_regclass_bit(pRExC_state,
11326           ret,
11327           LATIN_SMALL_LETTER_SHARP_S,
11328           &l1_fold_invlist, &unicode_alternate);
11329      }
11330     }
11331     else {
11332      /* Single character fold.  Add everything in its fold
11333      * closure to the list that this node should match */
11334      SV** listp;
11335
11336      /* The fold closures data structure is a hash with the keys
11337      * being every character that is folded to, like 'k', and
11338      * the values each an array of everything that folds to its
11339      * key.  e.g. [ 'k', 'K', KELVIN_SIGN ] */
11340      if ((listp = hv_fetch(PL_utf8_foldclosures,
11341          (char *) foldbuf, foldlen, FALSE)))
11342      {
11343       AV* list = (AV*) *listp;
11344       IV k;
11345       for (k = 0; k <= av_len(list); k++) {
11346        SV** c_p = av_fetch(list, k, FALSE);
11347        UV c;
11348        if (c_p == NULL) {
11349         Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
11350        }
11351        c = SvUV(*c_p);
11352
11353        /* /aa doesn't allow folds between ASCII and non-;
11354        * /l doesn't allow them between above and below
11355        * 256 */
11356        if ((MORE_ASCII_RESTRICTED
11357         && (isASCII(c) != isASCII(j)))
11358          || (LOC && ((c < 256) != (j < 256))))
11359        {
11360         continue;
11361        }
11362
11363        if (c < 256 && AT_LEAST_UNI_SEMANTICS) {
11364         stored += set_regclass_bit(pRExC_state,
11365           ret,
11366           (U8) c,
11367           &l1_fold_invlist, &unicode_alternate);
11368        }
11369         /* It may be that the code point is already in
11370         * this range or already in the bitmap, in
11371         * which case we need do nothing */
11372        else if ((c < start || c > end)
11373           && (c > 255
11374            || ! ANYOF_BITMAP_TEST(ret, c)))
11375        {
11376         nonbitmap = add_cp_to_invlist(nonbitmap, c);
11377        }
11378       }
11379      }
11380     }
11381    }
11382   }
11383   SvREFCNT_dec(fold_intersection);
11384  }
11385
11386  /* Combine the two lists into one. */
11387  if (l1_fold_invlist) {
11388   if (nonbitmap) {
11389    _invlist_union(nonbitmap, l1_fold_invlist, &nonbitmap);
11390    SvREFCNT_dec(l1_fold_invlist);
11391   }
11392   else {
11393    nonbitmap = l1_fold_invlist;
11394   }
11395  }
11396
11397  /* And combine the result (if any) with any inversion list from properties.
11398  * The lists are kept separate up to now because we don't want to fold the
11399  * properties */
11400  if (properties) {
11401   if (nonbitmap) {
11402    _invlist_union(nonbitmap, properties, &nonbitmap);
11403    SvREFCNT_dec(properties);
11404   }
11405   else {
11406    nonbitmap = properties;
11407   }
11408  }
11409
11410  /* Here, <nonbitmap> contains all the code points we can determine at
11411  * compile time that we haven't put into the bitmap.  Go through it, and
11412  * for things that belong in the bitmap, put them there, and delete from
11413  * <nonbitmap> */
11414  if (nonbitmap) {
11415
11416   /* Above-ASCII code points in /d have to stay in <nonbitmap>, as they
11417   * possibly only should match when the target string is UTF-8 */
11418   UV max_cp_to_set = (DEPENDS_SEMANTICS) ? 127 : 255;
11419
11420   /* This gets set if we actually need to modify things */
11421   bool change_invlist = FALSE;
11422
11423   UV start, end;
11424
11425   /* Start looking through <nonbitmap> */
11426   invlist_iterinit(nonbitmap);
11427   while (invlist_iternext(nonbitmap, &start, &end)) {
11428    UV high;
11429    int i;
11430
11431    /* Quit if are above what we should change */
11432    if (start > max_cp_to_set) {
11433     break;
11434    }
11435
11436    change_invlist = TRUE;
11437
11438    /* Set all the bits in the range, up to the max that we are doing */
11439    high = (end < max_cp_to_set) ? end : max_cp_to_set;
11440    for (i = start; i <= (int) high; i++) {
11441     if (! ANYOF_BITMAP_TEST(ret, i)) {
11442      ANYOF_BITMAP_SET(ret, i);
11443      stored++;
11444      prevvalue = value;
11445      value = i;
11446     }
11447    }
11448   }
11449
11450   /* Done with loop; remove any code points that are in the bitmap from
11451   * <nonbitmap> */
11452   if (change_invlist) {
11453    _invlist_subtract(nonbitmap,
11454        (DEPENDS_SEMANTICS)
11455         ? PL_ASCII
11456         : PL_Latin1,
11457        &nonbitmap);
11458   }
11459
11460   /* If have completely emptied it, remove it completely */
11461   if (invlist_len(nonbitmap) == 0) {
11462    SvREFCNT_dec(nonbitmap);
11463    nonbitmap = NULL;
11464   }
11465  }
11466
11467  /* Here, we have calculated what code points should be in the character
11468  * class.  <nonbitmap> does not overlap the bitmap except possibly in the
11469  * case of DEPENDS rules.
11470  *
11471  * Now we can see about various optimizations.  Fold calculation (which we
11472  * did above) needs to take place before inversion.  Otherwise /[^k]/i
11473  * would invert to include K, which under /i would match k, which it
11474  * shouldn't. */
11475
11476  /* Optimize inverted simple patterns (e.g. [^a-z]).  Note that we haven't
11477  * set the FOLD flag yet, so this does optimize those.  It doesn't
11478  * optimize locale.  Doing so perhaps could be done as long as there is
11479  * nothing like \w in it; some thought also would have to be given to the
11480  * interaction with above 0x100 chars */
11481  if ((ANYOF_FLAGS(ret) & ANYOF_INVERT)
11482   && ! LOC
11483   && ! unicode_alternate
11484   /* In case of /d, there are some things that should match only when in
11485   * not in the bitmap, i.e., they require UTF8 to match.  These are
11486   * listed in nonbitmap, but if ANYOF_NONBITMAP_NON_UTF8 is set in this
11487   * case, they don't require UTF8, so can invert here */
11488   && (! nonbitmap
11489    || ! DEPENDS_SEMANTICS
11490    || (ANYOF_FLAGS(ret) & ANYOF_NONBITMAP_NON_UTF8))
11491   && SvCUR(listsv) == initial_listsv_len)
11492  {
11493   int i;
11494   if (! nonbitmap) {
11495    for (i = 0; i < 256; ++i) {
11496     if (ANYOF_BITMAP_TEST(ret, i)) {
11497      ANYOF_BITMAP_CLEAR(ret, i);
11498     }
11499     else {
11500      ANYOF_BITMAP_SET(ret, i);
11501      prevvalue = value;
11502      value = i;
11503     }
11504    }
11505    /* The inversion means that everything above 255 is matched */
11506    ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
11507   }
11508   else {
11509    /* Here, also has things outside the bitmap that may overlap with
11510    * the bitmap.  We have to sync them up, so that they get inverted
11511    * in both places.  Earlier, we removed all overlaps except in the
11512    * case of /d rules, so no syncing is needed except for this case
11513    */
11514    SV *remove_list = NULL;
11515
11516    if (DEPENDS_SEMANTICS) {
11517     UV start, end;
11518
11519     /* Set the bits that correspond to the ones that aren't in the
11520     * bitmap.  Otherwise, when we invert, we'll miss these.
11521     * Earlier, we removed from the nonbitmap all code points
11522     * < 128, so there is no extra work here */
11523     invlist_iterinit(nonbitmap);
11524     while (invlist_iternext(nonbitmap, &start, &end)) {
11525      if (start > 255) {  /* The bit map goes to 255 */
11526       break;
11527      }
11528      if (end > 255) {
11529       end = 255;
11530      }
11531      for (i = start; i <= (int) end; ++i) {
11532       ANYOF_BITMAP_SET(ret, i);
11533       prevvalue = value;
11534       value = i;
11535      }
11536     }
11537    }
11538
11539    /* Now invert both the bitmap and the nonbitmap.  Anything in the
11540    * bitmap has to also be removed from the non-bitmap, but again,
11541    * there should not be overlap unless is /d rules. */
11542    _invlist_invert(nonbitmap);
11543
11544    /* Any swash can't be used as-is, because we've inverted things */
11545    if (swash) {
11546     SvREFCNT_dec(swash);
11547     swash = NULL;
11548    }
11549
11550    for (i = 0; i < 256; ++i) {
11551     if (ANYOF_BITMAP_TEST(ret, i)) {
11552      ANYOF_BITMAP_CLEAR(ret, i);
11553      if (DEPENDS_SEMANTICS) {
11554       if (! remove_list) {
11555        remove_list = _new_invlist(2);
11556       }
11557       remove_list = add_cp_to_invlist(remove_list, i);
11558      }
11559     }
11560     else {
11561      ANYOF_BITMAP_SET(ret, i);
11562      prevvalue = value;
11563      value = i;
11564     }
11565    }
11566
11567    /* And do the removal */
11568    if (DEPENDS_SEMANTICS) {
11569     if (remove_list) {
11570      _invlist_subtract(nonbitmap, remove_list, &nonbitmap);
11571      SvREFCNT_dec(remove_list);
11572     }
11573    }
11574    else {
11575     /* There is no overlap for non-/d, so just delete anything
11576     * below 256 */
11577     _invlist_intersection(nonbitmap, PL_AboveLatin1, &nonbitmap);
11578    }
11579   }
11580
11581   stored = 256 - stored;
11582
11583   /* Clear the invert flag since have just done it here */
11584   ANYOF_FLAGS(ret) &= ~ANYOF_INVERT;
11585  }
11586
11587  /* Folding in the bitmap is taken care of above, but not for locale (for
11588  * which we have to wait to see what folding is in effect at runtime), and
11589  * for some things not in the bitmap (only the upper latin folds in this
11590  * case, as all other single-char folding has been set above).  Set
11591  * run-time fold flag for these */
11592  if (FOLD && (LOC
11593     || (DEPENDS_SEMANTICS
11594      && nonbitmap
11595      && ! (ANYOF_FLAGS(ret) & ANYOF_NONBITMAP_NON_UTF8))
11596     || unicode_alternate))
11597  {
11598   ANYOF_FLAGS(ret) |= ANYOF_LOC_NONBITMAP_FOLD;
11599  }
11600
11601  /* A single character class can be "optimized" into an EXACTish node.
11602  * Note that since we don't currently count how many characters there are
11603  * outside the bitmap, we are XXX missing optimization possibilities for
11604  * them.  This optimization can't happen unless this is a truly single
11605  * character class, which means that it can't be an inversion into a
11606  * many-character class, and there must be no possibility of there being
11607  * things outside the bitmap.  'stored' (only) for locales doesn't include
11608  * \w, etc, so have to make a special test that they aren't present
11609  *
11610  * Similarly A 2-character class of the very special form like [bB] can be
11611  * optimized into an EXACTFish node, but only for non-locales, and for
11612  * characters which only have the two folds; so things like 'fF' and 'Ii'
11613  * wouldn't work because they are part of the fold of 'LATIN SMALL LIGATURE
11614  * FI'. */
11615  if (! nonbitmap
11616   && ! unicode_alternate
11617   && SvCUR(listsv) == initial_listsv_len
11618   && ! (ANYOF_FLAGS(ret) & (ANYOF_INVERT|ANYOF_UNICODE_ALL))
11619   && (((stored == 1 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
11620        || (! ANYOF_CLASS_TEST_ANY_SET(ret)))))
11621    || (stored == 2 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
11622         && (! _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(value))
11623         /* If the latest code point has a fold whose
11624         * bit is set, it must be the only other one */
11625         && ((prevvalue = PL_fold_latin1[value]) != (IV)value)
11626         && ANYOF_BITMAP_TEST(ret, prevvalue)))))
11627  {
11628   /* Note that the information needed to decide to do this optimization
11629   * is not currently available until the 2nd pass, and that the actually
11630   * used EXACTish node takes less space than the calculated ANYOF node,
11631   * and hence the amount of space calculated in the first pass is larger
11632   * than actually used, so this optimization doesn't gain us any space.
11633   * But an EXACT node is faster than an ANYOF node, and can be combined
11634   * with any adjacent EXACT nodes later by the optimizer for further
11635   * gains.  The speed of executing an EXACTF is similar to an ANYOF
11636   * node, so the optimization advantage comes from the ability to join
11637   * it to adjacent EXACT nodes */
11638
11639   const char * cur_parse= RExC_parse;
11640   U8 op;
11641   RExC_emit = (regnode *)orig_emit;
11642   RExC_parse = (char *)orig_parse;
11643
11644   if (stored == 1) {
11645
11646    /* A locale node with one point can be folded; all the other cases
11647    * with folding will have two points, since we calculate them above
11648    */
11649    if (ANYOF_FLAGS(ret) & ANYOF_LOC_NONBITMAP_FOLD) {
11650     op = EXACTFL;
11651    }
11652    else {
11653     op = EXACT;
11654    }
11655   }
11656   else {   /* else 2 chars in the bit map: the folds of each other */
11657
11658    /* Use the folded value, which for the cases where we get here,
11659    * is just the lower case of the current one (which may resolve to
11660    * itself, or to the other one */
11661    value = toLOWER_LATIN1(value);
11662
11663    /* To join adjacent nodes, they must be the exact EXACTish type.
11664    * Try to use the most likely type, by using EXACTFA if possible,
11665    * then EXACTFU if the regex calls for it, or is required because
11666    * the character is non-ASCII.  (If <value> is ASCII, its fold is
11667    * also ASCII for the cases where we get here.) */
11668    if (MORE_ASCII_RESTRICTED && isASCII(value)) {
11669     op = EXACTFA;
11670    }
11671    else if (AT_LEAST_UNI_SEMANTICS || !isASCII(value)) {
11672     op = EXACTFU;
11673    }
11674    else {    /* Otherwise, more likely to be EXACTF type */
11675     op = EXACTF;
11676    }
11677   }
11678
11679   ret = reg_node(pRExC_state, op);
11680   RExC_parse = (char *)cur_parse;
11681   if (UTF && ! NATIVE_IS_INVARIANT(value)) {
11682    *STRING(ret)= UTF8_EIGHT_BIT_HI((U8) value);
11683    *(STRING(ret) + 1)= UTF8_EIGHT_BIT_LO((U8) value);
11684    STR_LEN(ret)= 2;
11685    RExC_emit += STR_SZ(2);
11686   }
11687   else {
11688    *STRING(ret)= (char)value;
11689    STR_LEN(ret)= 1;
11690    RExC_emit += STR_SZ(1);
11691   }
11692   SvREFCNT_dec(listsv);
11693   return ret;
11694  }
11695
11696  /* If there is a swash and more than one element, we can't use the swash in
11697  * the optimization below. */
11698  if (swash && element_count > 1) {
11699   SvREFCNT_dec(swash);
11700   swash = NULL;
11701  }
11702  if (! nonbitmap
11703   && SvCUR(listsv) == initial_listsv_len
11704   && ! unicode_alternate)
11705  {
11706   ARG_SET(ret, ANYOF_NONBITMAP_EMPTY);
11707   SvREFCNT_dec(listsv);
11708   SvREFCNT_dec(unicode_alternate);
11709  }
11710  else {
11711   /* av[0] stores the character class description in its textual form:
11712   *       used later (regexec.c:Perl_regclass_swash()) to initialize the
11713   *       appropriate swash, and is also useful for dumping the regnode.
11714   * av[1] if NULL, is a placeholder to later contain the swash computed
11715   *       from av[0].  But if no further computation need be done, the
11716   *       swash is stored there now.
11717   * av[2] stores the multicharacter foldings, used later in
11718   *       regexec.c:S_reginclass().
11719   * av[3] stores the nonbitmap inversion list for use in addition or
11720   *       instead of av[0]; not used if av[1] isn't NULL
11721   * av[4] is set if any component of the class is from a user-defined
11722   *       property; not used if av[1] isn't NULL */
11723   AV * const av = newAV();
11724   SV *rv;
11725
11726   av_store(av, 0, (SvCUR(listsv) == initial_listsv_len)
11727       ? &PL_sv_undef
11728       : listsv);
11729   if (swash) {
11730    av_store(av, 1, swash);
11731    SvREFCNT_dec(nonbitmap);
11732   }
11733   else {
11734    av_store(av, 1, NULL);
11735    if (nonbitmap) {
11736     av_store(av, 3, nonbitmap);
11737     av_store(av, 4, newSVuv(has_user_defined_property));
11738    }
11739   }
11740
11741   /* Store any computed multi-char folds only if we are allowing
11742   * them */
11743   if (allow_full_fold) {
11744    av_store(av, 2, MUTABLE_SV(unicode_alternate));
11745    if (unicode_alternate) { /* This node is variable length */
11746     OP(ret) = ANYOFV;
11747    }
11748   }
11749   else {
11750    av_store(av, 2, NULL);
11751   }
11752   rv = newRV_noinc(MUTABLE_SV(av));
11753   n = add_data(pRExC_state, 1, "s");
11754   RExC_rxi->data->data[n] = (void*)rv;
11755   ARG_SET(ret, n);
11756  }
11757  return ret;
11758 }
11759
11760
11761 /* reg_skipcomment()
11762
11763    Absorbs an /x style # comments from the input stream.
11764    Returns true if there is more text remaining in the stream.
11765    Will set the REG_SEEN_RUN_ON_COMMENT flag if the comment
11766    terminates the pattern without including a newline.
11767
11768    Note its the callers responsibility to ensure that we are
11769    actually in /x mode
11770
11771 */
11772
11773 STATIC bool
11774 S_reg_skipcomment(pTHX_ RExC_state_t *pRExC_state)
11775 {
11776  bool ended = 0;
11777
11778  PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
11779
11780  while (RExC_parse < RExC_end)
11781   if (*RExC_parse++ == '\n') {
11782    ended = 1;
11783    break;
11784   }
11785  if (!ended) {
11786   /* we ran off the end of the pattern without ending
11787   the comment, so we have to add an \n when wrapping */
11788   RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
11789   return 0;
11790  } else
11791   return 1;
11792 }
11793
11794 /* nextchar()
11795
11796    Advances the parse position, and optionally absorbs
11797    "whitespace" from the inputstream.
11798
11799    Without /x "whitespace" means (?#...) style comments only,
11800    with /x this means (?#...) and # comments and whitespace proper.
11801
11802    Returns the RExC_parse point from BEFORE the scan occurs.
11803
11804    This is the /x friendly way of saying RExC_parse++.
11805 */
11806
11807 STATIC char*
11808 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
11809 {
11810  char* const retval = RExC_parse++;
11811
11812  PERL_ARGS_ASSERT_NEXTCHAR;
11813
11814  for (;;) {
11815   if (RExC_end - RExC_parse >= 3
11816    && *RExC_parse == '('
11817    && RExC_parse[1] == '?'
11818    && RExC_parse[2] == '#')
11819   {
11820    while (*RExC_parse != ')') {
11821     if (RExC_parse == RExC_end)
11822      FAIL("Sequence (?#... not terminated");
11823     RExC_parse++;
11824    }
11825    RExC_parse++;
11826    continue;
11827   }
11828   if (RExC_flags & RXf_PMf_EXTENDED) {
11829    if (isSPACE(*RExC_parse)) {
11830     RExC_parse++;
11831     continue;
11832    }
11833    else if (*RExC_parse == '#') {
11834     if ( reg_skipcomment( pRExC_state ) )
11835      continue;
11836    }
11837   }
11838   return retval;
11839  }
11840 }
11841
11842 /*
11843 - reg_node - emit a node
11844 */
11845 STATIC regnode *   /* Location. */
11846 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
11847 {
11848  dVAR;
11849  register regnode *ptr;
11850  regnode * const ret = RExC_emit;
11851  GET_RE_DEBUG_FLAGS_DECL;
11852
11853  PERL_ARGS_ASSERT_REG_NODE;
11854
11855  if (SIZE_ONLY) {
11856   SIZE_ALIGN(RExC_size);
11857   RExC_size += 1;
11858   return(ret);
11859  }
11860  if (RExC_emit >= RExC_emit_bound)
11861   Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
11862     op, RExC_emit, RExC_emit_bound);
11863
11864  NODE_ALIGN_FILL(ret);
11865  ptr = ret;
11866  FILL_ADVANCE_NODE(ptr, op);
11867  REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, (ptr) - 1);
11868 #ifdef RE_TRACK_PATTERN_OFFSETS
11869  if (RExC_offsets) {         /* MJD */
11870   MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n",
11871    "reg_node", __LINE__,
11872    PL_reg_name[op],
11873    (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0]
11874     ? "Overwriting end of array!\n" : "OK",
11875    (UV)(RExC_emit - RExC_emit_start),
11876    (UV)(RExC_parse - RExC_start),
11877    (UV)RExC_offsets[0]));
11878   Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
11879  }
11880 #endif
11881  RExC_emit = ptr;
11882  return(ret);
11883 }
11884
11885 /*
11886 - reganode - emit a node with an argument
11887 */
11888 STATIC regnode *   /* Location. */
11889 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
11890 {
11891  dVAR;
11892  register regnode *ptr;
11893  regnode * const ret = RExC_emit;
11894  GET_RE_DEBUG_FLAGS_DECL;
11895
11896  PERL_ARGS_ASSERT_REGANODE;
11897
11898  if (SIZE_ONLY) {
11899   SIZE_ALIGN(RExC_size);
11900   RExC_size += 2;
11901   /*
11902   We can't do this:
11903
11904   assert(2==regarglen[op]+1);
11905
11906   Anything larger than this has to allocate the extra amount.
11907   If we changed this to be:
11908
11909   RExC_size += (1 + regarglen[op]);
11910
11911   then it wouldn't matter. Its not clear what side effect
11912   might come from that so its not done so far.
11913   -- dmq
11914   */
11915   return(ret);
11916  }
11917  if (RExC_emit >= RExC_emit_bound)
11918   Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
11919     op, RExC_emit, RExC_emit_bound);
11920
11921  NODE_ALIGN_FILL(ret);
11922  ptr = ret;
11923  FILL_ADVANCE_NODE_ARG(ptr, op, arg);
11924  REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, (ptr) - 2);
11925 #ifdef RE_TRACK_PATTERN_OFFSETS
11926  if (RExC_offsets) {         /* MJD */
11927   MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n",
11928    "reganode",
11929    __LINE__,
11930    PL_reg_name[op],
11931    (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ?
11932    "Overwriting end of array!\n" : "OK",
11933    (UV)(RExC_emit - RExC_emit_start),
11934    (UV)(RExC_parse - RExC_start),
11935    (UV)RExC_offsets[0]));
11936   Set_Cur_Node_Offset;
11937  }
11938 #endif
11939  RExC_emit = ptr;
11940  return(ret);
11941 }
11942
11943 /*
11944 - reguni - emit (if appropriate) a Unicode character
11945 */
11946 STATIC STRLEN
11947 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
11948 {
11949  dVAR;
11950
11951  PERL_ARGS_ASSERT_REGUNI;
11952
11953  return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
11954 }
11955
11956 /*
11957 - reginsert - insert an operator in front of already-emitted operand
11958 *
11959 * Means relocating the operand.
11960 */
11961 STATIC void
11962 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
11963 {
11964  dVAR;
11965  register regnode *src;
11966  register regnode *dst;
11967  register regnode *place;
11968  const int offset = regarglen[(U8)op];
11969  const int size = NODE_STEP_REGNODE + offset;
11970  GET_RE_DEBUG_FLAGS_DECL;
11971
11972  PERL_ARGS_ASSERT_REGINSERT;
11973  PERL_UNUSED_ARG(depth);
11974 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
11975  DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
11976  if (SIZE_ONLY) {
11977   RExC_size += size;
11978   return;
11979  }
11980
11981  src = RExC_emit;
11982  RExC_emit += size;
11983  dst = RExC_emit;
11984  if (RExC_open_parens) {
11985   int paren;
11986   /*DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);*/
11987   for ( paren=0 ; paren < RExC_npar ; paren++ ) {
11988    if ( RExC_open_parens[paren] >= opnd ) {
11989     /*DEBUG_PARSE_FMT("open"," - %d",size);*/
11990     RExC_open_parens[paren] += size;
11991    } else {
11992     /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
11993    }
11994    if ( RExC_close_parens[paren] >= opnd ) {
11995     /*DEBUG_PARSE_FMT("close"," - %d",size);*/
11996     RExC_close_parens[paren] += size;
11997    } else {
11998     /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
11999    }
12000   }
12001  }
12002
12003  while (src > opnd) {
12004   StructCopy(--src, --dst, regnode);
12005 #ifdef RE_TRACK_PATTERN_OFFSETS
12006   if (RExC_offsets) {     /* MJD 20010112 */
12007    MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
12008     "reg_insert",
12009     __LINE__,
12010     PL_reg_name[op],
12011     (UV)(dst - RExC_emit_start) > RExC_offsets[0]
12012      ? "Overwriting end of array!\n" : "OK",
12013     (UV)(src - RExC_emit_start),
12014     (UV)(dst - RExC_emit_start),
12015     (UV)RExC_offsets[0]));
12016    Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
12017    Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
12018   }
12019 #endif
12020  }
12021
12022
12023  place = opnd;  /* Op node, where operand used to be. */
12024 #ifdef RE_TRACK_PATTERN_OFFSETS
12025  if (RExC_offsets) {         /* MJD */
12026   MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n",
12027    "reginsert",
12028    __LINE__,
12029    PL_reg_name[op],
12030    (UV)(place - RExC_emit_start) > RExC_offsets[0]
12031    ? "Overwriting end of array!\n" : "OK",
12032    (UV)(place - RExC_emit_start),
12033    (UV)(RExC_parse - RExC_start),
12034    (UV)RExC_offsets[0]));
12035   Set_Node_Offset(place, RExC_parse);
12036   Set_Node_Length(place, 1);
12037  }
12038 #endif
12039  src = NEXTOPER(place);
12040  FILL_ADVANCE_NODE(place, op);
12041  REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, (place) - 1);
12042  Zero(src, offset, regnode);
12043 }
12044
12045 /*
12046 - regtail - set the next-pointer at the end of a node chain of p to val.
12047 - SEE ALSO: regtail_study
12048 */
12049 /* TODO: All three parms should be const */
12050 STATIC void
12051 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
12052 {
12053  dVAR;
12054  register regnode *scan;
12055  GET_RE_DEBUG_FLAGS_DECL;
12056
12057  PERL_ARGS_ASSERT_REGTAIL;
12058 #ifndef DEBUGGING
12059  PERL_UNUSED_ARG(depth);
12060 #endif
12061
12062  if (SIZE_ONLY)
12063   return;
12064
12065  /* Find last node. */
12066  scan = p;
12067  for (;;) {
12068   regnode * const temp = regnext(scan);
12069   DEBUG_PARSE_r({
12070    SV * const mysv=sv_newmortal();
12071    DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
12072    regprop(RExC_rx, mysv, scan);
12073    PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
12074     SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
12075      (temp == NULL ? "->" : ""),
12076      (temp == NULL ? PL_reg_name[OP(val)] : "")
12077    );
12078   });
12079   if (temp == NULL)
12080    break;
12081   scan = temp;
12082  }
12083
12084  if (reg_off_by_arg[OP(scan)]) {
12085   ARG_SET(scan, val - scan);
12086  }
12087  else {
12088   NEXT_OFF(scan) = val - scan;
12089  }
12090 }
12091
12092 #ifdef DEBUGGING
12093 /*
12094 - regtail_study - set the next-pointer at the end of a node chain of p to val.
12095 - Look for optimizable sequences at the same time.
12096 - currently only looks for EXACT chains.
12097
12098 This is experimental code. The idea is to use this routine to perform
12099 in place optimizations on branches and groups as they are constructed,
12100 with the long term intention of removing optimization from study_chunk so
12101 that it is purely analytical.
12102
12103 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
12104 to control which is which.
12105
12106 */
12107 /* TODO: All four parms should be const */
12108
12109 STATIC U8
12110 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
12111 {
12112  dVAR;
12113  register regnode *scan;
12114  U8 exact = PSEUDO;
12115 #ifdef EXPERIMENTAL_INPLACESCAN
12116  I32 min = 0;
12117 #endif
12118  GET_RE_DEBUG_FLAGS_DECL;
12119
12120  PERL_ARGS_ASSERT_REGTAIL_STUDY;
12121
12122
12123  if (SIZE_ONLY)
12124   return exact;
12125
12126  /* Find last node. */
12127
12128  scan = p;
12129  for (;;) {
12130   regnode * const temp = regnext(scan);
12131 #ifdef EXPERIMENTAL_INPLACESCAN
12132   if (PL_regkind[OP(scan)] == EXACT) {
12133    bool has_exactf_sharp_s; /* Unexamined in this routine */
12134    if (join_exact(pRExC_state,scan,&min, &has_exactf_sharp_s, 1,val,depth+1))
12135     return EXACT;
12136   }
12137 #endif
12138   if ( exact ) {
12139    switch (OP(scan)) {
12140     case EXACT:
12141     case EXACTF:
12142     case EXACTFA:
12143     case EXACTFU:
12144     case EXACTFU_SS:
12145     case EXACTFU_TRICKYFOLD:
12146     case EXACTFL:
12147       if( exact == PSEUDO )
12148        exact= OP(scan);
12149       else if ( exact != OP(scan) )
12150        exact= 0;
12151     case NOTHING:
12152      break;
12153     default:
12154      exact= 0;
12155    }
12156   }
12157   DEBUG_PARSE_r({
12158    SV * const mysv=sv_newmortal();
12159    DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
12160    regprop(RExC_rx, mysv, scan);
12161    PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
12162     SvPV_nolen_const(mysv),
12163     REG_NODE_NUM(scan),
12164     PL_reg_name[exact]);
12165   });
12166   if (temp == NULL)
12167    break;
12168   scan = temp;
12169  }
12170  DEBUG_PARSE_r({
12171   SV * const mysv_val=sv_newmortal();
12172   DEBUG_PARSE_MSG("");
12173   regprop(RExC_rx, mysv_val, val);
12174   PerlIO_printf(Perl_debug_log, "~ attach to %s (%"IVdf") offset to %"IVdf"\n",
12175      SvPV_nolen_const(mysv_val),
12176      (IV)REG_NODE_NUM(val),
12177      (IV)(val - scan)
12178   );
12179  });
12180  if (reg_off_by_arg[OP(scan)]) {
12181   ARG_SET(scan, val - scan);
12182  }
12183  else {
12184   NEXT_OFF(scan) = val - scan;
12185  }
12186
12187  return exact;
12188 }
12189 #endif
12190
12191 /*
12192  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
12193  */
12194 #ifdef DEBUGGING
12195 static void
12196 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
12197 {
12198  int bit;
12199  int set=0;
12200  regex_charset cs;
12201
12202  for (bit=0; bit<32; bit++) {
12203   if (flags & (1<<bit)) {
12204    if ((1<<bit) & RXf_PMf_CHARSET) { /* Output separately, below */
12205     continue;
12206    }
12207    if (!set++ && lead)
12208     PerlIO_printf(Perl_debug_log, "%s",lead);
12209    PerlIO_printf(Perl_debug_log, "%s ",PL_reg_extflags_name[bit]);
12210   }
12211  }
12212  if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
12213    if (!set++ && lead) {
12214     PerlIO_printf(Perl_debug_log, "%s",lead);
12215    }
12216    switch (cs) {
12217     case REGEX_UNICODE_CHARSET:
12218      PerlIO_printf(Perl_debug_log, "UNICODE");
12219      break;
12220     case REGEX_LOCALE_CHARSET:
12221      PerlIO_printf(Perl_debug_log, "LOCALE");
12222      break;
12223     case REGEX_ASCII_RESTRICTED_CHARSET:
12224      PerlIO_printf(Perl_debug_log, "ASCII-RESTRICTED");
12225      break;
12226     case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
12227      PerlIO_printf(Perl_debug_log, "ASCII-MORE_RESTRICTED");
12228      break;
12229     default:
12230      PerlIO_printf(Perl_debug_log, "UNKNOWN CHARACTER SET");
12231      break;
12232    }
12233  }
12234  if (lead)  {
12235   if (set)
12236    PerlIO_printf(Perl_debug_log, "\n");
12237   else
12238    PerlIO_printf(Perl_debug_log, "%s[none-set]\n",lead);
12239  }
12240 }
12241 #endif
12242
12243 void
12244 Perl_regdump(pTHX_ const regexp *r)
12245 {
12246 #ifdef DEBUGGING
12247  dVAR;
12248  SV * const sv = sv_newmortal();
12249  SV *dsv= sv_newmortal();
12250  RXi_GET_DECL(r,ri);
12251  GET_RE_DEBUG_FLAGS_DECL;
12252
12253  PERL_ARGS_ASSERT_REGDUMP;
12254
12255  (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
12256
12257  /* Header fields of interest. */
12258  if (r->anchored_substr) {
12259   RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr),
12260    RE_SV_DUMPLEN(r->anchored_substr), 30);
12261   PerlIO_printf(Perl_debug_log,
12262      "anchored %s%s at %"IVdf" ",
12263      s, RE_SV_TAIL(r->anchored_substr),
12264      (IV)r->anchored_offset);
12265  } else if (r->anchored_utf8) {
12266   RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8),
12267    RE_SV_DUMPLEN(r->anchored_utf8), 30);
12268   PerlIO_printf(Perl_debug_log,
12269      "anchored utf8 %s%s at %"IVdf" ",
12270      s, RE_SV_TAIL(r->anchored_utf8),
12271      (IV)r->anchored_offset);
12272  }
12273  if (r->float_substr) {
12274   RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr),
12275    RE_SV_DUMPLEN(r->float_substr), 30);
12276   PerlIO_printf(Perl_debug_log,
12277      "floating %s%s at %"IVdf"..%"UVuf" ",
12278      s, RE_SV_TAIL(r->float_substr),
12279      (IV)r->float_min_offset, (UV)r->float_max_offset);
12280  } else if (r->float_utf8) {
12281   RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8),
12282    RE_SV_DUMPLEN(r->float_utf8), 30);
12283   PerlIO_printf(Perl_debug_log,
12284      "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
12285      s, RE_SV_TAIL(r->float_utf8),
12286      (IV)r->float_min_offset, (UV)r->float_max_offset);
12287  }
12288  if (r->check_substr || r->check_utf8)
12289   PerlIO_printf(Perl_debug_log,
12290      (const char *)
12291      (r->check_substr == r->float_substr
12292      && r->check_utf8 == r->float_utf8
12293      ? "(checking floating" : "(checking anchored"));
12294  if (r->extflags & RXf_NOSCAN)
12295   PerlIO_printf(Perl_debug_log, " noscan");
12296  if (r->extflags & RXf_CHECK_ALL)
12297   PerlIO_printf(Perl_debug_log, " isall");
12298  if (r->check_substr || r->check_utf8)
12299   PerlIO_printf(Perl_debug_log, ") ");
12300
12301  if (ri->regstclass) {
12302   regprop(r, sv, ri->regstclass);
12303   PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
12304  }
12305  if (r->extflags & RXf_ANCH) {
12306   PerlIO_printf(Perl_debug_log, "anchored");
12307   if (r->extflags & RXf_ANCH_BOL)
12308    PerlIO_printf(Perl_debug_log, "(BOL)");
12309   if (r->extflags & RXf_ANCH_MBOL)
12310    PerlIO_printf(Perl_debug_log, "(MBOL)");
12311   if (r->extflags & RXf_ANCH_SBOL)
12312    PerlIO_printf(Perl_debug_log, "(SBOL)");
12313   if (r->extflags & RXf_ANCH_GPOS)
12314    PerlIO_printf(Perl_debug_log, "(GPOS)");
12315   PerlIO_putc(Perl_debug_log, ' ');
12316  }
12317  if (r->extflags & RXf_GPOS_SEEN)
12318   PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs);
12319  if (r->intflags & PREGf_SKIP)
12320   PerlIO_printf(Perl_debug_log, "plus ");
12321  if (r->intflags & PREGf_IMPLICIT)
12322   PerlIO_printf(Perl_debug_log, "implicit ");
12323  PerlIO_printf(Perl_debug_log, "minlen %"IVdf" ", (IV)r->minlen);
12324  if (r->extflags & RXf_EVAL_SEEN)
12325   PerlIO_printf(Perl_debug_log, "with eval ");
12326  PerlIO_printf(Perl_debug_log, "\n");
12327  DEBUG_FLAGS_r(regdump_extflags("r->extflags: ",r->extflags));
12328 #else
12329  PERL_ARGS_ASSERT_REGDUMP;
12330  PERL_UNUSED_CONTEXT;
12331  PERL_UNUSED_ARG(r);
12332 #endif /* DEBUGGING */
12333 }
12334
12335 /*
12336 - regprop - printable representation of opcode
12337 */
12338 #define EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags) \
12339 STMT_START { \
12340   if (do_sep) {                           \
12341    Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]); \
12342    if (flags & ANYOF_INVERT)           \
12343     /*make sure the invert info is in each */ \
12344     sv_catpvs(sv, "^");             \
12345    do_sep = 0;                         \
12346   }                                       \
12347 } STMT_END
12348
12349 void
12350 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
12351 {
12352 #ifdef DEBUGGING
12353  dVAR;
12354  register int k;
12355  RXi_GET_DECL(prog,progi);
12356  GET_RE_DEBUG_FLAGS_DECL;
12357
12358  PERL_ARGS_ASSERT_REGPROP;
12359
12360  sv_setpvs(sv, "");
12361
12362  if (OP(o) > REGNODE_MAX)  /* regnode.type is unsigned */
12363   /* It would be nice to FAIL() here, but this may be called from
12364   regexec.c, and it would be hard to supply pRExC_state. */
12365   Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX);
12366  sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
12367
12368  k = PL_regkind[OP(o)];
12369
12370  if (k == EXACT) {
12371   sv_catpvs(sv, " ");
12372   /* Using is_utf8_string() (via PERL_PV_UNI_DETECT)
12373   * is a crude hack but it may be the best for now since
12374   * we have no flag "this EXACTish node was UTF-8"
12375   * --jhi */
12376   pv_pretty(sv, STRING(o), STR_LEN(o), 60, PL_colors[0], PL_colors[1],
12377     PERL_PV_ESCAPE_UNI_DETECT |
12378     PERL_PV_ESCAPE_NONASCII   |
12379     PERL_PV_PRETTY_ELLIPSES   |
12380     PERL_PV_PRETTY_LTGT       |
12381     PERL_PV_PRETTY_NOCLEAR
12382     );
12383  } else if (k == TRIE) {
12384   /* print the details of the trie in dumpuntil instead, as
12385   * progi->data isn't available here */
12386   const char op = OP(o);
12387   const U32 n = ARG(o);
12388   const reg_ac_data * const ac = IS_TRIE_AC(op) ?
12389    (reg_ac_data *)progi->data->data[n] :
12390    NULL;
12391   const reg_trie_data * const trie
12392    = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
12393
12394   Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
12395   DEBUG_TRIE_COMPILE_r(
12396    Perl_sv_catpvf(aTHX_ sv,
12397     "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
12398     (UV)trie->startstate,
12399     (IV)trie->statecount-1, /* -1 because of the unused 0 element */
12400     (UV)trie->wordcount,
12401     (UV)trie->minlen,
12402     (UV)trie->maxlen,
12403     (UV)TRIE_CHARCOUNT(trie),
12404     (UV)trie->uniquecharcount
12405    )
12406   );
12407   if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
12408    int i;
12409    int rangestart = -1;
12410    U8* bitmap = IS_ANYOF_TRIE(op) ? (U8*)ANYOF_BITMAP(o) : (U8*)TRIE_BITMAP(trie);
12411    sv_catpvs(sv, "[");
12412    for (i = 0; i <= 256; i++) {
12413     if (i < 256 && BITMAP_TEST(bitmap,i)) {
12414      if (rangestart == -1)
12415       rangestart = i;
12416     } else if (rangestart != -1) {
12417      if (i <= rangestart + 3)
12418       for (; rangestart < i; rangestart++)
12419        put_byte(sv, rangestart);
12420      else {
12421       put_byte(sv, rangestart);
12422       sv_catpvs(sv, "-");
12423       put_byte(sv, i - 1);
12424      }
12425      rangestart = -1;
12426     }
12427    }
12428    sv_catpvs(sv, "]");
12429   }
12430
12431  } else if (k == CURLY) {
12432   if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
12433    Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
12434   Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
12435  }
12436  else if (k == WHILEM && o->flags)   /* Ordinal/of */
12437   Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
12438  else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) {
12439   Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o)); /* Parenth number */
12440   if ( RXp_PAREN_NAMES(prog) ) {
12441    if ( k != REF || (OP(o) < NREF)) {
12442     AV *list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
12443     SV **name= av_fetch(list, ARG(o), 0 );
12444     if (name)
12445      Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
12446    }
12447    else {
12448     AV *list= MUTABLE_AV(progi->data->data[ progi->name_list_idx ]);
12449     SV *sv_dat= MUTABLE_SV(progi->data->data[ ARG( o ) ]);
12450     I32 *nums=(I32*)SvPVX(sv_dat);
12451     SV **name= av_fetch(list, nums[0], 0 );
12452     I32 n;
12453     if (name) {
12454      for ( n=0; n<SvIVX(sv_dat); n++ ) {
12455       Perl_sv_catpvf(aTHX_ sv, "%s%"IVdf,
12456          (n ? "," : ""), (IV)nums[n]);
12457      }
12458      Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
12459     }
12460    }
12461   }
12462  } else if (k == GOSUB)
12463   Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */
12464  else if (k == VERB) {
12465   if (!o->flags)
12466    Perl_sv_catpvf(aTHX_ sv, ":%"SVf,
12467       SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
12468  } else if (k == LOGICAL)
12469   Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* 2: embedded, otherwise 1 */
12470  else if (k == ANYOF) {
12471   int i, rangestart = -1;
12472   const U8 flags = ANYOF_FLAGS(o);
12473   int do_sep = 0;
12474
12475   /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
12476   static const char * const anyofs[] = {
12477    "\\w",
12478    "\\W",
12479    "\\s",
12480    "\\S",
12481    "\\d",
12482    "\\D",
12483    "[:alnum:]",
12484    "[:^alnum:]",
12485    "[:alpha:]",
12486    "[:^alpha:]",
12487    "[:ascii:]",
12488    "[:^ascii:]",
12489    "[:cntrl:]",
12490    "[:^cntrl:]",
12491    "[:graph:]",
12492    "[:^graph:]",
12493    "[:lower:]",
12494    "[:^lower:]",
12495    "[:print:]",
12496    "[:^print:]",
12497    "[:punct:]",
12498    "[:^punct:]",
12499    "[:upper:]",
12500    "[:^upper:]",
12501    "[:xdigit:]",
12502    "[:^xdigit:]",
12503    "[:space:]",
12504    "[:^space:]",
12505    "[:blank:]",
12506    "[:^blank:]"
12507   };
12508
12509   if (flags & ANYOF_LOCALE)
12510    sv_catpvs(sv, "{loc}");
12511   if (flags & ANYOF_LOC_NONBITMAP_FOLD)
12512    sv_catpvs(sv, "{i}");
12513   Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
12514   if (flags & ANYOF_INVERT)
12515    sv_catpvs(sv, "^");
12516
12517   /* output what the standard cp 0-255 bitmap matches */
12518   for (i = 0; i <= 256; i++) {
12519    if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
12520     if (rangestart == -1)
12521      rangestart = i;
12522    } else if (rangestart != -1) {
12523     if (i <= rangestart + 3)
12524      for (; rangestart < i; rangestart++)
12525       put_byte(sv, rangestart);
12526     else {
12527      put_byte(sv, rangestart);
12528      sv_catpvs(sv, "-");
12529      put_byte(sv, i - 1);
12530     }
12531     do_sep = 1;
12532     rangestart = -1;
12533    }
12534   }
12535
12536   EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
12537   /* output any special charclass tests (used entirely under use locale) */
12538   if (ANYOF_CLASS_TEST_ANY_SET(o))
12539    for (i = 0; i < (int)(sizeof(anyofs)/sizeof(char*)); i++)
12540     if (ANYOF_CLASS_TEST(o,i)) {
12541      sv_catpv(sv, anyofs[i]);
12542      do_sep = 1;
12543     }
12544
12545   EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
12546
12547   if (flags & ANYOF_NON_UTF8_LATIN1_ALL) {
12548    sv_catpvs(sv, "{non-utf8-latin1-all}");
12549   }
12550
12551   /* output information about the unicode matching */
12552   if (flags & ANYOF_UNICODE_ALL)
12553    sv_catpvs(sv, "{unicode_all}");
12554   else if (ANYOF_NONBITMAP(o))
12555    sv_catpvs(sv, "{unicode}");
12556   if (flags & ANYOF_NONBITMAP_NON_UTF8)
12557    sv_catpvs(sv, "{outside bitmap}");
12558
12559   if (ANYOF_NONBITMAP(o)) {
12560    SV *lv; /* Set if there is something outside the bit map */
12561    SV * const sw = regclass_swash(prog, o, FALSE, &lv, 0);
12562    bool byte_output = FALSE;   /* If something in the bitmap has been
12563           output */
12564
12565    if (lv && lv != &PL_sv_undef) {
12566     if (sw) {
12567      U8 s[UTF8_MAXBYTES_CASE+1];
12568
12569      for (i = 0; i <= 256; i++) { /* Look at chars in bitmap */
12570       uvchr_to_utf8(s, i);
12571
12572       if (i < 256
12573        && ! ANYOF_BITMAP_TEST(o, i)    /* Don't duplicate
12574                things already
12575                output as part
12576                of the bitmap */
12577        && swash_fetch(sw, s, TRUE))
12578       {
12579        if (rangestart == -1)
12580         rangestart = i;
12581       } else if (rangestart != -1) {
12582        byte_output = TRUE;
12583        if (i <= rangestart + 3)
12584         for (; rangestart < i; rangestart++) {
12585          put_byte(sv, rangestart);
12586         }
12587        else {
12588         put_byte(sv, rangestart);
12589         sv_catpvs(sv, "-");
12590         put_byte(sv, i-1);
12591        }
12592        rangestart = -1;
12593       }
12594      }
12595     }
12596
12597     {
12598      char *s = savesvpv(lv);
12599      char * const origs = s;
12600
12601      while (*s && *s != '\n')
12602       s++;
12603
12604      if (*s == '\n') {
12605       const char * const t = ++s;
12606
12607       if (byte_output) {
12608        sv_catpvs(sv, " ");
12609       }
12610
12611       while (*s) {
12612        if (*s == '\n') {
12613
12614         /* Truncate very long output */
12615         if (s - origs > 256) {
12616          Perl_sv_catpvf(aTHX_ sv,
12617             "%.*s...",
12618             (int) (s - origs - 1),
12619             t);
12620          goto out_dump;
12621         }
12622         *s = ' ';
12623        }
12624        else if (*s == '\t') {
12625         *s = '-';
12626        }
12627        s++;
12628       }
12629       if (s[-1] == ' ')
12630        s[-1] = 0;
12631
12632       sv_catpv(sv, t);
12633      }
12634
12635     out_dump:
12636
12637      Safefree(origs);
12638     }
12639     SvREFCNT_dec(lv);
12640    }
12641   }
12642
12643   Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
12644  }
12645  else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
12646   Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
12647 #else
12648  PERL_UNUSED_CONTEXT;
12649  PERL_UNUSED_ARG(sv);
12650  PERL_UNUSED_ARG(o);
12651  PERL_UNUSED_ARG(prog);
12652 #endif /* DEBUGGING */
12653 }
12654
12655 SV *
12656 Perl_re_intuit_string(pTHX_ REGEXP * const r)
12657 {    /* Assume that RE_INTUIT is set */
12658  dVAR;
12659  struct regexp *const prog = (struct regexp *)SvANY(r);
12660  GET_RE_DEBUG_FLAGS_DECL;
12661
12662  PERL_ARGS_ASSERT_RE_INTUIT_STRING;
12663  PERL_UNUSED_CONTEXT;
12664
12665  DEBUG_COMPILE_r(
12666   {
12667    const char * const s = SvPV_nolen_const(prog->check_substr
12668      ? prog->check_substr : prog->check_utf8);
12669
12670    if (!PL_colorset) reginitcolors();
12671    PerlIO_printf(Perl_debug_log,
12672      "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
12673      PL_colors[4],
12674      prog->check_substr ? "" : "utf8 ",
12675      PL_colors[5],PL_colors[0],
12676      s,
12677      PL_colors[1],
12678      (strlen(s) > 60 ? "..." : ""));
12679   } );
12680
12681  return prog->check_substr ? prog->check_substr : prog->check_utf8;
12682 }
12683
12684 /*
12685    pregfree()
12686
12687    handles refcounting and freeing the perl core regexp structure. When
12688    it is necessary to actually free the structure the first thing it
12689    does is call the 'free' method of the regexp_engine associated to
12690    the regexp, allowing the handling of the void *pprivate; member
12691    first. (This routine is not overridable by extensions, which is why
12692    the extensions free is called first.)
12693
12694    See regdupe and regdupe_internal if you change anything here.
12695 */
12696 #ifndef PERL_IN_XSUB_RE
12697 void
12698 Perl_pregfree(pTHX_ REGEXP *r)
12699 {
12700  SvREFCNT_dec(r);
12701 }
12702
12703 void
12704 Perl_pregfree2(pTHX_ REGEXP *rx)
12705 {
12706  dVAR;
12707  struct regexp *const r = (struct regexp *)SvANY(rx);
12708  GET_RE_DEBUG_FLAGS_DECL;
12709
12710  PERL_ARGS_ASSERT_PREGFREE2;
12711
12712  if (r->mother_re) {
12713   ReREFCNT_dec(r->mother_re);
12714  } else {
12715   CALLREGFREE_PVT(rx); /* free the private data */
12716   SvREFCNT_dec(RXp_PAREN_NAMES(r));
12717  }
12718  if (r->substrs) {
12719   SvREFCNT_dec(r->anchored_substr);
12720   SvREFCNT_dec(r->anchored_utf8);
12721   SvREFCNT_dec(r->float_substr);
12722   SvREFCNT_dec(r->float_utf8);
12723   Safefree(r->substrs);
12724  }
12725  RX_MATCH_COPY_FREE(rx);
12726 #ifdef PERL_OLD_COPY_ON_WRITE
12727  SvREFCNT_dec(r->saved_copy);
12728 #endif
12729  Safefree(r->offs);
12730 }
12731
12732 /*  reg_temp_copy()
12733
12734  This is a hacky workaround to the structural issue of match results
12735  being stored in the regexp structure which is in turn stored in
12736  PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
12737  could be PL_curpm in multiple contexts, and could require multiple
12738  result sets being associated with the pattern simultaneously, such
12739  as when doing a recursive match with (??{$qr})
12740
12741  The solution is to make a lightweight copy of the regexp structure
12742  when a qr// is returned from the code executed by (??{$qr}) this
12743  lightweight copy doesn't actually own any of its data except for
12744  the starp/end and the actual regexp structure itself.
12745
12746 */
12747
12748
12749 REGEXP *
12750 Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
12751 {
12752  struct regexp *ret;
12753  struct regexp *const r = (struct regexp *)SvANY(rx);
12754  register const I32 npar = r->nparens+1;
12755
12756  PERL_ARGS_ASSERT_REG_TEMP_COPY;
12757
12758  if (!ret_x)
12759   ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
12760  ret = (struct regexp *)SvANY(ret_x);
12761
12762  (void)ReREFCNT_inc(rx);
12763  /* We can take advantage of the existing "copied buffer" mechanism in SVs
12764  by pointing directly at the buffer, but flagging that the allocated
12765  space in the copy is zero. As we've just done a struct copy, it's now
12766  a case of zero-ing that, rather than copying the current length.  */
12767  SvPV_set(ret_x, RX_WRAPPED(rx));
12768  SvFLAGS(ret_x) |= SvFLAGS(rx) & (SVf_POK|SVp_POK|SVf_UTF8);
12769  memcpy(&(ret->xpv_cur), &(r->xpv_cur),
12770   sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
12771  SvLEN_set(ret_x, 0);
12772  SvSTASH_set(ret_x, NULL);
12773  SvMAGIC_set(ret_x, NULL);
12774  Newx(ret->offs, npar, regexp_paren_pair);
12775  Copy(r->offs, ret->offs, npar, regexp_paren_pair);
12776  if (r->substrs) {
12777   Newx(ret->substrs, 1, struct reg_substr_data);
12778   StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
12779
12780   SvREFCNT_inc_void(ret->anchored_substr);
12781   SvREFCNT_inc_void(ret->anchored_utf8);
12782   SvREFCNT_inc_void(ret->float_substr);
12783   SvREFCNT_inc_void(ret->float_utf8);
12784
12785   /* check_substr and check_utf8, if non-NULL, point to either their
12786   anchored or float namesakes, and don't hold a second reference.  */
12787  }
12788  RX_MATCH_COPIED_off(ret_x);
12789 #ifdef PERL_OLD_COPY_ON_WRITE
12790  ret->saved_copy = NULL;
12791 #endif
12792  ret->mother_re = rx;
12793
12794  return ret_x;
12795 }
12796 #endif
12797
12798 /* regfree_internal()
12799
12800    Free the private data in a regexp. This is overloadable by
12801    extensions. Perl takes care of the regexp structure in pregfree(),
12802    this covers the *pprivate pointer which technically perl doesn't
12803    know about, however of course we have to handle the
12804    regexp_internal structure when no extension is in use.
12805
12806    Note this is called before freeing anything in the regexp
12807    structure.
12808  */
12809
12810 void
12811 Perl_regfree_internal(pTHX_ REGEXP * const rx)
12812 {
12813  dVAR;
12814  struct regexp *const r = (struct regexp *)SvANY(rx);
12815  RXi_GET_DECL(r,ri);
12816  GET_RE_DEBUG_FLAGS_DECL;
12817
12818  PERL_ARGS_ASSERT_REGFREE_INTERNAL;
12819
12820  DEBUG_COMPILE_r({
12821   if (!PL_colorset)
12822    reginitcolors();
12823   {
12824    SV *dsv= sv_newmortal();
12825    RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
12826     dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60);
12827    PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n",
12828     PL_colors[4],PL_colors[5],s);
12829   }
12830  });
12831 #ifdef RE_TRACK_PATTERN_OFFSETS
12832  if (ri->u.offsets)
12833   Safefree(ri->u.offsets);             /* 20010421 MJD */
12834 #endif
12835  if (ri->data) {
12836   int n = ri->data->count;
12837   PAD* new_comppad = NULL;
12838   PAD* old_comppad;
12839   PADOFFSET refcnt;
12840
12841   while (--n >= 0) {
12842   /* If you add a ->what type here, update the comment in regcomp.h */
12843    switch (ri->data->what[n]) {
12844    case 'a':
12845    case 's':
12846    case 'S':
12847    case 'u':
12848     SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
12849     break;
12850    case 'f':
12851     Safefree(ri->data->data[n]);
12852     break;
12853    case 'p':
12854     new_comppad = MUTABLE_AV(ri->data->data[n]);
12855     break;
12856    case 'o':
12857     if (new_comppad == NULL)
12858      Perl_croak(aTHX_ "panic: pregfree comppad");
12859     PAD_SAVE_LOCAL(old_comppad,
12860      /* Watch out for global destruction's random ordering. */
12861      (SvTYPE(new_comppad) == SVt_PVAV) ? new_comppad : NULL
12862     );
12863     OP_REFCNT_LOCK;
12864     refcnt = OpREFCNT_dec((OP_4tree*)ri->data->data[n]);
12865     OP_REFCNT_UNLOCK;
12866     if (!refcnt)
12867      op_free((OP_4tree*)ri->data->data[n]);
12868
12869     PAD_RESTORE_LOCAL(old_comppad);
12870     SvREFCNT_dec(MUTABLE_SV(new_comppad));
12871     new_comppad = NULL;
12872     break;
12873    case 'n':
12874     break;
12875    case 'T':
12876     { /* Aho Corasick add-on structure for a trie node.
12877      Used in stclass optimization only */
12878      U32 refcount;
12879      reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
12880      OP_REFCNT_LOCK;
12881      refcount = --aho->refcount;
12882      OP_REFCNT_UNLOCK;
12883      if ( !refcount ) {
12884       PerlMemShared_free(aho->states);
12885       PerlMemShared_free(aho->fail);
12886       /* do this last!!!! */
12887       PerlMemShared_free(ri->data->data[n]);
12888       PerlMemShared_free(ri->regstclass);
12889      }
12890     }
12891     break;
12892    case 't':
12893     {
12894      /* trie structure. */
12895      U32 refcount;
12896      reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
12897      OP_REFCNT_LOCK;
12898      refcount = --trie->refcount;
12899      OP_REFCNT_UNLOCK;
12900      if ( !refcount ) {
12901       PerlMemShared_free(trie->charmap);
12902       PerlMemShared_free(trie->states);
12903       PerlMemShared_free(trie->trans);
12904       if (trie->bitmap)
12905        PerlMemShared_free(trie->bitmap);
12906       if (trie->jump)
12907        PerlMemShared_free(trie->jump);
12908       PerlMemShared_free(trie->wordinfo);
12909       /* do this last!!!! */
12910       PerlMemShared_free(ri->data->data[n]);
12911      }
12912     }
12913     break;
12914    default:
12915     Perl_croak(aTHX_ "panic: regfree data code '%c'", ri->data->what[n]);
12916    }
12917   }
12918   Safefree(ri->data->what);
12919   Safefree(ri->data);
12920  }
12921
12922  Safefree(ri);
12923 }
12924
12925 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
12926 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
12927 #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
12928
12929 /*
12930    re_dup - duplicate a regexp.
12931
12932    This routine is expected to clone a given regexp structure. It is only
12933    compiled under USE_ITHREADS.
12934
12935    After all of the core data stored in struct regexp is duplicated
12936    the regexp_engine.dupe method is used to copy any private data
12937    stored in the *pprivate pointer. This allows extensions to handle
12938    any duplication it needs to do.
12939
12940    See pregfree() and regfree_internal() if you change anything here.
12941 */
12942 #if defined(USE_ITHREADS)
12943 #ifndef PERL_IN_XSUB_RE
12944 void
12945 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
12946 {
12947  dVAR;
12948  I32 npar;
12949  const struct regexp *r = (const struct regexp *)SvANY(sstr);
12950  struct regexp *ret = (struct regexp *)SvANY(dstr);
12951
12952  PERL_ARGS_ASSERT_RE_DUP_GUTS;
12953
12954  npar = r->nparens+1;
12955  Newx(ret->offs, npar, regexp_paren_pair);
12956  Copy(r->offs, ret->offs, npar, regexp_paren_pair);
12957  if(ret->swap) {
12958   /* no need to copy these */
12959   Newx(ret->swap, npar, regexp_paren_pair);
12960  }
12961
12962  if (ret->substrs) {
12963   /* Do it this way to avoid reading from *r after the StructCopy().
12964   That way, if any of the sv_dup_inc()s dislodge *r from the L1
12965   cache, it doesn't matter.  */
12966   const bool anchored = r->check_substr
12967    ? r->check_substr == r->anchored_substr
12968    : r->check_utf8 == r->anchored_utf8;
12969   Newx(ret->substrs, 1, struct reg_substr_data);
12970   StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
12971
12972   ret->anchored_substr = sv_dup_inc(ret->anchored_substr, param);
12973   ret->anchored_utf8 = sv_dup_inc(ret->anchored_utf8, param);
12974   ret->float_substr = sv_dup_inc(ret->float_substr, param);
12975   ret->float_utf8 = sv_dup_inc(ret->float_utf8, param);
12976
12977   /* check_substr and check_utf8, if non-NULL, point to either their
12978   anchored or float namesakes, and don't hold a second reference.  */
12979
12980   if (ret->check_substr) {
12981    if (anchored) {
12982     assert(r->check_utf8 == r->anchored_utf8);
12983     ret->check_substr = ret->anchored_substr;
12984     ret->check_utf8 = ret->anchored_utf8;
12985    } else {
12986     assert(r->check_substr == r->float_substr);
12987     assert(r->check_utf8 == r->float_utf8);
12988     ret->check_substr = ret->float_substr;
12989     ret->check_utf8 = ret->float_utf8;
12990    }
12991   } else if (ret->check_utf8) {
12992    if (anchored) {
12993     ret->check_utf8 = ret->anchored_utf8;
12994    } else {
12995     ret->check_utf8 = ret->float_utf8;
12996    }
12997   }
12998  }
12999
13000  RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
13001
13002  if (ret->pprivate)
13003   RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
13004
13005  if (RX_MATCH_COPIED(dstr))
13006   ret->subbeg  = SAVEPVN(ret->subbeg, ret->sublen);
13007  else
13008   ret->subbeg = NULL;
13009 #ifdef PERL_OLD_COPY_ON_WRITE
13010  ret->saved_copy = NULL;
13011 #endif
13012
13013  if (ret->mother_re) {
13014   if (SvPVX_const(dstr) == SvPVX_const(ret->mother_re)) {
13015    /* Our storage points directly to our mother regexp, but that's
13016    1: a buffer in a different thread
13017    2: something we no longer hold a reference on
13018    so we need to copy it locally.  */
13019    /* Note we need to use SvCUR(), rather than
13020    SvLEN(), on our mother_re, because it, in
13021    turn, may well be pointing to its own mother_re.  */
13022    SvPV_set(dstr, SAVEPVN(SvPVX_const(ret->mother_re),
13023         SvCUR(ret->mother_re)+1));
13024    SvLEN_set(dstr, SvCUR(ret->mother_re)+1);
13025   }
13026   ret->mother_re      = NULL;
13027  }
13028  ret->gofs = 0;
13029 }
13030 #endif /* PERL_IN_XSUB_RE */
13031
13032 /*
13033    regdupe_internal()
13034
13035    This is the internal complement to regdupe() which is used to copy
13036    the structure pointed to by the *pprivate pointer in the regexp.
13037    This is the core version of the extension overridable cloning hook.
13038    The regexp structure being duplicated will be copied by perl prior
13039    to this and will be provided as the regexp *r argument, however
13040    with the /old/ structures pprivate pointer value. Thus this routine
13041    may override any copying normally done by perl.
13042
13043    It returns a pointer to the new regexp_internal structure.
13044 */
13045
13046 void *
13047 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
13048 {
13049  dVAR;
13050  struct regexp *const r = (struct regexp *)SvANY(rx);
13051  regexp_internal *reti;
13052  int len;
13053  RXi_GET_DECL(r,ri);
13054
13055  PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
13056
13057  len = ProgLen(ri);
13058
13059  Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode), char, regexp_internal);
13060  Copy(ri->program, reti->program, len+1, regnode);
13061
13062
13063  reti->regstclass = NULL;
13064
13065  if (ri->data) {
13066   struct reg_data *d;
13067   const int count = ri->data->count;
13068   int i;
13069
13070   Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
13071     char, struct reg_data);
13072   Newx(d->what, count, U8);
13073
13074   d->count = count;
13075   for (i = 0; i < count; i++) {
13076    d->what[i] = ri->data->what[i];
13077    switch (d->what[i]) {
13078     /* legal options are one of: sSfpontTua
13079     see also regcomp.h and pregfree() */
13080    case 'a': /* actually an AV, but the dup function is identical.  */
13081    case 's':
13082    case 'S':
13083    case 'p': /* actually an AV, but the dup function is identical.  */
13084    case 'u': /* actually an HV, but the dup function is identical.  */
13085     d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
13086     break;
13087    case 'f':
13088     /* This is cheating. */
13089     Newx(d->data[i], 1, struct regnode_charclass_class);
13090     StructCopy(ri->data->data[i], d->data[i],
13091        struct regnode_charclass_class);
13092     reti->regstclass = (regnode*)d->data[i];
13093     break;
13094    case 'o':
13095     /* Compiled op trees are readonly and in shared memory,
13096     and can thus be shared without duplication. */
13097     OP_REFCNT_LOCK;
13098     d->data[i] = (void*)OpREFCNT_inc((OP*)ri->data->data[i]);
13099     OP_REFCNT_UNLOCK;
13100     break;
13101    case 'T':
13102     /* Trie stclasses are readonly and can thus be shared
13103     * without duplication. We free the stclass in pregfree
13104     * when the corresponding reg_ac_data struct is freed.
13105     */
13106     reti->regstclass= ri->regstclass;
13107     /* Fall through */
13108    case 't':
13109     OP_REFCNT_LOCK;
13110     ((reg_trie_data*)ri->data->data[i])->refcount++;
13111     OP_REFCNT_UNLOCK;
13112     /* Fall through */
13113    case 'n':
13114     d->data[i] = ri->data->data[i];
13115     break;
13116    default:
13117     Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", ri->data->what[i]);
13118    }
13119   }
13120
13121   reti->data = d;
13122  }
13123  else
13124   reti->data = NULL;
13125
13126  reti->name_list_idx = ri->name_list_idx;
13127
13128 #ifdef RE_TRACK_PATTERN_OFFSETS
13129  if (ri->u.offsets) {
13130   Newx(reti->u.offsets, 2*len+1, U32);
13131   Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
13132  }
13133 #else
13134  SetProgLen(reti,len);
13135 #endif
13136
13137  return (void*)reti;
13138 }
13139
13140 #endif    /* USE_ITHREADS */
13141
13142 #ifndef PERL_IN_XSUB_RE
13143
13144 /*
13145  - regnext - dig the "next" pointer out of a node
13146  */
13147 regnode *
13148 Perl_regnext(pTHX_ register regnode *p)
13149 {
13150  dVAR;
13151  register I32 offset;
13152
13153  if (!p)
13154   return(NULL);
13155
13156  if (OP(p) > REGNODE_MAX) {  /* regnode.type is unsigned */
13157   Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(p), (int)REGNODE_MAX);
13158  }
13159
13160  offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
13161  if (offset == 0)
13162   return(NULL);
13163
13164  return(p+offset);
13165 }
13166 #endif
13167
13168 STATIC void
13169 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
13170 {
13171  va_list args;
13172  STRLEN l1 = strlen(pat1);
13173  STRLEN l2 = strlen(pat2);
13174  char buf[512];
13175  SV *msv;
13176  const char *message;
13177
13178  PERL_ARGS_ASSERT_RE_CROAK2;
13179
13180  if (l1 > 510)
13181   l1 = 510;
13182  if (l1 + l2 > 510)
13183   l2 = 510 - l1;
13184  Copy(pat1, buf, l1 , char);
13185  Copy(pat2, buf + l1, l2 , char);
13186  buf[l1 + l2] = '\n';
13187  buf[l1 + l2 + 1] = '\0';
13188 #ifdef I_STDARG
13189  /* ANSI variant takes additional second argument */
13190  va_start(args, pat2);
13191 #else
13192  va_start(args);
13193 #endif
13194  msv = vmess(buf, &args);
13195  va_end(args);
13196  message = SvPV_const(msv,l1);
13197  if (l1 > 512)
13198   l1 = 512;
13199  Copy(message, buf, l1 , char);
13200  buf[l1-1] = '\0';   /* Overwrite \n */
13201  Perl_croak(aTHX_ "%s", buf);
13202 }
13203
13204 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
13205
13206 #ifndef PERL_IN_XSUB_RE
13207 void
13208 Perl_save_re_context(pTHX)
13209 {
13210  dVAR;
13211
13212  struct re_save_state *state;
13213
13214  SAVEVPTR(PL_curcop);
13215  SSGROW(SAVESTACK_ALLOC_FOR_RE_SAVE_STATE + 1);
13216
13217  state = (struct re_save_state *)(PL_savestack + PL_savestack_ix);
13218  PL_savestack_ix += SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
13219  SSPUSHUV(SAVEt_RE_STATE);
13220
13221  Copy(&PL_reg_state, state, 1, struct re_save_state);
13222
13223  PL_reg_start_tmp = 0;
13224  PL_reg_start_tmpl = 0;
13225  PL_reg_oldsaved = NULL;
13226  PL_reg_oldsavedlen = 0;
13227  PL_reg_maxiter = 0;
13228  PL_reg_leftiter = 0;
13229  PL_reg_poscache = NULL;
13230  PL_reg_poscache_size = 0;
13231 #ifdef PERL_OLD_COPY_ON_WRITE
13232  PL_nrs = NULL;
13233 #endif
13234
13235  /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
13236  if (PL_curpm) {
13237   const REGEXP * const rx = PM_GETRE(PL_curpm);
13238   if (rx) {
13239    U32 i;
13240    for (i = 1; i <= RX_NPARENS(rx); i++) {
13241     char digits[TYPE_CHARS(long)];
13242     const STRLEN len = my_snprintf(digits, sizeof(digits), "%lu", (long)i);
13243     GV *const *const gvp
13244      = (GV**)hv_fetch(PL_defstash, digits, len, 0);
13245
13246     if (gvp) {
13247      GV * const gv = *gvp;
13248      if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
13249       save_scalar(gv);
13250     }
13251    }
13252   }
13253  }
13254 }
13255 #endif
13256
13257 static void
13258 clear_re(pTHX_ void *r)
13259 {
13260  dVAR;
13261  ReREFCNT_dec((REGEXP *)r);
13262 }
13263
13264 #ifdef DEBUGGING
13265
13266 STATIC void
13267 S_put_byte(pTHX_ SV *sv, int c)
13268 {
13269  PERL_ARGS_ASSERT_PUT_BYTE;
13270
13271  /* Our definition of isPRINT() ignores locales, so only bytes that are
13272  not part of UTF-8 are considered printable. I assume that the same
13273  holds for UTF-EBCDIC.
13274  Also, code point 255 is not printable in either (it's E0 in EBCDIC,
13275  which Wikipedia says:
13276
13277  EO, or Eight Ones, is an 8-bit EBCDIC character code represented as all
13278  ones (binary 1111 1111, hexadecimal FF). It is similar, but not
13279  identical, to the ASCII delete (DEL) or rubout control character.
13280  ) So the old condition can be simplified to !isPRINT(c)  */
13281  if (!isPRINT(c)) {
13282   if (c < 256) {
13283    Perl_sv_catpvf(aTHX_ sv, "\\x%02x", c);
13284   }
13285   else {
13286    Perl_sv_catpvf(aTHX_ sv, "\\x{%x}", c);
13287   }
13288  }
13289  else {
13290   const char string = c;
13291   if (c == '-' || c == ']' || c == '\\' || c == '^')
13292    sv_catpvs(sv, "\\");
13293   sv_catpvn(sv, &string, 1);
13294  }
13295 }
13296
13297
13298 #define CLEAR_OPTSTART \
13299  if (optstart) STMT_START { \
13300    DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%"IVdf" nodes)\n", (IV)(node - optstart))); \
13301    optstart=NULL; \
13302  } STMT_END
13303
13304 #define DUMPUNTIL(b,e) CLEAR_OPTSTART; node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
13305
13306 STATIC const regnode *
13307 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
13308    const regnode *last, const regnode *plast,
13309    SV* sv, I32 indent, U32 depth)
13310 {
13311  dVAR;
13312  register U8 op = PSEUDO; /* Arbitrary non-END op. */
13313  register const regnode *next;
13314  const regnode *optstart= NULL;
13315
13316  RXi_GET_DECL(r,ri);
13317  GET_RE_DEBUG_FLAGS_DECL;
13318
13319  PERL_ARGS_ASSERT_DUMPUNTIL;
13320
13321 #ifdef DEBUG_DUMPUNTIL
13322  PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
13323   last ? last-start : 0,plast ? plast-start : 0);
13324 #endif
13325
13326  if (plast && plast < last)
13327   last= plast;
13328
13329  while (PL_regkind[op] != END && (!last || node < last)) {
13330   /* While that wasn't END last time... */
13331   NODE_ALIGN(node);
13332   op = OP(node);
13333   if (op == CLOSE || op == WHILEM)
13334    indent--;
13335   next = regnext((regnode *)node);
13336
13337   /* Where, what. */
13338   if (OP(node) == OPTIMIZED) {
13339    if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
13340     optstart = node;
13341    else
13342     goto after_print;
13343   } else
13344    CLEAR_OPTSTART;
13345
13346   regprop(r, sv, node);
13347   PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
13348      (int)(2*indent + 1), "", SvPVX_const(sv));
13349
13350   if (OP(node) != OPTIMIZED) {
13351    if (next == NULL)  /* Next ptr. */
13352     PerlIO_printf(Perl_debug_log, " (0)");
13353    else if (PL_regkind[(U8)op] == BRANCH && PL_regkind[OP(next)] != BRANCH )
13354     PerlIO_printf(Perl_debug_log, " (FAIL)");
13355    else
13356     PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start));
13357    (void)PerlIO_putc(Perl_debug_log, '\n');
13358   }
13359
13360  after_print:
13361   if (PL_regkind[(U8)op] == BRANCHJ) {
13362    assert(next);
13363    {
13364     register const regnode *nnode = (OP(next) == LONGJMP
13365            ? regnext((regnode *)next)
13366            : next);
13367     if (last && nnode > last)
13368      nnode = last;
13369     DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
13370    }
13371   }
13372   else if (PL_regkind[(U8)op] == BRANCH) {
13373    assert(next);
13374    DUMPUNTIL(NEXTOPER(node), next);
13375   }
13376   else if ( PL_regkind[(U8)op]  == TRIE ) {
13377    const regnode *this_trie = node;
13378    const char op = OP(node);
13379    const U32 n = ARG(node);
13380    const reg_ac_data * const ac = op>=AHOCORASICK ?
13381    (reg_ac_data *)ri->data->data[n] :
13382    NULL;
13383    const reg_trie_data * const trie =
13384     (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
13385 #ifdef DEBUGGING
13386    AV *const trie_words = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
13387 #endif
13388    const regnode *nextbranch= NULL;
13389    I32 word_idx;
13390    sv_setpvs(sv, "");
13391    for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
13392     SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
13393
13394     PerlIO_printf(Perl_debug_log, "%*s%s ",
13395     (int)(2*(indent+3)), "",
13396      elem_ptr ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60,
13397        PL_colors[0], PL_colors[1],
13398        (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) |
13399        PERL_PV_PRETTY_ELLIPSES    |
13400        PERL_PV_PRETTY_LTGT
13401        )
13402        : "???"
13403     );
13404     if (trie->jump) {
13405      U16 dist= trie->jump[word_idx+1];
13406      PerlIO_printf(Perl_debug_log, "(%"UVuf")\n",
13407         (UV)((dist ? this_trie + dist : next) - start));
13408      if (dist) {
13409       if (!nextbranch)
13410        nextbranch= this_trie + trie->jump[0];
13411       DUMPUNTIL(this_trie + dist, nextbranch);
13412      }
13413      if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
13414       nextbranch= regnext((regnode *)nextbranch);
13415     } else {
13416      PerlIO_printf(Perl_debug_log, "\n");
13417     }
13418    }
13419    if (last && next > last)
13420     node= last;
13421    else
13422     node= next;
13423   }
13424   else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
13425    DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
13426      NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
13427   }
13428   else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
13429    assert(next);
13430    DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
13431   }
13432   else if ( op == PLUS || op == STAR) {
13433    DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
13434   }
13435   else if (PL_regkind[(U8)op] == ANYOF) {
13436    /* arglen 1 + class block */
13437    node += 1 + ((ANYOF_FLAGS(node) & ANYOF_CLASS)
13438      ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
13439    node = NEXTOPER(node);
13440   }
13441   else if (PL_regkind[(U8)op] == EXACT) {
13442    /* Literal string, where present. */
13443    node += NODE_SZ_STR(node) - 1;
13444    node = NEXTOPER(node);
13445   }
13446   else {
13447    node = NEXTOPER(node);
13448    node += regarglen[(U8)op];
13449   }
13450   if (op == CURLYX || op == OPEN)
13451    indent++;
13452  }
13453  CLEAR_OPTSTART;
13454 #ifdef DEBUG_DUMPUNTIL
13455  PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent);
13456 #endif
13457  return node;
13458 }
13459
13460 #endif /* DEBUGGING */
13461
13462 /*
13463  * Local variables:
13464  * c-indentation-style: bsd
13465  * c-basic-offset: 4
13466  * indent-tabs-mode: t
13467  * End:
13468  *
13469  * ex: set ts=8 sts=4 sw=4 noet:
13470  */