regcomp.c

   1 /*    regcomp.c
   2  */
   3
   4 /*
   5  * "A fair jaw-cracker dwarf-language must be."  --Samwise Gamgee
   6  */
   7
   8 /* This file contains functions for compiling a regular expression.  See
   9  * also regexec.c which funnily enough, contains functions for executing
  10  * a regular expression.
  11  *
  12  * This file is also copied at build time to ext/re/re_comp.c, where
  13  * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
  14  * This causes the main functions to be compiled under new names and with
  15  * debugging support added, which makes "use re 'debug'" work.
  16  */
  17
  18 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
  19  * confused with the original package (see point 3 below).  Thanks, Henry!
  20  */
  21
  22 /* Additional note: this code is very heavily munged from Henry's version
  23  * in places.  In some spots I've traded clarity for efficiency, so don't
  24  * blame Henry for some of the lack of readability.
  25  */
  26
  27 /* The names of the functions have been changed from regcomp and
  28  * regexec to  pregcomp and pregexec in order to avoid conflicts
  29  * with the POSIX routines of the same names.
  30 */
  31
  32 #ifdef PERL_EXT_RE_BUILD
  33 #include "re_top.h"
  34 #endif
  35
  36 /*
  37  * pregcomp and pregexec -- regsub and regerror are not used in perl
  38  *
  39  *      Copyright (c) 1986 by University of Toronto.
  40  *      Written by Henry Spencer.  Not derived from licensed software.
  41  *
  42  *      Permission is granted to anyone to use this software for any
  43  *      purpose on any computer system, and to redistribute it freely,
  44  *      subject to the following restrictions:
  45  *
  46  *      1. The author is not responsible for the consequences of use of
  47  *              this software, no matter how awful, even if they arise
  48  *              from defects in it.
  49  *
  50  *      2. The origin of this software must not be misrepresented, either
  51  *              by explicit claim or by omission.
  52  *
  53  *      3. Altered versions must be plainly marked as such, and must not
  54  *              be misrepresented as being the original software.
  55  *
  56  *
  57  ****    Alterations to Henry's code are...
  58  ****
  59  ****    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
  60  ****    2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
  61  ****
  62  ****    You may distribute under the terms of either the GNU General Public
  63  ****    License or the Artistic License, as specified in the README file.
  64
  65  *
  66  * Beware that some of this code is subtly aware of the way operator
  67  * precedence is structured in regular expressions.  Serious changes in
  68  * regular-expression syntax might require a total rethink.
  69  */
  70 #include "EXTERN.h"
  71 #define PERL_IN_REGCOMP_C
  72 #include "perl.h"
  73
  74 #ifndef PERL_IN_XSUB_RE
  75 #  include "INTERN.h"
  76 #endif
  77
  78 #define REG_COMP_C
  79 #ifdef PERL_IN_XSUB_RE
  80 #  include "re_comp.h"
  81 #else
  82 #  include "regcomp.h"
  83 #endif
  84
  85 #ifdef op
  86 #undef op
  87 #endif /* op */
  88
  89 #ifdef MSDOS
  90 #  if defined(BUGGY_MSC6)
  91  /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
  92 #    pragma optimize("a",off)
  93  /* But MSC 6.00A is happy with 'w', for aliases only across function calls*/
  94 #    pragma optimize("w",on )
  95 #  endif /* BUGGY_MSC6 */
  96 #endif /* MSDOS */
  97
  98 #ifndef STATIC
  99 #define STATIC  static
 100 #endif
 101
 102 typedef struct RExC_state_t {
 103     U32         flags;                  /* are we folding, multilining? */
 104     char        *precomp;               /* uncompiled string. */
 105     regexp      *rx;                    /* perl core regexp structure */
 106     regexp_internal     *rxi;           /* internal data for regexp object pprivate field */
 107     char        *start;                 /* Start of input for compile */
 108     char        *end;                   /* End of input for compile */
 109     char        *parse;                 /* Input-scan pointer. */
 110     I32         whilem_seen;            /* number of WHILEM in this expr */
 111     regnode     *emit_start;            /* Start of emitted-code area */
 112     regnode     *emit;                  /* Code-emit pointer; &regdummy = don't = compiling */
 113     I32         naughty;                /* How bad is this pattern? */
 114     I32         sawback;                /* Did we see \1, ...? */
 115     U32         seen;
 116     I32         size;                   /* Code size. */
 117     I32         npar;                   /* Capture buffer count, (OPEN). */
 118     I32         cpar;                   /* Capture buffer count, (CLOSE). */
 119     I32         nestroot;               /* root parens we are in - used by accept */
 120     I32         extralen;
 121     I32         seen_zerolen;
 122     I32         seen_evals;
 123     regnode     **open_parens;          /* pointers to open parens */
 124     regnode     **close_parens;         /* pointers to close parens */
 125     regnode     *opend;                 /* END node in program */
 126     I32         utf8;
 127     HV          *charnames;             /* cache of named sequences */
 128     HV          *paren_names;           /* Paren names */
 129     regnode     **recurse;              /* Recurse regops */
 130     I32         recurse_count;          /* Number of recurse regops */
 131 #if ADD_TO_REGEXEC
 132     char        *starttry;              /* -Dr: where regtry was called. */
 133 #define RExC_starttry   (pRExC_state->starttry)
 134 #endif
 135 #ifdef DEBUGGING
 136     const char  *lastparse;
 137     I32         lastnum;
 138 #define RExC_lastparse  (pRExC_state->lastparse)
 139 #define RExC_lastnum    (pRExC_state->lastnum)
 140 #endif
 141 } RExC_state_t;
 142
 143 #define RExC_flags      (pRExC_state->flags)
 144 #define RExC_precomp    (pRExC_state->precomp)
 145 #define RExC_rx         (pRExC_state->rx)
 146 #define RExC_rxi        (pRExC_state->rxi)
 147 #define RExC_start      (pRExC_state->start)
 148 #define RExC_end        (pRExC_state->end)
 149 #define RExC_parse      (pRExC_state->parse)
 150 #define RExC_whilem_seen        (pRExC_state->whilem_seen)
 151 #define RExC_offsets    (pRExC_state->rxi->offsets) /* I am not like the others */
 152 #define RExC_emit       (pRExC_state->emit)
 153 #define RExC_emit_start (pRExC_state->emit_start)
 154 #define RExC_naughty    (pRExC_state->naughty)
 155 #define RExC_sawback    (pRExC_state->sawback)
 156 #define RExC_seen       (pRExC_state->seen)
 157 #define RExC_size       (pRExC_state->size)
 158 #define RExC_npar       (pRExC_state->npar)
 159 #define RExC_cpar       (pRExC_state->cpar)
 160 #define RExC_nestroot   (pRExC_state->nestroot)
 161 #define RExC_extralen   (pRExC_state->extralen)
 162 #define RExC_seen_zerolen       (pRExC_state->seen_zerolen)
 163 #define RExC_seen_evals (pRExC_state->seen_evals)
 164 #define RExC_utf8       (pRExC_state->utf8)
 165 #define RExC_charnames  (pRExC_state->charnames)
 166 #define RExC_open_parens        (pRExC_state->open_parens)
 167 #define RExC_close_parens       (pRExC_state->close_parens)
 168 #define RExC_opend      (pRExC_state->opend)
 169 #define RExC_paren_names        (pRExC_state->paren_names)
 170 #define RExC_recurse    (pRExC_state->recurse)
 171 #define RExC_recurse_count      (pRExC_state->recurse_count)
 172
 173 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
 174 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
 175         ((*s) == '{' && regcurly(s)))
 176
 177 #ifdef SPSTART
 178 #undef SPSTART          /* dratted cpp namespace... */
 179 #endif
 180 /*
 181  * Flags to be passed up and down.
 182  */
 183 #define WORST           0       /* Worst case. */
 184 #define HASWIDTH        0x1     /* Known to match non-null strings. */
 185 #define SIMPLE          0x2     /* Simple enough to be STAR/PLUS operand. */
 186 #define SPSTART         0x4     /* Starts with * or +. */
 187 #define TRYAGAIN        0x8     /* Weeded out a declaration. */
 188
 189 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
 190
 191 /* whether trie related optimizations are enabled */
 192 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
 193 #define TRIE_STUDY_OPT
 194 #define FULL_TRIE_STUDY
 195 #define TRIE_STCLASS
 196 #endif
 197
 198
 199
 200 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
 201 #define PBITVAL(paren) (1 << ((paren) & 7))
 202 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
 203 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
 204 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
 205
 206
 207 /* About scan_data_t.
 208
 209   During optimisation we recurse through the regexp program performing
 210   various inplace (keyhole style) optimisations. In addition study_chunk
 211   and scan_commit populate this data structure with information about
 212   what strings MUST appear in the pattern. We look for the longest
 213   string that must appear for at a fixed location, and we look for the
 214   longest string that may appear at a floating location. So for instance
 215   in the pattern:
 216
 217     /FOO[xX]A.*B[xX]BAR/
 218
 219   Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
 220   strings (because they follow a .* construct). study_chunk will identify
 221   both FOO and BAR as being the longest fixed and floating strings respectively.
 222
 223   The strings can be composites, for instance
 224
 225      /(f)(o)(o)/
 226
 227   will result in a composite fixed substring 'foo'.
 228
 229   For each string some basic information is maintained:
 230
 231   - offset or min_offset
 232     This is the position the string must appear at, or not before.
 233     It also implicitly (when combined with minlenp) tells us how many
 234     character must match before the string we are searching.
 235     Likewise when combined with minlenp and the length of the string
 236     tells us how many characters must appear after the string we have
 237     found.
 238
 239   - max_offset
 240     Only used for floating strings. This is the rightmost point that
 241     the string can appear at. Ifset to I32 max it indicates that the
 242     string can occur infinitely far to the right.
 243
 244   - minlenp
 245     A pointer to the minimum length of the pattern that the string
 246     was found inside. This is important as in the case of positive
 247     lookahead or positive lookbehind we can have multiple patterns
 248     involved. Consider
 249
 250     /(?=FOO).*F/
 251
 252     The minimum length of the pattern overall is 3, the minimum length
 253     of the lookahead part is 3, but the minimum length of the part that
 254     will actually match is 1. So 'FOO's minimum length is 3, but the
 255     minimum length for the F is 1. This is important as the minimum length
 256     is used to determine offsets in front of and behind the string being
 257     looked for.  Since strings can be composites this is the length of the
 258     pattern at the time it was commited with a scan_commit. Note that
 259     the length is calculated by study_chunk, so that the minimum lengths
 260     are not known until the full pattern has been compiled, thus the
 261     pointer to the value.
 262
 263   - lookbehind
 264
 265     In the case of lookbehind the string being searched for can be
 266     offset past the start point of the final matching string.
 267     If this value was just blithely removed from the min_offset it would
 268     invalidate some of the calculations for how many chars must match
 269     before or after (as they are derived from min_offset and minlen and
 270     the length of the string being searched for).
 271     When the final pattern is compiled and the data is moved from the
 272     scan_data_t structure into the regexp structure the information
 273     about lookbehind is factored in, with the information that would
 274     have been lost precalculated in the end_shift field for the
 275     associated string.
 276
 277   The fields pos_min and pos_delta are used to store the minimum offset
 278   and the delta to the maximum offset at the current point in the pattern.
 279
 280 */
 281
 282 typedef struct scan_data_t {
 283     /*I32 len_min;      unused */
 284     /*I32 len_delta;    unused */
 285     I32 pos_min;
 286     I32 pos_delta;
 287     SV *last_found;
 288     I32 last_end;           /* min value, <0 unless valid. */
 289     I32 last_start_min;
 290     I32 last_start_max;
 291     SV **longest;           /* Either &l_fixed, or &l_float. */
 292     SV *longest_fixed;      /* longest fixed string found in pattern */
 293     I32 offset_fixed;       /* offset where it starts */
 294     I32 *minlen_fixed;      /* pointer to the minlen relevent to the string */
 295     I32 lookbehind_fixed;   /* is the position of the string modfied by LB */
 296     SV *longest_float;      /* longest floating string found in pattern */
 297     I32 offset_float_min;   /* earliest point in string it can appear */
 298     I32 offset_float_max;   /* latest point in string it can appear */
 299     I32 *minlen_float;      /* pointer to the minlen relevent to the string */
 300     I32 lookbehind_float;   /* is the position of the string modified by LB */
 301     I32 flags;
 302     I32 whilem_c;
 303     I32 *last_closep;
 304     struct regnode_charclass_class *start_class;
 305 } scan_data_t;
 306
 307 /*
 308  * Forward declarations for pregcomp()'s friends.
 309  */
 310
 311 static const scan_data_t zero_scan_data =
 312   { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,0};
 313
 314 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
 315 #define SF_BEFORE_SEOL          0x0001
 316 #define SF_BEFORE_MEOL          0x0002
 317 #define SF_FIX_BEFORE_EOL       (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
 318 #define SF_FL_BEFORE_EOL        (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
 319
 320 #ifdef NO_UNARY_PLUS
 321 #  define SF_FIX_SHIFT_EOL      (0+2)
 322 #  define SF_FL_SHIFT_EOL               (0+4)
 323 #else
 324 #  define SF_FIX_SHIFT_EOL      (+2)
 325 #  define SF_FL_SHIFT_EOL               (+4)
 326 #endif
 327
 328 #define SF_FIX_BEFORE_SEOL      (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
 329 #define SF_FIX_BEFORE_MEOL      (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
 330
 331 #define SF_FL_BEFORE_SEOL       (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
 332 #define SF_FL_BEFORE_MEOL       (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
 333 #define SF_IS_INF               0x0040
 334 #define SF_HAS_PAR              0x0080
 335 #define SF_IN_PAR               0x0100
 336 #define SF_HAS_EVAL             0x0200
 337 #define SCF_DO_SUBSTR           0x0400
 338 #define SCF_DO_STCLASS_AND      0x0800
 339 #define SCF_DO_STCLASS_OR       0x1000
 340 #define SCF_DO_STCLASS          (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
 341 #define SCF_WHILEM_VISITED_POS  0x2000
 342
 343 #define SCF_TRIE_RESTUDY        0x4000 /* Do restudy? */
 344 #define SCF_SEEN_ACCEPT         0x8000
 345
 346 #define UTF (RExC_utf8 != 0)
 347 #define LOC ((RExC_flags & RXf_PMf_LOCALE) != 0)
 348 #define FOLD ((RExC_flags & RXf_PMf_FOLD) != 0)
 349
 350 #define OOB_UNICODE             12345678
 351 #define OOB_NAMEDCLASS          -1
 352
 353 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
 354 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
 355
 356
 357 /* length of regex to show in messages that don't mark a position within */
 358 #define RegexLengthToShowInErrorMessages 127
 359
 360 /*
 361  * If MARKER[12] are adjusted, be sure to adjust the constants at the top
 362  * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
 363  * op/pragma/warn/regcomp.
 364  */
 365 #define MARKER1 "<-- HERE"    /* marker as it appears in the description */
 366 #define MARKER2 " <-- HERE "  /* marker as it appears within the regex */
 367
 368 #define REPORT_LOCATION " in regex; marked by " MARKER1 " in m/%.*s" MARKER2 "%s/"
 369
 370 /*
 371  * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
 372  * arg. Show regex, up to a maximum length. If it's too long, chop and add
 373  * "...".
 374  */
 375 #define _FAIL(code) STMT_START {                                        \
 376     const char *ellipses = "";                                          \
 377     IV len = RExC_end - RExC_precomp;                                   \
 378                                                                         \
 379     if (!SIZE_ONLY)                                                     \
 380         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx);                      \
 381     if (len > RegexLengthToShowInErrorMessages) {                       \
 382         /* chop 10 shorter than the max, to ensure meaning of "..." */  \
 383         len = RegexLengthToShowInErrorMessages - 10;                    \
 384         ellipses = "...";                                               \
 385     }                                                                   \
 386     code;                                                               \
 387 } STMT_END
 388
 389 #define FAIL(msg) _FAIL(                            \
 390     Perl_croak(aTHX_ "%s in regex m/%.*s%s/",       \
 391             msg, (int)len, RExC_precomp, ellipses))
 392
 393 #define FAIL2(msg,arg) _FAIL(                       \
 394     Perl_croak(aTHX_ msg " in regex m/%.*s%s/",     \
 395             arg, (int)len, RExC_precomp, ellipses))
 396
 397 /*
 398  * Simple_vFAIL -- like FAIL, but marks the current location in the scan
 399  */
 400 #define Simple_vFAIL(m) STMT_START {                                    \
 401     const IV offset = RExC_parse - RExC_precomp;                        \
 402     Perl_croak(aTHX_ "%s" REPORT_LOCATION,                              \
 403             m, (int)offset, RExC_precomp, RExC_precomp + offset);       \
 404 } STMT_END
 405
 406 /*
 407  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
 408  */
 409 #define vFAIL(m) STMT_START {                           \
 410     if (!SIZE_ONLY)                                     \
 411         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx);      \
 412     Simple_vFAIL(m);                                    \
 413 } STMT_END
 414
 415 /*
 416  * Like Simple_vFAIL(), but accepts two arguments.
 417  */
 418 #define Simple_vFAIL2(m,a1) STMT_START {                        \
 419     const IV offset = RExC_parse - RExC_precomp;                        \
 420     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1,                   \
 421             (int)offset, RExC_precomp, RExC_precomp + offset);  \
 422 } STMT_END
 423
 424 /*
 425  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
 426  */
 427 #define vFAIL2(m,a1) STMT_START {                       \
 428     if (!SIZE_ONLY)                                     \
 429         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx);      \
 430     Simple_vFAIL2(m, a1);                               \
 431 } STMT_END
 432
 433
 434 /*
 435  * Like Simple_vFAIL(), but accepts three arguments.
 436  */
 437 #define Simple_vFAIL3(m, a1, a2) STMT_START {                   \
 438     const IV offset = RExC_parse - RExC_precomp;                \
 439     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2,               \
 440             (int)offset, RExC_precomp, RExC_precomp + offset);  \
 441 } STMT_END
 442
 443 /*
 444  * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
 445  */
 446 #define vFAIL3(m,a1,a2) STMT_START {                    \
 447     if (!SIZE_ONLY)                                     \
 448         SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx);      \
 449     Simple_vFAIL3(m, a1, a2);                           \
 450 } STMT_END
 451
 452 /*
 453  * Like Simple_vFAIL(), but accepts four arguments.
 454  */
 455 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START {               \
 456     const IV offset = RExC_parse - RExC_precomp;                \
 457     S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3,           \
 458             (int)offset, RExC_precomp, RExC_precomp + offset);  \
 459 } STMT_END
 460
 461 #define vWARN(loc,m) STMT_START {                                       \
 462     const IV offset = loc - RExC_precomp;                               \
 463     Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s" REPORT_LOCATION,      \
 464             m, (int)offset, RExC_precomp, RExC_precomp + offset);       \
 465 } STMT_END
 466
 467 #define vWARNdep(loc,m) STMT_START {                                    \
 468     const IV offset = loc - RExC_precomp;                               \
 469     Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP),          \
 470             "%s" REPORT_LOCATION,                                       \
 471             m, (int)offset, RExC_precomp, RExC_precomp + offset);       \
 472 } STMT_END
 473
 474
 475 #define vWARN2(loc, m, a1) STMT_START {                                 \
 476     const IV offset = loc - RExC_precomp;                               \
 477     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
 478             a1, (int)offset, RExC_precomp, RExC_precomp + offset);      \
 479 } STMT_END
 480
 481 #define vWARN3(loc, m, a1, a2) STMT_START {                             \
 482     const IV offset = loc - RExC_precomp;                               \
 483     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
 484             a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset);  \
 485 } STMT_END
 486
 487 #define vWARN4(loc, m, a1, a2, a3) STMT_START {                         \
 488     const IV offset = loc - RExC_precomp;                               \
 489     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
 490             a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
 491 } STMT_END
 492
 493 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START {                     \
 494     const IV offset = loc - RExC_precomp;                               \
 495     Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION,         \
 496             a1, a2, a3, a4, (int)offset, RExC_precomp, RExC_precomp + offset); \
 497 } STMT_END
 498
 499
 500 /* Allow for side effects in s */
 501 #define REGC(c,s) STMT_START {                  \
 502     if (!SIZE_ONLY) *(s) = (c); else (void)(s); \
 503 } STMT_END
 504
 505 /* Macros for recording node offsets.   20001227 mjd@plover.com
 506  * Nodes are numbered 1, 2, 3, 4.  Node #n's position is recorded in
 507  * element 2*n-1 of the array.  Element #2n holds the byte length node #n.
 508  * Element 0 holds the number n.
 509  * Position is 1 indexed.
 510  */
 511
 512 #define Set_Node_Offset_To_R(node,byte) STMT_START {                    \
 513     if (! SIZE_ONLY) {                                                  \
 514         MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n",         \
 515                     __LINE__, (int)(node), (int)(byte)));               \
 516         if((node) < 0) {                                                \
 517             Perl_croak(aTHX_ "value of node is %d in Offset macro", (int)(node)); \
 518         } else {                                                        \
 519             RExC_offsets[2*(node)-1] = (byte);                          \
 520         }                                                               \
 521     }                                                                   \
 522 } STMT_END
 523
 524 #define Set_Node_Offset(node,byte) \
 525     Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
 526 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
 527
 528 #define Set_Node_Length_To_R(node,len) STMT_START {                     \
 529     if (! SIZE_ONLY) {                                                  \
 530         MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n",           \
 531                 __LINE__, (int)(node), (int)(len)));                    \
 532         if((node) < 0) {                                                \
 533             Perl_croak(aTHX_ "value of node is %d in Length macro", (int)(node)); \
 534         } else {                                                        \
 535             RExC_offsets[2*(node)] = (len);                             \
 536         }                                                               \
 537     }                                                                   \
 538 } STMT_END
 539
 540 #define Set_Node_Length(node,len) \
 541     Set_Node_Length_To_R((node)-RExC_emit_start, len)
 542 #define Set_Cur_Node_Length(len) Set_Node_Length(RExC_emit, len)
 543 #define Set_Node_Cur_Length(node) \
 544     Set_Node_Length(node, RExC_parse - parse_start)
 545
 546 /* Get offsets and lengths */
 547 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
 548 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
 549
 550 #define Set_Node_Offset_Length(node,offset,len) STMT_START {    \
 551     Set_Node_Offset_To_R((node)-RExC_emit_start, (offset));     \
 552     Set_Node_Length_To_R((node)-RExC_emit_start, (len));        \
 553 } STMT_END
 554
 555
 556 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
 557 #define EXPERIMENTAL_INPLACESCAN
 558 #endif
 559
 560 #define DEBUG_STUDYDATA(data,depth)                                  \
 561 DEBUG_OPTIMISE_MORE_r(if(data){                                           \
 562     PerlIO_printf(Perl_debug_log,                                    \
 563         "%*s"/* Len:%"IVdf"/%"IVdf" */"Pos:%"IVdf"/%"IVdf           \
 564         " Flags: %"IVdf" Whilem_c: %"IVdf" Lcp: %"IVdf" ",           \
 565         (int)(depth)*2, "",                                          \
 566         (IV)((data)->pos_min),                                       \
 567         (IV)((data)->pos_delta),                                     \
 568         (IV)((data)->flags),                                         \
 569         (IV)((data)->whilem_c),                                      \
 570         (IV)((data)->last_closep ? *((data)->last_closep) : -1)      \
 571     );                                                               \
 572     if ((data)->last_found)                                          \
 573         PerlIO_printf(Perl_debug_log,                                \
 574             "Last:'%s' %"IVdf":%"IVdf"/%"IVdf" %sFixed:'%s' @ %"IVdf \
 575             " %sFloat: '%s' @ %"IVdf"/%"IVdf"",                      \
 576             SvPVX_const((data)->last_found),                         \
 577             (IV)((data)->last_end),                                  \
 578             (IV)((data)->last_start_min),                            \
 579             (IV)((data)->last_start_max),                            \
 580             ((data)->longest &&                                      \
 581              (data)->longest==&((data)->longest_fixed)) ? "*" : "",  \
 582             SvPVX_const((data)->longest_fixed),                      \
 583             (IV)((data)->offset_fixed),                              \
 584             ((data)->longest &&                                      \
 585              (data)->longest==&((data)->longest_float)) ? "*" : "",  \
 586             SvPVX_const((data)->longest_float),                      \
 587             (IV)((data)->offset_float_min),                          \
 588             (IV)((data)->offset_float_max)                           \
 589         );                                                           \
 590     PerlIO_printf(Perl_debug_log,"\n");                              \
 591 });
 592
 593 static void clear_re(pTHX_ void *r);
 594
 595 /* Mark that we cannot extend a found fixed substring at this point.
 596    Update the longest found anchored substring and the longest found
 597    floating substrings if needed. */
 598
 599 STATIC void
 600 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, I32 *minlenp)
 601 {
 602     const STRLEN l = CHR_SVLEN(data->last_found);
 603     const STRLEN old_l = CHR_SVLEN(*data->longest);
 604     GET_RE_DEBUG_FLAGS_DECL;
 605
 606     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
 607         SvSetMagicSV(*data->longest, data->last_found);
 608         if (*data->longest == data->longest_fixed) {
 609             data->offset_fixed = l ? data->last_start_min : data->pos_min;
 610             if (data->flags & SF_BEFORE_EOL)
 611                 data->flags
 612                     |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
 613             else
 614                 data->flags &= ~SF_FIX_BEFORE_EOL;
 615             data->minlen_fixed=minlenp;
 616             data->lookbehind_fixed=0;
 617         }
 618         else {
 619             data->offset_float_min = l ? data->last_start_min : data->pos_min;
 620             data->offset_float_max = (l
 621                                       ? data->last_start_max
 622                                       : data->pos_min + data->pos_delta);
 623             if ((U32)data->offset_float_max > (U32)I32_MAX)
 624                 data->offset_float_max = I32_MAX;
 625             if (data->flags & SF_BEFORE_EOL)
 626                 data->flags
 627                     |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
 628             else
 629                 data->flags &= ~SF_FL_BEFORE_EOL;
 630             data->minlen_float=minlenp;
 631             data->lookbehind_float=0;
 632         }
 633     }
 634     SvCUR_set(data->last_found, 0);
 635     {
 636         SV * const sv = data->last_found;
 637         if (SvUTF8(sv) && SvMAGICAL(sv)) {
 638             MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
 639             if (mg)
 640                 mg->mg_len = 0;
 641         }
 642     }
 643     data->last_end = -1;
 644     data->flags &= ~SF_BEFORE_EOL;
 645     DEBUG_STUDYDATA(data,0);
 646 }
 647
 648 /* Can match anything (initialization) */
 649 STATIC void
 650 S_cl_anything(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
 651 {
 652     ANYOF_CLASS_ZERO(cl);
 653     ANYOF_BITMAP_SETALL(cl);
 654     cl->flags = ANYOF_EOS|ANYOF_UNICODE_ALL;
 655     if (LOC)
 656         cl->flags |= ANYOF_LOCALE;
 657 }
 658
 659 /* Can match anything (initialization) */
 660 STATIC int
 661 S_cl_is_anything(const struct regnode_charclass_class *cl)
 662 {
 663     int value;
 664
 665     for (value = 0; value <= ANYOF_MAX; value += 2)
 666         if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
 667             return 1;
 668     if (!(cl->flags & ANYOF_UNICODE_ALL))
 669         return 0;
 670     if (!ANYOF_BITMAP_TESTALLSET((const void*)cl))
 671         return 0;
 672     return 1;
 673 }
 674
 675 /* Can match anything (initialization) */
 676 STATIC void
 677 S_cl_init(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
 678 {
 679     Zero(cl, 1, struct regnode_charclass_class);
 680     cl->type = ANYOF;
 681     cl_anything(pRExC_state, cl);
 682 }
 683
 684 STATIC void
 685 S_cl_init_zero(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
 686 {
 687     Zero(cl, 1, struct regnode_charclass_class);
 688     cl->type = ANYOF;
 689     cl_anything(pRExC_state, cl);
 690     if (LOC)
 691         cl->flags |= ANYOF_LOCALE;
 692 }
 693
 694 /* 'And' a given class with another one.  Can create false positives */
 695 /* We assume that cl is not inverted */
 696 STATIC void
 697 S_cl_and(struct regnode_charclass_class *cl,
 698         const struct regnode_charclass_class *and_with)
 699 {
 700
 701     assert(and_with->type == ANYOF);
 702     if (!(and_with->flags & ANYOF_CLASS)
 703         && !(cl->flags & ANYOF_CLASS)
 704         && (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
 705         && !(and_with->flags & ANYOF_FOLD)
 706         && !(cl->flags & ANYOF_FOLD)) {
 707         int i;
 708
 709         if (and_with->flags & ANYOF_INVERT)
 710             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
 711                 cl->bitmap[i] &= ~and_with->bitmap[i];
 712         else
 713             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
 714                 cl->bitmap[i] &= and_with->bitmap[i];
 715     } /* XXXX: logic is complicated otherwise, leave it along for a moment. */
 716     if (!(and_with->flags & ANYOF_EOS))
 717         cl->flags &= ~ANYOF_EOS;
 718
 719     if (cl->flags & ANYOF_UNICODE_ALL && and_with->flags & ANYOF_UNICODE &&
 720         !(and_with->flags & ANYOF_INVERT)) {
 721         cl->flags &= ~ANYOF_UNICODE_ALL;
 722         cl->flags |= ANYOF_UNICODE;
 723         ARG_SET(cl, ARG(and_with));
 724     }
 725     if (!(and_with->flags & ANYOF_UNICODE_ALL) &&
 726         !(and_with->flags & ANYOF_INVERT))
 727         cl->flags &= ~ANYOF_UNICODE_ALL;
 728     if (!(and_with->flags & (ANYOF_UNICODE|ANYOF_UNICODE_ALL)) &&
 729         !(and_with->flags & ANYOF_INVERT))
 730         cl->flags &= ~ANYOF_UNICODE;
 731 }
 732
 733 /* 'OR' a given class with another one.  Can create false positives */
 734 /* We assume that cl is not inverted */
 735 STATIC void
 736 S_cl_or(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, const struct regnode_charclass_class *or_with)
 737 {
 738     if (or_with->flags & ANYOF_INVERT) {
 739         /* We do not use
 740          * (B1 | CL1) | (!B2 & !CL2) = (B1 | !B2 & !CL2) | (CL1 | (!B2 & !CL2))
 741          *   <= (B1 | !B2) | (CL1 | !CL2)
 742          * which is wasteful if CL2 is small, but we ignore CL2:
 743          *   (B1 | CL1) | (!B2 & !CL2) <= (B1 | CL1) | !B2 = (B1 | !B2) | CL1
 744          * XXXX Can we handle case-fold?  Unclear:
 745          *   (OK1(i) | OK1(i')) | !(OK1(i) | OK1(i')) =
 746          *   (OK1(i) | OK1(i')) | (!OK1(i) & !OK1(i'))
 747          */
 748         if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
 749              && !(or_with->flags & ANYOF_FOLD)
 750              && !(cl->flags & ANYOF_FOLD) ) {
 751             int i;
 752
 753             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
 754                 cl->bitmap[i] |= ~or_with->bitmap[i];
 755         } /* XXXX: logic is complicated otherwise */
 756         else {
 757             cl_anything(pRExC_state, cl);
 758         }
 759     } else {
 760         /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
 761         if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
 762              && (!(or_with->flags & ANYOF_FOLD)
 763                  || (cl->flags & ANYOF_FOLD)) ) {
 764             int i;
 765
 766             /* OR char bitmap and class bitmap separately */
 767             for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
 768                 cl->bitmap[i] |= or_with->bitmap[i];
 769             if (or_with->flags & ANYOF_CLASS) {
 770                 for (i = 0; i < ANYOF_CLASSBITMAP_SIZE; i++)
 771                     cl->classflags[i] |= or_with->classflags[i];
 772                 cl->flags |= ANYOF_CLASS;
 773             }
 774         }
 775         else { /* XXXX: logic is complicated, leave it along for a moment. */
 776             cl_anything(pRExC_state, cl);
 777         }
 778     }
 779     if (or_with->flags & ANYOF_EOS)
 780         cl->flags |= ANYOF_EOS;
 781
 782     if (cl->flags & ANYOF_UNICODE && or_with->flags & ANYOF_UNICODE &&
 783         ARG(cl) != ARG(or_with)) {
 784         cl->flags |= ANYOF_UNICODE_ALL;
 785         cl->flags &= ~ANYOF_UNICODE;
 786     }
 787     if (or_with->flags & ANYOF_UNICODE_ALL) {
 788         cl->flags |= ANYOF_UNICODE_ALL;
 789         cl->flags &= ~ANYOF_UNICODE;
 790     }
 791 }
 792
 793 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
 794 #define TRIE_LIST_CUR(state)  ( TRIE_LIST_ITEM( state, 0 ).forid )
 795 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
 796 #define TRIE_LIST_USED(idx)  ( trie->states[state].trans.list ? (TRIE_LIST_CUR( idx ) - 1) : 0 )
 797
 798
 799 #ifdef DEBUGGING
 800 /*
 801    dump_trie(trie)
 802    dump_trie_interim_list(trie,next_alloc)
 803    dump_trie_interim_table(trie,next_alloc)
 804
 805    These routines dump out a trie in a somewhat readable format.
 806    The _interim_ variants are used for debugging the interim
 807    tables that are used to generate the final compressed
 808    representation which is what dump_trie expects.
 809
 810    Part of the reason for their existance is to provide a form
 811    of documentation as to how the different representations function.
 812
 813 */
 814
 815 /*
 816   dump_trie(trie)
 817   Dumps the final compressed table form of the trie to Perl_debug_log.
 818   Used for debugging make_trie().
 819 */
 820
 821 STATIC void
 822 S_dump_trie(pTHX_ const struct _reg_trie_data *trie,U32 depth)
 823 {
 824     U32 state;
 825     SV *sv=sv_newmortal();
 826     int colwidth= trie->widecharmap ? 6 : 4;
 827     GET_RE_DEBUG_FLAGS_DECL;
 828
 829
 830     PerlIO_printf( Perl_debug_log, "%*sChar : %-6s%-6s%-4s ",
 831         (int)depth * 2 + 2,"",
 832         "Match","Base","Ofs" );
 833
 834     for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
 835         SV ** const tmp = av_fetch( trie->revcharmap, state, 0);
 836         if ( tmp ) {
 837             PerlIO_printf( Perl_debug_log, "%*s",
 838                 colwidth,
 839                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
 840                             PL_colors[0], PL_colors[1],
 841                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
 842                             PERL_PV_ESCAPE_FIRSTCHAR
 843                 )
 844             );
 845         }
 846     }
 847     PerlIO_printf( Perl_debug_log, "\n%*sState|-----------------------",
 848         (int)depth * 2 + 2,"");
 849
 850     for( state = 0 ; state < trie->uniquecharcount ; state++ )
 851         PerlIO_printf( Perl_debug_log, "%.*s", colwidth, "--------");
 852     PerlIO_printf( Perl_debug_log, "\n");
 853
 854     for( state = 1 ; state < trie->statecount ; state++ ) {
 855         const U32 base = trie->states[ state ].trans.base;
 856
 857         PerlIO_printf( Perl_debug_log, "%*s#%4"UVXf"|", (int)depth * 2 + 2,"", (UV)state);
 858
 859         if ( trie->states[ state ].wordnum ) {
 860             PerlIO_printf( Perl_debug_log, " W%4X", trie->states[ state ].wordnum );
 861         } else {
 862             PerlIO_printf( Perl_debug_log, "%6s", "" );
 863         }
 864
 865         PerlIO_printf( Perl_debug_log, " @%4"UVXf" ", (UV)base );
 866
 867         if ( base ) {
 868             U32 ofs = 0;
 869
 870             while( ( base + ofs  < trie->uniquecharcount ) ||
 871                    ( base + ofs - trie->uniquecharcount < trie->lasttrans
 872                      && trie->trans[ base + ofs - trie->uniquecharcount ].check != state))
 873                     ofs++;
 874
 875             PerlIO_printf( Perl_debug_log, "+%2"UVXf"[ ", (UV)ofs);
 876
 877             for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
 878                 if ( ( base + ofs >= trie->uniquecharcount ) &&
 879                      ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
 880                      trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
 881                 {
 882                    PerlIO_printf( Perl_debug_log, "%*"UVXf,
 883                     colwidth,
 884                     (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next );
 885                 } else {
 886                     PerlIO_printf( Perl_debug_log, "%*s",colwidth,"   ." );
 887                 }
 888             }
 889
 890             PerlIO_printf( Perl_debug_log, "]");
 891
 892         }
 893         PerlIO_printf( Perl_debug_log, "\n" );
 894     }
 895 }
 896 /*
 897   dump_trie_interim_list(trie,next_alloc)
 898   Dumps a fully constructed but uncompressed trie in list form.
 899   List tries normally only are used for construction when the number of
 900   possible chars (trie->uniquecharcount) is very high.
 901   Used for debugging make_trie().
 902 */
 903 STATIC void
 904 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie, U32 next_alloc,U32 depth)
 905 {
 906     U32 state;
 907     SV *sv=sv_newmortal();
 908     int colwidth= trie->widecharmap ? 6 : 4;
 909     GET_RE_DEBUG_FLAGS_DECL;
 910     /* print out the table precompression.  */
 911     PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s%s",
 912         (int)depth * 2 + 2,"", (int)depth * 2 + 2,"",
 913         "------:-----+-----------------\n" );
 914
 915     for( state=1 ; state < next_alloc ; state ++ ) {
 916         U16 charid;
 917
 918         PerlIO_printf( Perl_debug_log, "%*s %4"UVXf" :",
 919             (int)depth * 2 + 2,"", (UV)state  );
 920         if ( ! trie->states[ state ].wordnum ) {
 921             PerlIO_printf( Perl_debug_log, "%5s| ","");
 922         } else {
 923             PerlIO_printf( Perl_debug_log, "W%4x| ",
 924                 trie->states[ state ].wordnum
 925             );
 926         }
 927         for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
 928             SV ** const tmp = av_fetch( trie->revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0);
 929             if ( tmp ) {
 930                 PerlIO_printf( Perl_debug_log, "%*s:%3X=%4"UVXf" | ",
 931                     colwidth,
 932                     pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
 933                             PL_colors[0], PL_colors[1],
 934                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
 935                             PERL_PV_ESCAPE_FIRSTCHAR
 936                     ) ,
 937                     TRIE_LIST_ITEM(state,charid).forid,
 938                     (UV)TRIE_LIST_ITEM(state,charid).newstate
 939                 );
 940                 if (!(charid % 10))
 941                     PerlIO_printf(Perl_debug_log, "\n%*s| ",
 942                         (int)((depth * 2) + 14), "");
 943             }
 944         }
 945         PerlIO_printf( Perl_debug_log, "\n");
 946     }
 947 }
 948
 949 /*
 950   dump_trie_interim_table(trie,next_alloc)
 951   Dumps a fully constructed but uncompressed trie in table form.
 952   This is the normal DFA style state transition table, with a few
 953   twists to facilitate compression later.
 954   Used for debugging make_trie().
 955 */
 956 STATIC void
 957 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie, U32 next_alloc, U32 depth)
 958 {
 959     U32 state;
 960     U16 charid;
 961     SV *sv=sv_newmortal();
 962     int colwidth= trie->widecharmap ? 6 : 4;
 963     GET_RE_DEBUG_FLAGS_DECL;
 964
 965     /*
 966        print out the table precompression so that we can do a visual check
 967        that they are identical.
 968      */
 969
 970     PerlIO_printf( Perl_debug_log, "%*sChar : ",(int)depth * 2 + 2,"" );
 971
 972     for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
 973         SV ** const tmp = av_fetch( trie->revcharmap, charid, 0);
 974         if ( tmp ) {
 975             PerlIO_printf( Perl_debug_log, "%*s",
 976                 colwidth,
 977                 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
 978                             PL_colors[0], PL_colors[1],
 979                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
 980                             PERL_PV_ESCAPE_FIRSTCHAR
 981                 )
 982             );
 983         }
 984     }
 985
 986     PerlIO_printf( Perl_debug_log, "\n%*sState+-",(int)depth * 2 + 2,"" );
 987
 988     for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
 989         PerlIO_printf( Perl_debug_log, "%.*s", colwidth,"--------");
 990     }
 991
 992     PerlIO_printf( Perl_debug_log, "\n" );
 993
 994     for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
 995
 996         PerlIO_printf( Perl_debug_log, "%*s%4"UVXf" : ",
 997             (int)depth * 2 + 2,"",
 998             (UV)TRIE_NODENUM( state ) );
 999
1000         for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1001             UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
1002             if (v)
1003                 PerlIO_printf( Perl_debug_log, "%*"UVXf, colwidth, v );
1004             else
1005                 PerlIO_printf( Perl_debug_log, "%*s", colwidth, "." );
1006         }
1007         if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
1008             PerlIO_printf( Perl_debug_log, " (%4"UVXf")\n", (UV)trie->trans[ state ].check );
1009         } else {
1010             PerlIO_printf( Perl_debug_log, " (%4"UVXf") W%4X\n", (UV)trie->trans[ state ].check,
1011             trie->states[ TRIE_NODENUM( state ) ].wordnum );
1012         }
1013     }
1014 }
1015
1016 #endif
1017
1018 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
1019   startbranch: the first branch in the whole branch sequence
1020   first      : start branch of sequence of branch-exact nodes.
1021                May be the same as startbranch
1022   last       : Thing following the last branch.
1023                May be the same as tail.
1024   tail       : item following the branch sequence
1025   count      : words in the sequence
1026   flags      : currently the OP() type we will be building one of /EXACT(|F|Fl)/
1027   depth      : indent depth
1028
1029 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
1030
1031 A trie is an N'ary tree where the branches are determined by digital
1032 decomposition of the key. IE, at the root node you look up the 1st character and
1033 follow that branch repeat until you find the end of the branches. Nodes can be
1034 marked as "accepting" meaning they represent a complete word. Eg:
1035
1036   /he|she|his|hers/
1037
1038 would convert into the following structure. Numbers represent states, letters
1039 following numbers represent valid transitions on the letter from that state, if
1040 the number is in square brackets it represents an accepting state, otherwise it
1041 will be in parenthesis.
1042
1043       +-h->+-e->[3]-+-r->(8)-+-s->[9]
1044       |    |
1045       |   (2)
1046       |    |
1047      (1)   +-i->(6)-+-s->[7]
1048       |
1049       +-s->(3)-+-h->(4)-+-e->[5]
1050
1051       Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
1052
1053 This shows that when matching against the string 'hers' we will begin at state 1
1054 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
1055 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
1056 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
1057 single traverse. We store a mapping from accepting to state to which word was
1058 matched, and then when we have multiple possibilities we try to complete the
1059 rest of the regex in the order in which they occured in the alternation.
1060
1061 The only prior NFA like behaviour that would be changed by the TRIE support is
1062 the silent ignoring of duplicate alternations which are of the form:
1063
1064  / (DUPE|DUPE) X? (?{ ... }) Y /x
1065
1066 Thus EVAL blocks follwing a trie may be called a different number of times with
1067 and without the optimisation. With the optimisations dupes will be silently
1068 ignored. This inconsistant behaviour of EVAL type nodes is well established as
1069 the following demonstrates:
1070
1071  'words'=~/(word|word|word)(?{ print $1 })[xyz]/
1072
1073 which prints out 'word' three times, but
1074
1075  'words'=~/(word|word|word)(?{ print $1 })S/
1076
1077 which doesnt print it out at all. This is due to other optimisations kicking in.
1078
1079 Example of what happens on a structural level:
1080
1081 The regexp /(ac|ad|ab)+/ will produce the folowing debug output:
1082
1083    1: CURLYM[1] {1,32767}(18)
1084    5:   BRANCH(8)
1085    6:     EXACT <ac>(16)
1086    8:   BRANCH(11)
1087    9:     EXACT <ad>(16)
1088   11:   BRANCH(14)
1089   12:     EXACT <ab>(16)
1090   16:   SUCCEED(0)
1091   17:   NOTHING(18)
1092   18: END(0)
1093
1094 This would be optimizable with startbranch=5, first=5, last=16, tail=16
1095 and should turn into:
1096
1097    1: CURLYM[1] {1,32767}(18)
1098    5:   TRIE(16)
1099         [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
1100           <ac>
1101           <ad>
1102           <ab>
1103   16:   SUCCEED(0)
1104   17:   NOTHING(18)
1105   18: END(0)
1106
1107 Cases where tail != last would be like /(?foo|bar)baz/:
1108
1109    1: BRANCH(4)
1110    2:   EXACT <foo>(8)
1111    4: BRANCH(7)
1112    5:   EXACT <bar>(8)
1113    7: TAIL(8)
1114    8: EXACT <baz>(10)
1115   10: END(0)
1116
1117 which would be optimizable with startbranch=1, first=1, last=7, tail=8
1118 and would end up looking like:
1119
1120     1: TRIE(8)
1121       [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
1122         <foo>
1123         <bar>
1124    7: TAIL(8)
1125    8: EXACT <baz>(10)
1126   10: END(0)
1127
1128     d = uvuni_to_utf8_flags(d, uv, 0);
1129
1130 is the recommended Unicode-aware way of saying
1131
1132     *(d++) = uv;
1133 */
1134
1135 #define TRIE_STORE_REVCHAR                                                 \
1136     STMT_START {                                                           \
1137         SV *tmp = newSVpvs("");                                            \
1138         if (UTF) SvUTF8_on(tmp);                                           \
1139         Perl_sv_catpvf( aTHX_ tmp, "%c", (int)uvc );                       \
1140         av_push( TRIE_REVCHARMAP(trie), tmp );                             \
1141     } STMT_END
1142
1143 #define TRIE_READ_CHAR STMT_START {                                           \
1144     wordlen++;                                                                \
1145     if ( UTF ) {                                                              \
1146         if ( folder ) {                                                       \
1147             if ( foldlen > 0 ) {                                              \
1148                uvc = utf8n_to_uvuni( scan, UTF8_MAXLEN, &len, uniflags );     \
1149                foldlen -= len;                                                \
1150                scan += len;                                                   \
1151                len = 0;                                                       \
1152             } else {                                                          \
1153                 uvc = utf8n_to_uvuni( (const U8*)uc, UTF8_MAXLEN, &len, uniflags);\
1154                 uvc = to_uni_fold( uvc, foldbuf, &foldlen );                  \
1155                 foldlen -= UNISKIP( uvc );                                    \
1156                 scan = foldbuf + UNISKIP( uvc );                              \
1157             }                                                                 \
1158         } else {                                                              \
1159             uvc = utf8n_to_uvuni( (const U8*)uc, UTF8_MAXLEN, &len, uniflags);\
1160         }                                                                     \
1161     } else {                                                                  \
1162         uvc = (U32)*uc;                                                       \
1163         len = 1;                                                              \
1164     }                                                                         \
1165 } STMT_END
1166
1167
1168
1169 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START {               \
1170     if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) {    \
1171         U32 ging = TRIE_LIST_LEN( state ) *= 2;                 \
1172         Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
1173     }                                                           \
1174     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid;     \
1175     TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns;   \
1176     TRIE_LIST_CUR( state )++;                                   \
1177 } STMT_END
1178
1179 #define TRIE_LIST_NEW(state) STMT_START {                       \
1180     Newxz( trie->states[ state ].trans.list,               \
1181         4, reg_trie_trans_le );                                 \
1182      TRIE_LIST_CUR( state ) = 1;                                \
1183      TRIE_LIST_LEN( state ) = 4;                                \
1184 } STMT_END
1185
1186 #define TRIE_HANDLE_WORD(state) STMT_START {                    \
1187     U16 dupe= trie->states[ state ].wordnum;                    \
1188     regnode * const noper_next = regnext( noper );              \
1189                                                                 \
1190     if (trie->wordlen)                                          \
1191         trie->wordlen[ curword ] = wordlen;                     \
1192     DEBUG_r({                                                   \
1193         /* store the word for dumping */                        \
1194         SV* tmp;                                                \
1195         if (OP(noper) != NOTHING)                               \
1196             tmp = newSVpvn(STRING(noper), STR_LEN(noper));      \
1197         else                                                    \
1198             tmp = newSVpvn( "", 0 );                            \
1199         if ( UTF ) SvUTF8_on( tmp );                            \
1200         av_push( trie->words, tmp );                            \
1201     });                                                         \
1202                                                                 \
1203     curword++;                                                  \
1204                                                                 \
1205     if ( noper_next < tail ) {                                  \
1206         if (!trie->jump)                                        \
1207             Newxz( trie->jump, word_count + 1, U16);            \
1208         trie->jump[curword] = (U16)(noper_next - convert);      \
1209         if (!jumper)                                            \
1210             jumper = noper_next;                                \
1211         if (!nextbranch)                                        \
1212             nextbranch= regnext(cur);                           \
1213     }                                                           \
1214                                                                 \
1215     if ( dupe ) {                                               \
1216         /* So it's a dupe. This means we need to maintain a   */\
1217         /* linked-list from the first to the next.            */\
1218         /* we only allocate the nextword buffer when there    */\
1219         /* a dupe, so first time we have to do the allocation */\
1220         if (!trie->nextword)                                    \
1221             Newxz( trie->nextword, word_count + 1, U16);        \
1222         while ( trie->nextword[dupe] )                          \
1223             dupe= trie->nextword[dupe];                         \
1224         trie->nextword[dupe]= curword;                          \
1225     } else {                                                    \
1226         /* we haven't inserted this word yet.                */ \
1227         trie->states[ state ].wordnum = curword;                \
1228     }                                                           \
1229 } STMT_END
1230
1231
1232 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special)          \
1233      ( ( base + charid >=  ucharcount                                   \
1234          && base + charid < ubound                                      \
1235          && state == trie->trans[ base - ucharcount + charid ].check    \
1236          && trie->trans[ base - ucharcount + charid ].next )            \
1237            ? trie->trans[ base - ucharcount + charid ].next             \
1238            : ( state==1 ? special : 0 )                                 \
1239       )
1240
1241 #define MADE_TRIE       1
1242 #define MADE_JUMP_TRIE  2
1243 #define MADE_EXACT_TRIE 4
1244
1245 STATIC I32
1246 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *first, regnode *last, regnode *tail, U32 word_count, U32 flags, U32 depth)
1247 {
1248     dVAR;
1249     /* first pass, loop through and scan words */
1250     reg_trie_data *trie;
1251     regnode *cur;
1252     const U32 uniflags = UTF8_ALLOW_DEFAULT;
1253     STRLEN len = 0;
1254     UV uvc = 0;
1255     U16 curword = 0;
1256     U32 next_alloc = 0;
1257     regnode *jumper = NULL;
1258     regnode *nextbranch = NULL;
1259     regnode *convert = NULL;
1260     /* we just use folder as a flag in utf8 */
1261     const U8 * const folder = ( flags == EXACTF
1262                        ? PL_fold
1263                        : ( flags == EXACTFL
1264                            ? PL_fold_locale
1265                            : NULL
1266                          )
1267                      );
1268
1269     const U32 data_slot = add_data( pRExC_state, 1, "t" );
1270     SV *re_trie_maxbuff;
1271 #ifndef DEBUGGING
1272     /* these are only used during construction but are useful during
1273      * debugging so we store them in the struct when debugging.
1274      */
1275     STRLEN trie_charcount=0;
1276     AV *trie_revcharmap;
1277 #endif
1278     GET_RE_DEBUG_FLAGS_DECL;
1279 #ifndef DEBUGGING
1280     PERL_UNUSED_ARG(depth);
1281 #endif
1282
1283     Newxz( trie, 1, reg_trie_data );
1284     trie->refcount = 1;
1285     trie->startstate = 1;
1286     trie->wordcount = word_count;
1287     RExC_rxi->data->data[ data_slot ] = (void*)trie;
1288     Newxz( trie->charmap, 256, U16 );
1289     if (!(UTF && folder))
1290         Newxz( trie->bitmap, ANYOF_BITMAP_SIZE, char );
1291     DEBUG_r({
1292         trie->words = newAV();
1293     });
1294     TRIE_REVCHARMAP(trie) = newAV();
1295
1296     re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
1297     if (!SvIOK(re_trie_maxbuff)) {
1298         sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
1299     }
1300     DEBUG_OPTIMISE_r({
1301                 PerlIO_printf( Perl_debug_log,
1302                   "%*smake_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
1303                   (int)depth * 2 + 2, "",
1304                   REG_NODE_NUM(startbranch),REG_NODE_NUM(first),
1305                   REG_NODE_NUM(last), REG_NODE_NUM(tail),
1306                   (int)depth);
1307     });
1308
1309    /* Find the node we are going to overwrite */
1310     if ( first == startbranch && OP( last ) != BRANCH ) {
1311         /* whole branch chain */
1312         convert = first;
1313     } else {
1314         /* branch sub-chain */
1315         convert = NEXTOPER( first );
1316     }
1317
1318     /*  -- First loop and Setup --
1319
1320        We first traverse the branches and scan each word to determine if it
1321        contains widechars, and how many unique chars there are, this is
1322        important as we have to build a table with at least as many columns as we
1323        have unique chars.
1324
1325        We use an array of integers to represent the character codes 0..255
1326        (trie->charmap) and we use a an HV* to store unicode characters. We use the
1327        native representation of the character value as the key and IV's for the
1328        coded index.
1329
1330        *TODO* If we keep track of how many times each character is used we can
1331        remap the columns so that the table compression later on is more
1332        efficient in terms of memory by ensuring most common value is in the
1333        middle and the least common are on the outside.  IMO this would be better
1334        than a most to least common mapping as theres a decent chance the most
1335        common letter will share a node with the least common, meaning the node
1336        will not be compressable. With a middle is most common approach the worst
1337        case is when we have the least common nodes twice.
1338
1339      */
1340
1341     for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1342         regnode * const noper = NEXTOPER( cur );
1343         const U8 *uc = (U8*)STRING( noper );
1344         const U8 * const e  = uc + STR_LEN( noper );
1345         STRLEN foldlen = 0;
1346         U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1347         const U8 *scan = (U8*)NULL;
1348         U32 wordlen      = 0;         /* required init */
1349         STRLEN chars=0;
1350
1351         if (OP(noper) == NOTHING) {
1352             trie->minlen= 0;
1353             continue;
1354         }
1355         if (trie->bitmap) {
1356             TRIE_BITMAP_SET(trie,*uc);
1357             if ( folder ) TRIE_BITMAP_SET(trie,folder[ *uc ]);
1358         }
1359         for ( ; uc < e ; uc += len ) {
1360             TRIE_CHARCOUNT(trie)++;
1361             TRIE_READ_CHAR;
1362             chars++;
1363             if ( uvc < 256 ) {
1364                 if ( !trie->charmap[ uvc ] ) {
1365                     trie->charmap[ uvc ]=( ++trie->uniquecharcount );
1366                     if ( folder )
1367                         trie->charmap[ folder[ uvc ] ] = trie->charmap[ uvc ];
1368                     TRIE_STORE_REVCHAR;
1369                 }
1370             } else {
1371                 SV** svpp;
1372                 if ( !trie->widecharmap )
1373                     trie->widecharmap = newHV();
1374
1375                 svpp = hv_fetch( trie->widecharmap, (char*)&uvc, sizeof( UV ), 1 );
1376
1377                 if ( !svpp )
1378                     Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%"UVXf, uvc );
1379
1380                 if ( !SvTRUE( *svpp ) ) {
1381                     sv_setiv( *svpp, ++trie->uniquecharcount );
1382                     TRIE_STORE_REVCHAR;
1383                 }
1384             }
1385         }
1386         if( cur == first ) {
1387             trie->minlen=chars;
1388             trie->maxlen=chars;
1389         } else if (chars < trie->minlen) {
1390             trie->minlen=chars;
1391         } else if (chars > trie->maxlen) {
1392             trie->maxlen=chars;
1393         }
1394
1395     } /* end first pass */
1396     DEBUG_TRIE_COMPILE_r(
1397         PerlIO_printf( Perl_debug_log, "%*sTRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
1398                 (int)depth * 2 + 2,"",
1399                 ( trie->widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
1400                 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
1401                 (int)trie->minlen, (int)trie->maxlen )
1402     );
1403     Newxz( trie->wordlen, word_count, U32 );
1404
1405     /*
1406         We now know what we are dealing with in terms of unique chars and
1407         string sizes so we can calculate how much memory a naive
1408         representation using a flat table  will take. If it's over a reasonable
1409         limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
1410         conservative but potentially much slower representation using an array
1411         of lists.
1412
1413         At the end we convert both representations into the same compressed
1414         form that will be used in regexec.c for matching with. The latter
1415         is a form that cannot be used to construct with but has memory
1416         properties similar to the list form and access properties similar
1417         to the table form making it both suitable for fast searches and
1418         small enough that its feasable to store for the duration of a program.
1419
1420         See the comment in the code where the compressed table is produced
1421         inplace from the flat tabe representation for an explanation of how
1422         the compression works.
1423
1424     */
1425
1426
1427     if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1) > SvIV(re_trie_maxbuff) ) {
1428         /*
1429             Second Pass -- Array Of Lists Representation
1430
1431             Each state will be represented by a list of charid:state records
1432             (reg_trie_trans_le) the first such element holds the CUR and LEN
1433             points of the allocated array. (See defines above).
1434
1435             We build the initial structure using the lists, and then convert
1436             it into the compressed table form which allows faster lookups
1437             (but cant be modified once converted).
1438         */
1439
1440         STRLEN transcount = 1;
1441
1442         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log,
1443             "%*sCompiling trie using list compiler\n",
1444             (int)depth * 2 + 2, ""));
1445
1446         Newxz( trie->states, TRIE_CHARCOUNT(trie) + 2, reg_trie_state );
1447         TRIE_LIST_NEW(1);
1448         next_alloc = 2;
1449
1450         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1451
1452             regnode * const noper = NEXTOPER( cur );
1453             U8 *uc           = (U8*)STRING( noper );
1454             const U8 * const e = uc + STR_LEN( noper );
1455             U32 state        = 1;         /* required init */
1456             U16 charid       = 0;         /* sanity init */
1457             U8 *scan         = (U8*)NULL; /* sanity init */
1458             STRLEN foldlen   = 0;         /* required init */
1459             U32 wordlen      = 0;         /* required init */
1460             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1461
1462             if (OP(noper) != NOTHING) {
1463                 for ( ; uc < e ; uc += len ) {
1464
1465                     TRIE_READ_CHAR;
1466
1467                     if ( uvc < 256 ) {
1468                         charid = trie->charmap[ uvc ];
1469                     } else {
1470                         SV** const svpp = hv_fetch( trie->widecharmap, (char*)&uvc, sizeof( UV ), 0);
1471                         if ( !svpp ) {
1472                             charid = 0;
1473                         } else {
1474                             charid=(U16)SvIV( *svpp );
1475                         }
1476                     }
1477                     /* charid is now 0 if we dont know the char read, or nonzero if we do */
1478                     if ( charid ) {
1479
1480                         U16 check;
1481                         U32 newstate = 0;
1482
1483                         charid--;
1484                         if ( !trie->states[ state ].trans.list ) {
1485                             TRIE_LIST_NEW( state );
1486                         }
1487                         for ( check = 1; check <= TRIE_LIST_USED( state ); check++ ) {
1488                             if ( TRIE_LIST_ITEM( state, check ).forid == charid ) {
1489                                 newstate = TRIE_LIST_ITEM( state, check ).newstate;
1490                                 break;
1491                             }
1492                         }
1493                         if ( ! newstate ) {
1494                             newstate = next_alloc++;
1495                             TRIE_LIST_PUSH( state, charid, newstate );
1496                             transcount++;
1497                         }
1498                         state = newstate;
1499                     } else {
1500                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1501                     }
1502                 }
1503             }
1504             TRIE_HANDLE_WORD(state);
1505
1506         } /* end second pass */
1507
1508         /* next alloc is the NEXT state to be allocated */
1509         trie->statecount = next_alloc;
1510         Renew( trie->states, next_alloc, reg_trie_state );
1511
1512         /* and now dump it out before we compress it */
1513         DEBUG_TRIE_COMPILE_MORE_r(
1514             dump_trie_interim_list(trie,next_alloc,depth+1)
1515         );
1516
1517         Newxz( trie->trans, transcount ,reg_trie_trans );
1518         {
1519             U32 state;
1520             U32 tp = 0;
1521             U32 zp = 0;
1522
1523
1524             for( state=1 ; state < next_alloc ; state ++ ) {
1525                 U32 base=0;
1526
1527                 /*
1528                 DEBUG_TRIE_COMPILE_MORE_r(
1529                     PerlIO_printf( Perl_debug_log, "tp: %d zp: %d ",tp,zp)
1530                 );
1531                 */
1532
1533                 if (trie->states[state].trans.list) {
1534                     U16 minid=TRIE_LIST_ITEM( state, 1).forid;
1535                     U16 maxid=minid;
1536                     U16 idx;
1537
1538                     for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1539                         const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
1540                         if ( forid < minid ) {
1541                             minid=forid;
1542                         } else if ( forid > maxid ) {
1543                             maxid=forid;
1544                         }
1545                     }
1546                     if ( transcount < tp + maxid - minid + 1) {
1547                         transcount *= 2;
1548                         Renew( trie->trans, transcount, reg_trie_trans );
1549                         Zero( trie->trans + (transcount / 2), transcount / 2 , reg_trie_trans );
1550                     }
1551                     base = trie->uniquecharcount + tp - minid;
1552                     if ( maxid == minid ) {
1553                         U32 set = 0;
1554                         for ( ; zp < tp ; zp++ ) {
1555                             if ( ! trie->trans[ zp ].next ) {
1556                                 base = trie->uniquecharcount + zp - minid;
1557                                 trie->trans[ zp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1558                                 trie->trans[ zp ].check = state;
1559                                 set = 1;
1560                                 break;
1561                             }
1562                         }
1563                         if ( !set ) {
1564                             trie->trans[ tp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1565                             trie->trans[ tp ].check = state;
1566                             tp++;
1567                             zp = tp;
1568                         }
1569                     } else {
1570                         for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1571                             const U32 tid = base -  trie->uniquecharcount + TRIE_LIST_ITEM( state, idx ).forid;
1572                             trie->trans[ tid ].next = TRIE_LIST_ITEM( state, idx ).newstate;
1573                             trie->trans[ tid ].check = state;
1574                         }
1575                         tp += ( maxid - minid + 1 );
1576                     }
1577                     Safefree(trie->states[ state ].trans.list);
1578                 }
1579                 /*
1580                 DEBUG_TRIE_COMPILE_MORE_r(
1581                     PerlIO_printf( Perl_debug_log, " base: %d\n",base);
1582                 );
1583                 */
1584                 trie->states[ state ].trans.base=base;
1585             }
1586             trie->lasttrans = tp + 1;
1587         }
1588     } else {
1589         /*
1590            Second Pass -- Flat Table Representation.
1591
1592            we dont use the 0 slot of either trans[] or states[] so we add 1 to each.
1593            We know that we will need Charcount+1 trans at most to store the data
1594            (one row per char at worst case) So we preallocate both structures
1595            assuming worst case.
1596
1597            We then construct the trie using only the .next slots of the entry
1598            structs.
1599
1600            We use the .check field of the first entry of the node  temporarily to
1601            make compression both faster and easier by keeping track of how many non
1602            zero fields are in the node.
1603
1604            Since trans are numbered from 1 any 0 pointer in the table is a FAIL
1605            transition.
1606
1607            There are two terms at use here: state as a TRIE_NODEIDX() which is a
1608            number representing the first entry of the node, and state as a
1609            TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1) and
1610            TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3) if there
1611            are 2 entrys per node. eg:
1612
1613              A B       A B
1614           1. 2 4    1. 3 7
1615           2. 0 3    3. 0 5
1616           3. 0 0    5. 0 0
1617           4. 0 0    7. 0 0
1618
1619            The table is internally in the right hand, idx form. However as we also
1620            have to deal with the states array which is indexed by nodenum we have to
1621            use TRIE_NODENUM() to convert.
1622
1623         */
1624         DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log,
1625             "%*sCompiling trie using table compiler\n",
1626             (int)depth * 2 + 2, ""));
1627
1628         Newxz( trie->trans, ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1,
1629               reg_trie_trans );
1630         Newxz( trie->states, TRIE_CHARCOUNT(trie) + 2, reg_trie_state );
1631         next_alloc = trie->uniquecharcount + 1;
1632
1633
1634         for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1635
1636             regnode * const noper   = NEXTOPER( cur );
1637             const U8 *uc     = (U8*)STRING( noper );
1638             const U8 * const e = uc + STR_LEN( noper );
1639
1640             U32 state        = 1;         /* required init */
1641
1642             U16 charid       = 0;         /* sanity init */
1643             U32 accept_state = 0;         /* sanity init */
1644             U8 *scan         = (U8*)NULL; /* sanity init */
1645
1646             STRLEN foldlen   = 0;         /* required init */
1647             U32 wordlen      = 0;         /* required init */
1648             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1649
1650             if ( OP(noper) != NOTHING ) {
1651                 for ( ; uc < e ; uc += len ) {
1652
1653                     TRIE_READ_CHAR;
1654
1655                     if ( uvc < 256 ) {
1656                         charid = trie->charmap[ uvc ];
1657                     } else {
1658                         SV* const * const svpp = hv_fetch( trie->widecharmap, (char*)&uvc, sizeof( UV ), 0);
1659                         charid = svpp ? (U16)SvIV(*svpp) : 0;
1660                     }
1661                     if ( charid ) {
1662                         charid--;
1663                         if ( !trie->trans[ state + charid ].next ) {
1664                             trie->trans[ state + charid ].next = next_alloc;
1665                             trie->trans[ state ].check++;
1666                             next_alloc += trie->uniquecharcount;
1667                         }
1668                         state = trie->trans[ state + charid ].next;
1669                     } else {
1670                         Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1671                     }
1672                     /* charid is now 0 if we dont know the char read, or nonzero if we do */
1673                 }
1674             }
1675             accept_state = TRIE_NODENUM( state );
1676             TRIE_HANDLE_WORD(accept_state);
1677
1678         } /* end second pass */
1679
1680         /* and now dump it out before we compress it */
1681         DEBUG_TRIE_COMPILE_MORE_r(
1682             dump_trie_interim_table(trie,next_alloc,depth+1)
1683         );
1684
1685         {
1686         /*
1687            * Inplace compress the table.*
1688
1689            For sparse data sets the table constructed by the trie algorithm will
1690            be mostly 0/FAIL transitions or to put it another way mostly empty.
1691            (Note that leaf nodes will not contain any transitions.)
1692
1693            This algorithm compresses the tables by eliminating most such
1694            transitions, at the cost of a modest bit of extra work during lookup:
1695
1696            - Each states[] entry contains a .base field which indicates the
1697            index in the state[] array wheres its transition data is stored.
1698
1699            - If .base is 0 there are no  valid transitions from that node.
1700
1701            - If .base is nonzero then charid is added to it to find an entry in
1702            the trans array.
1703
1704            -If trans[states[state].base+charid].check!=state then the
1705            transition is taken to be a 0/Fail transition. Thus if there are fail
1706            transitions at the front of the node then the .base offset will point
1707            somewhere inside the previous nodes data (or maybe even into a node
1708            even earlier), but the .check field determines if the transition is
1709            valid.
1710
1711            XXX - wrong maybe?
1712            The following process inplace converts the table to the compressed
1713            table: We first do not compress the root node 1,and mark its all its
1714            .check pointers as 1 and set its .base pointer as 1 as well. This
1715            allows to do a DFA construction from the compressed table later, and
1716            ensures that any .base pointers we calculate later are greater than
1717            0.
1718
1719            - We set 'pos' to indicate the first entry of the second node.
1720
1721            - We then iterate over the columns of the node, finding the first and
1722            last used entry at l and m. We then copy l..m into pos..(pos+m-l),
1723            and set the .check pointers accordingly, and advance pos
1724            appropriately and repreat for the next node. Note that when we copy
1725            the next pointers we have to convert them from the original
1726            NODEIDX form to NODENUM form as the former is not valid post
1727            compression.
1728
1729            - If a node has no transitions used we mark its base as 0 and do not
1730            advance the pos pointer.
1731
1732            - If a node only has one transition we use a second pointer into the
1733            structure to fill in allocated fail transitions from other states.
1734            This pointer is independent of the main pointer and scans forward
1735            looking for null transitions that are allocated to a state. When it
1736            finds one it writes the single transition into the "hole".  If the
1737            pointer doesnt find one the single transition is appended as normal.
1738
1739            - Once compressed we can Renew/realloc the structures to release the
1740            excess space.
1741
1742            See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
1743            specifically Fig 3.47 and the associated pseudocode.
1744
1745            demq
1746         */
1747         const U32 laststate = TRIE_NODENUM( next_alloc );
1748         U32 state, charid;
1749         U32 pos = 0, zp=0;
1750         trie->statecount = laststate;
1751
1752         for ( state = 1 ; state < laststate ; state++ ) {
1753             U8 flag = 0;
1754             const U32 stateidx = TRIE_NODEIDX( state );
1755             const U32 o_used = trie->trans[ stateidx ].check;
1756             U32 used = trie->trans[ stateidx ].check;
1757             trie->trans[ stateidx ].check = 0;
1758
1759             for ( charid = 0 ; used && charid < trie->uniquecharcount ; charid++ ) {
1760                 if ( flag || trie->trans[ stateidx + charid ].next ) {
1761                     if ( trie->trans[ stateidx + charid ].next ) {
1762                         if (o_used == 1) {
1763                             for ( ; zp < pos ; zp++ ) {
1764                                 if ( ! trie->trans[ zp ].next ) {
1765                                     break;
1766                                 }
1767                             }
1768                             trie->states[ state ].trans.base = zp + trie->uniquecharcount - charid ;
1769                             trie->trans[ zp ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
1770                             trie->trans[ zp ].check = state;
1771                             if ( ++zp > pos ) pos = zp;
1772                             break;
1773                         }
1774                         used--;
1775                     }
1776                     if ( !flag ) {
1777                         flag = 1;
1778                         trie->states[ state ].trans.base = pos + trie->uniquecharcount - charid ;
1779                     }
1780                     trie->trans[ pos ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
1781                     trie->trans[ pos ].check = state;
1782                     pos++;
1783                 }
1784             }
1785         }
1786         trie->lasttrans = pos + 1;
1787         Renew( trie->states, laststate, reg_trie_state);
1788         DEBUG_TRIE_COMPILE_MORE_r(
1789                 PerlIO_printf( Perl_debug_log,
1790                     "%*sAlloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n",
1791                     (int)depth * 2 + 2,"",
1792                     (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1 ),
1793                     (IV)next_alloc,
1794                     (IV)pos,
1795                     ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
1796             );
1797
1798         } /* end table compress */
1799     }
1800     DEBUG_TRIE_COMPILE_MORE_r(
1801             PerlIO_printf(Perl_debug_log, "%*sStatecount:%"UVxf" Lasttrans:%"UVxf"\n",
1802                 (int)depth * 2 + 2, "",
1803                 (UV)trie->statecount,
1804                 (UV)trie->lasttrans)
1805     );
1806     /* resize the trans array to remove unused space */
1807     Renew( trie->trans, trie->lasttrans, reg_trie_trans);
1808
1809     /* and now dump out the compressed format */
1810     DEBUG_TRIE_COMPILE_r(
1811         dump_trie(trie,depth+1)
1812     );
1813
1814     {   /* Modify the program and insert the new TRIE node*/
1815         U8 nodetype =(U8)(flags & 0xFF);
1816         char *str=NULL;
1817
1818 #ifdef DEBUGGING
1819         regnode *optimize = NULL;
1820         U32 mjd_offset = 0;
1821         U32 mjd_nodelen = 0;
1822 #endif
1823         /*
1824            This means we convert either the first branch or the first Exact,
1825            depending on whether the thing following (in 'last') is a branch
1826            or not and whther first is the startbranch (ie is it a sub part of
1827            the alternation or is it the whole thing.)
1828            Assuming its a sub part we conver the EXACT otherwise we convert
1829            the whole branch sequence, including the first.
1830          */
1831         /* Find the node we are going to overwrite */
1832         if ( first != startbranch || OP( last ) == BRANCH ) {
1833             /* branch sub-chain */
1834             NEXT_OFF( first ) = (U16)(last - first);
1835             DEBUG_r({
1836                 mjd_offset= Node_Offset((convert));
1837                 mjd_nodelen= Node_Length((convert));
1838             });
1839             /* whole branch chain */
1840         } else {
1841             DEBUG_r({
1842                 const  regnode *nop = NEXTOPER( convert );
1843                 mjd_offset= Node_Offset((nop));
1844                 mjd_nodelen= Node_Length((nop));
1845             });
1846         }
1847
1848         DEBUG_OPTIMISE_r(
1849             PerlIO_printf(Perl_debug_log, "%*sMJD offset:%"UVuf" MJD length:%"UVuf"\n",
1850                 (int)depth * 2 + 2, "",
1851                 (UV)mjd_offset, (UV)mjd_nodelen)
1852         );
1853
1854         /* But first we check to see if there is a common prefix we can
1855            split out as an EXACT and put in front of the TRIE node.  */
1856         trie->startstate= 1;
1857         if ( trie->bitmap && !trie->widecharmap && !trie->jump  ) {
1858             U32 state;
1859             for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
1860                 U32 ofs = 0;
1861                 I32 idx = -1;
1862                 U32 count = 0;
1863                 const U32 base = trie->states[ state ].trans.base;
1864
1865                 if ( trie->states[state].wordnum )
1866                         count = 1;
1867
1868                 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
1869                     if ( ( base + ofs >= trie->uniquecharcount ) &&
1870                          ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
1871                          trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
1872                     {
1873                         if ( ++count > 1 ) {
1874                             SV **tmp = av_fetch( TRIE_REVCHARMAP(trie), ofs, 0);
1875                             const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
1876                             if ( state == 1 ) break;
1877                             if ( count == 2 ) {
1878                                 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
1879                                 DEBUG_OPTIMISE_r(
1880                                     PerlIO_printf(Perl_debug_log,
1881                                         "%*sNew Start State=%"UVuf" Class: [",
1882                                         (int)depth * 2 + 2, "",
1883                                         (UV)state));
1884                                 if (idx >= 0) {
1885                                     SV ** const tmp = av_fetch( TRIE_REVCHARMAP(trie), idx, 0);
1886                                     const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
1887
1888                                     TRIE_BITMAP_SET(trie,*ch);
1889                                     if ( folder )
1890                                         TRIE_BITMAP_SET(trie, folder[ *ch ]);
1891                                     DEBUG_OPTIMISE_r(
1892                                         PerlIO_printf(Perl_debug_log, (char*)ch)
1893                                     );
1894                                 }
1895                             }
1896                             TRIE_BITMAP_SET(trie,*ch);
1897                             if ( folder )
1898                                 TRIE_BITMAP_SET(trie,folder[ *ch ]);
1899                             DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"%s", ch));
1900                         }
1901                         idx = ofs;
1902                     }
1903                 }
1904                 if ( count == 1 ) {
1905                     SV **tmp = av_fetch( TRIE_REVCHARMAP(trie), idx, 0);
1906                     char *ch = SvPV_nolen( *tmp );
1907                     DEBUG_OPTIMISE_r({
1908                         SV *sv=sv_newmortal();
1909                         PerlIO_printf( Perl_debug_log,
1910                             "%*sPrefix State: %"UVuf" Idx:%"UVuf" Char='%s'\n",
1911                             (int)depth * 2 + 2, "",
1912                             (UV)state, (UV)idx,
1913                             pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6,
1914                                 PL_colors[0], PL_colors[1],
1915                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1916                                 PERL_PV_ESCAPE_FIRSTCHAR
1917                             )
1918                         );
1919                     });
1920                     if ( state==1 ) {
1921                         OP( convert ) = nodetype;
1922                         str=STRING(convert);
1923                         STR_LEN(convert)=0;
1924                     }
1925                     while (*ch) {
1926                         *str++ = *ch++;
1927                         STR_LEN(convert)++;
1928                     }
1929
1930                 } else {
1931 #ifdef DEBUGGING
1932                     if (state>1)
1933                         DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"]\n"));
1934 #endif
1935                     break;
1936                 }
1937             }
1938             if (str) {
1939                 regnode *n = convert+NODE_SZ_STR(convert);
1940                 NEXT_OFF(convert) = NODE_SZ_STR(convert);
1941                 trie->startstate = state;
1942                 trie->minlen -= (state - 1);
1943                 trie->maxlen -= (state - 1);
1944                 DEBUG_r({
1945                     regnode *fix = convert;
1946                     U32 word = trie->wordcount;
1947                     mjd_nodelen++;
1948                     Set_Node_Offset_Length(convert, mjd_offset, state - 1);
1949                     while( ++fix < n ) {
1950                         Set_Node_Offset_Length(fix, 0, 0);
1951                     }
1952                     while (word--) {
1953                         SV ** const tmp = av_fetch( trie->words, word, 0 );
1954                         if (tmp) {
1955                             if ( STR_LEN(convert) <= SvCUR(*tmp) )
1956                                 sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
1957                             else
1958                                 sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
1959                         }
1960                     }
1961                 });
1962                 if (trie->maxlen) {
1963                     convert = n;
1964                 } else {
1965                     NEXT_OFF(convert) = (U16)(tail - convert);
1966                     DEBUG_r(optimize= n);
1967                 }
1968             }
1969         }
1970         if (!jumper)
1971             jumper = last;
1972         if ( trie->maxlen ) {
1973             NEXT_OFF( convert ) = (U16)(tail - convert);
1974             ARG_SET( convert, data_slot );
1975             /* Store the offset to the first unabsorbed branch in
1976                jump[0], which is otherwise unused by the jump logic.
1977                We use this when dumping a trie and during optimisation. */
1978             if (trie->jump)
1979                 trie->jump[0] = (U16)(nextbranch - convert);
1980
1981             /* XXXX */
1982             if ( !trie->states[trie->startstate].wordnum && trie->bitmap &&
1983                  ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
1984             {
1985                 OP( convert ) = TRIEC;
1986                 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
1987                 Safefree(trie->bitmap);
1988                 trie->bitmap= NULL;
1989             } else
1990                 OP( convert ) = TRIE;
1991
1992             /* store the type in the flags */
1993             convert->flags = nodetype;
1994             DEBUG_r({
1995             optimize = convert
1996                       + NODE_STEP_REGNODE
1997                       + regarglen[ OP( convert ) ];
1998             });
1999             /* XXX We really should free up the resource in trie now,
2000                    as we won't use them - (which resources?) dmq */
2001         }
2002         /* needed for dumping*/
2003         DEBUG_r(if (optimize) {
2004             regnode *opt = convert;
2005             while ( ++opt < optimize) {
2006                 Set_Node_Offset_Length(opt,0,0);
2007             }
2008             /*
2009                 Try to clean up some of the debris left after the
2010                 optimisation.
2011              */
2012             while( optimize < jumper ) {
2013                 mjd_nodelen += Node_Length((optimize));
2014                 OP( optimize ) = OPTIMIZED;
2015                 Set_Node_Offset_Length(optimize,0,0);
2016                 optimize++;
2017             }
2018             Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
2019         });
2020     } /* end node insert */
2021 #ifndef DEBUGGING
2022     SvREFCNT_dec(TRIE_REVCHARMAP(trie));
2023 #endif
2024     return trie->jump
2025            ? MADE_JUMP_TRIE
2026            : trie->startstate>1
2027              ? MADE_EXACT_TRIE
2028              : MADE_TRIE;
2029 }
2030
2031 STATIC void
2032 S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source,  regnode *stclass, U32 depth)
2033 {
2034 /* The Trie is constructed and compressed now so we can build a fail array now if its needed
2035
2036    This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and 3.32 in the
2037    "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi, Ullman 1985/88
2038    ISBN 0-201-10088-6
2039
2040    We find the fail state for each state in the trie, this state is the longest proper
2041    suffix of the current states 'word' that is also a proper prefix of another word in our
2042    trie. State 1 represents the word '' and is the thus the default fail state. This allows
2043    the DFA not to have to restart after its tried and failed a word at a given point, it
2044    simply continues as though it had been matching the other word in the first place.
2045    Consider
2046       'abcdgu'=~/abcdefg|cdgu/
2047    When we get to 'd' we are still matching the first word, we would encounter 'g' which would
2048    fail, which would bring use to the state representing 'd' in the second word where we would
2049    try 'g' and succeed, prodceding to match 'cdgu'.
2050  */
2051  /* add a fail transition */
2052     reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[ARG(source)];
2053     U32 *q;
2054     const U32 ucharcount = trie->uniquecharcount;
2055     const U32 numstates = trie->statecount;
2056     const U32 ubound = trie->lasttrans + ucharcount;
2057     U32 q_read = 0;
2058     U32 q_write = 0;
2059     U32 charid;
2060     U32 base = trie->states[ 1 ].trans.base;
2061     U32 *fail;
2062     reg_ac_data *aho;
2063     const U32 data_slot = add_data( pRExC_state, 1, "T" );
2064     GET_RE_DEBUG_FLAGS_DECL;
2065 #ifndef DEBUGGING
2066     PERL_UNUSED_ARG(depth);
2067 #endif
2068
2069
2070     ARG_SET( stclass, data_slot );
2071     Newxz( aho, 1, reg_ac_data );
2072     RExC_rxi->data->data[ data_slot ] = (void*)aho;
2073     aho->trie=trie;
2074     aho->states=(reg_trie_state *)savepvn((const char*)trie->states,
2075         numstates * sizeof(reg_trie_state));
2076     Newxz( q, numstates, U32);
2077     Newxz( aho->fail, numstates, U32 );
2078     aho->refcount = 1;
2079     fail = aho->fail;
2080     /* initialize fail[0..1] to be 1 so that we always have
2081        a valid final fail state */
2082     fail[ 0 ] = fail[ 1 ] = 1;
2083
2084     for ( charid = 0; charid < ucharcount ; charid++ ) {
2085         const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
2086         if ( newstate ) {
2087             q[ q_write ] = newstate;
2088             /* set to point at the root */
2089             fail[ q[ q_write++ ] ]=1;
2090         }
2091     }
2092     while ( q_read < q_write) {
2093         const U32 cur = q[ q_read++ % numstates ];
2094         base = trie->states[ cur ].trans.base;
2095
2096         for ( charid = 0 ; charid < ucharcount ; charid++ ) {
2097             const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
2098             if (ch_state) {
2099                 U32 fail_state = cur;
2100                 U32 fail_base;
2101                 do {
2102                     fail_state = fail[ fail_state ];
2103                     fail_base = aho->states[ fail_state ].trans.base;
2104                 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
2105
2106                 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
2107                 fail[ ch_state ] = fail_state;
2108                 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
2109                 {
2110                         aho->states[ ch_state ].wordnum =  aho->states[ fail_state ].wordnum;
2111                 }
2112                 q[ q_write++ % numstates] = ch_state;
2113             }
2114         }
2115     }
2116     /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
2117        when we fail in state 1, this allows us to use the
2118        charclass scan to find a valid start char. This is based on the principle
2119        that theres a good chance the string being searched contains lots of stuff
2120        that cant be a start char.
2121      */
2122     fail[ 0 ] = fail[ 1 ] = 0;
2123     DEBUG_TRIE_COMPILE_r({
2124         PerlIO_printf(Perl_debug_log,
2125                       "%*sStclass Failtable (%"UVuf" states): 0",
2126                       (int)(depth * 2), "", (UV)numstates
2127         );
2128         for( q_read=1; q_read<numstates; q_read++ ) {
2129             PerlIO_printf(Perl_debug_log, ", %"UVuf, (UV)fail[q_read]);
2130         }
2131         PerlIO_printf(Perl_debug_log, "\n");
2132     });
2133     Safefree(q);
2134     /*RExC_seen |= REG_SEEN_TRIEDFA;*/
2135 }
2136
2137
2138 /*
2139  * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2140  * These need to be revisited when a newer toolchain becomes available.
2141  */
2142 #if defined(__sparc64__) && defined(__GNUC__)
2143 #   if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2144 #       undef  SPARC64_GCC_WORKAROUND
2145 #       define SPARC64_GCC_WORKAROUND 1
2146 #   endif
2147 #endif
2148
2149 #define DEBUG_PEEP(str,scan,depth) \
2150     DEBUG_OPTIMISE_r({if (scan){ \
2151        SV * const mysv=sv_newmortal(); \
2152        regnode *Next = regnext(scan); \
2153        regprop(RExC_rx, mysv, scan); \
2154        PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s (%d)\n", \
2155        (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\
2156        Next ? (REG_NODE_NUM(Next)) : 0 ); \
2157    }});
2158
2159
2160
2161
2162
2163 #define JOIN_EXACT(scan,min,flags) \
2164     if (PL_regkind[OP(scan)] == EXACT) \
2165         join_exact(pRExC_state,(scan),(min),(flags),NULL,depth+1)
2166
2167 STATIC U32
2168 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, I32 *min, U32 flags,regnode *val, U32 depth) {
2169     /* Merge several consecutive EXACTish nodes into one. */
2170     regnode *n = regnext(scan);
2171     U32 stringok = 1;
2172     regnode *next = scan + NODE_SZ_STR(scan);
2173     U32 merged = 0;
2174     U32 stopnow = 0;
2175 #ifdef DEBUGGING
2176     regnode *stop = scan;
2177     GET_RE_DEBUG_FLAGS_DECL;
2178 #else
2179     PERL_UNUSED_ARG(depth);
2180 #endif
2181 #ifndef EXPERIMENTAL_INPLACESCAN
2182     PERL_UNUSED_ARG(flags);
2183     PERL_UNUSED_ARG(val);
2184 #endif
2185     DEBUG_PEEP("join",scan,depth);
2186
2187     /* Skip NOTHING, merge EXACT*. */
2188     while (n &&
2189            ( PL_regkind[OP(n)] == NOTHING ||
2190              (stringok && (OP(n) == OP(scan))))
2191            && NEXT_OFF(n)
2192            && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX) {
2193
2194         if (OP(n) == TAIL || n > next)
2195             stringok = 0;
2196         if (PL_regkind[OP(n)] == NOTHING) {
2197             DEBUG_PEEP("skip:",n,depth);
2198             NEXT_OFF(scan) += NEXT_OFF(n);
2199             next = n + NODE_STEP_REGNODE;
2200 #ifdef DEBUGGING
2201             if (stringok)
2202                 stop = n;
2203 #endif
2204             n = regnext(n);
2205         }
2206         else if (stringok) {
2207             const unsigned int oldl = STR_LEN(scan);
2208             regnode * const nnext = regnext(n);
2209
2210             DEBUG_PEEP("merg",n,depth);
2211
2212             merged++;
2213             if (oldl + STR_LEN(n) > U8_MAX)
2214                 break;
2215             NEXT_OFF(scan) += NEXT_OFF(n);
2216             STR_LEN(scan) += STR_LEN(n);
2217             next = n + NODE_SZ_STR(n);
2218             /* Now we can overwrite *n : */
2219             Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
2220 #ifdef DEBUGGING
2221             stop = next - 1;
2222 #endif
2223             n = nnext;
2224             if (stopnow) break;
2225         }
2226
2227 #ifdef EXPERIMENTAL_INPLACESCAN
2228         if (flags && !NEXT_OFF(n)) {
2229             DEBUG_PEEP("atch", val, depth);
2230             if (reg_off_by_arg[OP(n)]) {
2231                 ARG_SET(n, val - n);
2232             }
2233             else {
2234                 NEXT_OFF(n) = val - n;
2235             }
2236             stopnow = 1;
2237         }
2238 #endif
2239     }
2240
2241     if (UTF && ( OP(scan) == EXACTF ) && ( STR_LEN(scan) >= 6 ) ) {
2242     /*
2243     Two problematic code points in Unicode casefolding of EXACT nodes:
2244
2245     U+0390 - GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
2246     U+03B0 - GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
2247
2248     which casefold to
2249
2250     Unicode                      UTF-8
2251
2252     U+03B9 U+0308 U+0301         0xCE 0xB9 0xCC 0x88 0xCC 0x81
2253     U+03C5 U+0308 U+0301         0xCF 0x85 0xCC 0x88 0xCC 0x81
2254
2255     This means that in case-insensitive matching (or "loose matching",
2256     as Unicode calls it), an EXACTF of length six (the UTF-8 encoded byte
2257     length of the above casefolded versions) can match a target string
2258     of length two (the byte length of UTF-8 encoded U+0390 or U+03B0).
2259     This would rather mess up the minimum length computation.
2260
2261     What we'll do is to look for the tail four bytes, and then peek
2262     at the preceding two bytes to see whether we need to decrease
2263     the minimum length by four (six minus two).
2264
2265     Thanks to the design of UTF-8, there cannot be false matches:
2266     A sequence of valid UTF-8 bytes cannot be a subsequence of
2267     another valid sequence of UTF-8 bytes.
2268
2269     */
2270          char * const s0 = STRING(scan), *s, *t;
2271          char * const s1 = s0 + STR_LEN(scan) - 1;
2272          char * const s2 = s1 - 4;
2273 #ifdef EBCDIC /* RD tunifold greek 0390 and 03B0 */
2274          const char t0[] = "\xaf\x49\xaf\x42";
2275 #else
2276          const char t0[] = "\xcc\x88\xcc\x81";
2277 #endif
2278          const char * const t1 = t0 + 3;
2279
2280          for (s = s0 + 2;
2281               s < s2 && (t = ninstr(s, s1, t0, t1));
2282               s = t + 4) {
2283 #ifdef EBCDIC
2284               if (((U8)t[-1] == 0x68 && (U8)t[-2] == 0xB4) ||
2285                   ((U8)t[-1] == 0x46 && (U8)t[-2] == 0xB5))
2286 #else
2287               if (((U8)t[-1] == 0xB9 && (U8)t[-2] == 0xCE) ||
2288                   ((U8)t[-1] == 0x85 && (U8)t[-2] == 0xCF))
2289 #endif
2290                    *min -= 4;
2291          }
2292     }
2293
2294 #ifdef DEBUGGING
2295     /* Allow dumping */
2296     n = scan + NODE_SZ_STR(scan);
2297     while (n <= stop) {
2298         if (PL_regkind[OP(n)] != NOTHING || OP(n) == NOTHING) {
2299             OP(n) = OPTIMIZED;
2300             NEXT_OFF(n) = 0;
2301         }
2302         n++;
2303     }
2304 #endif
2305     DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
2306     return stopnow;
2307 }
2308
2309 /* REx optimizer.  Converts nodes into quickier variants "in place".
2310    Finds fixed substrings.  */
2311
2312 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
2313    to the position after last scanned or to NULL. */
2314
2315 #define INIT_AND_WITHP \
2316     assert(!and_withp); \
2317     Newx(and_withp,1,struct regnode_charclass_class); \
2318     SAVEFREEPV(and_withp)
2319
2320 /* this is a chain of data about sub patterns we are processing that
2321    need to be handled seperately/specially in study_chunk. Its so
2322    we can simulate recursion without losing state.  */
2323 struct scan_frame;
2324 typedef struct scan_frame {
2325     regnode *last;  /* last node to process in this frame */
2326     regnode *next;  /* next node to process when last is reached */
2327     struct scan_frame *prev; /*previous frame*/
2328     I32 stop; /* what stopparen do we use */
2329 } scan_frame;
2330
2331 STATIC I32
2332 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
2333                         I32 *minlenp, I32 *deltap,
2334                         regnode *last,
2335                         scan_data_t *data,
2336                         I32 stopparen,
2337                         U8* recursed,
2338                         struct regnode_charclass_class *and_withp,
2339                         U32 flags, U32 depth)
2340                         /* scanp: Start here (read-write). */
2341                         /* deltap: Write maxlen-minlen here. */
2342                         /* last: Stop before this one. */
2343                         /* data: string data about the pattern */
2344                         /* stopparen: treat close N as END */
2345                         /* recursed: which subroutines have we recursed into */
2346                         /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
2347 {
2348     dVAR;
2349     I32 min = 0, pars = 0, code;
2350     regnode *scan = *scanp, *next;
2351     I32 delta = 0;
2352     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
2353     int is_inf_internal = 0;            /* The studied chunk is infinite */
2354     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
2355     scan_data_t data_fake;
2356     SV *re_trie_maxbuff = NULL;
2357     regnode *first_non_open = scan;
2358     I32 stopmin = I32_MAX;
2359     scan_frame *frame = NULL;
2360
2361     GET_RE_DEBUG_FLAGS_DECL;
2362
2363 #ifdef DEBUGGING
2364     StructCopy(&zero_scan_data, &data_fake, scan_data_t);
2365 #endif
2366
2367     if ( depth == 0 ) {
2368         while (first_non_open && OP(first_non_open) == OPEN)
2369             first_non_open=regnext(first_non_open);
2370     }
2371
2372
2373   fake_study_recurse:
2374     while ( scan && OP(scan) != END && scan < last ){
2375         /* Peephole optimizer: */
2376         DEBUG_STUDYDATA(data,depth);
2377         DEBUG_PEEP("Peep",scan,depth);
2378         JOIN_EXACT(scan,&min,0);
2379
2380         /* Follow the next-chain of the current node and optimize
2381            away all the NOTHINGs from it.  */
2382         if (OP(scan) != CURLYX) {
2383             const int max = (reg_off_by_arg[OP(scan)]
2384                        ? I32_MAX
2385                        /* I32 may be smaller than U16 on CRAYs! */
2386                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
2387             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
2388             int noff;
2389             regnode *n = scan;
2390
2391             /* Skip NOTHING and LONGJMP. */
2392             while ((n = regnext(n))
2393                    && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
2394                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
2395                    && off + noff < max)
2396                 off += noff;
2397             if (reg_off_by_arg[OP(scan)])
2398                 ARG(scan) = off;
2399             else
2400                 NEXT_OFF(scan) = off;
2401         }
2402
2403
2404
2405         /* The principal pseudo-switch.  Cannot be a switch, since we
2406            look into several different things.  */
2407         if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
2408                    || OP(scan) == IFTHEN) {
2409             next = regnext(scan);
2410             code = OP(scan);
2411             /* demq: the op(next)==code check is to see if we have "branch-branch" AFAICT */
2412
2413             if (OP(next) == code || code == IFTHEN) {
2414                 /* NOTE - There is similar code to this block below for handling
2415                    TRIE nodes on a re-study.  If you change stuff here check there
2416                    too. */
2417                 I32 max1 = 0, min1 = I32_MAX, num = 0;
2418                 struct regnode_charclass_class accum;
2419                 regnode * const startbranch=scan;
2420
2421                 if (flags & SCF_DO_SUBSTR)
2422                     scan_commit(pRExC_state, data, minlenp); /* Cannot merge strings after this. */
2423                 if (flags & SCF_DO_STCLASS)
2424                     cl_init_zero(pRExC_state, &accum);
2425
2426                 while (OP(scan) == code) {
2427                     I32 deltanext, minnext, f = 0, fake;
2428                     struct regnode_charclass_class this_class;
2429
2430                     num++;
2431                     data_fake.flags = 0;
2432                     if (data) {
2433                         data_fake.whilem_c = data->whilem_c;
2434                         data_fake.last_closep = data->last_closep;
2435                     }
2436                     else
2437                         data_fake.last_closep = &fake;
2438
2439                     data_fake.pos_delta = delta;
2440                     next = regnext(scan);
2441                     scan = NEXTOPER(scan);
2442                     if (code != BRANCH)
2443                         scan = NEXTOPER(scan);
2444                     if (flags & SCF_DO_STCLASS) {
2445                         cl_init(pRExC_state, &this_class);
2446                         data_fake.start_class = &this_class;
2447                         f = SCF_DO_STCLASS_AND;
2448                     }
2449                     if (flags & SCF_WHILEM_VISITED_POS)
2450                         f |= SCF_WHILEM_VISITED_POS;
2451
2452                     /* we suppose the run is continuous, last=next...*/
2453                     minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
2454                                           next, &data_fake,
2455                                           stopparen, recursed, NULL, f,depth+1);
2456                     if (min1 > minnext)
2457                         min1 = minnext;
2458                     if (max1 < minnext + deltanext)
2459                         max1 = minnext + deltanext;
2460                     if (deltanext == I32_MAX)
2461                         is_inf = is_inf_internal = 1;
2462                     scan = next;
2463                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
2464                         pars++;
2465                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
2466                         if ( stopmin > minnext)
2467                             stopmin = min + min1;
2468                         flags &= ~SCF_DO_SUBSTR;
2469                         if (data)
2470                             data->flags |= SCF_SEEN_ACCEPT;
2471                     }
2472                     if (data) {
2473                         if (data_fake.flags & SF_HAS_EVAL)
2474                             data->flags |= SF_HAS_EVAL;
2475                         data->whilem_c = data_fake.whilem_c;
2476                     }
2477                     if (flags & SCF_DO_STCLASS)
2478                         cl_or(pRExC_state, &accum, &this_class);
2479                 }
2480                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
2481                     min1 = 0;
2482                 if (flags & SCF_DO_SUBSTR) {
2483                     data->pos_min += min1;
2484                     data->pos_delta += max1 - min1;
2485                     if (max1 != min1 || is_inf)
2486                         data->longest = &(data->longest_float);
2487                 }
2488                 min += min1;
2489                 delta += max1 - min1;
2490                 if (flags & SCF_DO_STCLASS_OR) {
2491                     cl_or(pRExC_state, data->start_class, &accum);
2492                     if (min1) {
2493                         cl_and(data->start_class, and_withp);
2494                         flags &= ~SCF_DO_STCLASS;
2495                     }
2496                 }
2497                 else if (flags & SCF_DO_STCLASS_AND) {
2498                     if (min1) {
2499                         cl_and(data->start_class, &accum);
2500                         flags &= ~SCF_DO_STCLASS;
2501                     }
2502                     else {
2503                         /* Switch to OR mode: cache the old value of
2504                          * data->start_class */
2505                         INIT_AND_WITHP;
2506                         StructCopy(data->start_class, and_withp,
2507                                    struct regnode_charclass_class);
2508                         flags &= ~SCF_DO_STCLASS_AND;
2509                         StructCopy(&accum, data->start_class,
2510                                    struct regnode_charclass_class);
2511                         flags |= SCF_DO_STCLASS_OR;
2512                         data->start_class->flags |= ANYOF_EOS;
2513                     }
2514                 }
2515
2516                 if (PERL_ENABLE_TRIE_OPTIMISATION && OP( startbranch ) == BRANCH ) {
2517                 /* demq.
2518
2519                    Assuming this was/is a branch we are dealing with: 'scan' now
2520                    points at the item that follows the branch sequence, whatever
2521                    it is. We now start at the beginning of the sequence and look
2522                    for subsequences of
2523
2524                    BRANCH->EXACT=>x1
2525                    BRANCH->EXACT=>x2
2526                    tail
2527
2528                    which would be constructed from a pattern like /A|LIST|OF|WORDS/
2529
2530                    If we can find such a subseqence we need to turn the first
2531                    element into a trie and then add the subsequent branch exact
2532                    strings to the trie.
2533
2534                    We have two cases
2535
2536                      1. patterns where the whole set of branch can be converted.
2537
2538                      2. patterns where only a subset can be converted.
2539
2540                    In case 1 we can replace the whole set with a single regop
2541                    for the trie. In case 2 we need to keep the start and end
2542                    branchs so
2543
2544                      'BRANCH EXACT; BRANCH EXACT; BRANCH X'
2545                      becomes BRANCH TRIE; BRANCH X;
2546
2547                   There is an additional case, that being where there is a
2548                   common prefix, which gets split out into an EXACT like node
2549                   preceding the TRIE node.
2550
2551                   If x(1..n)==tail then we can do a simple trie, if not we make
2552                   a "jump" trie, such that when we match the appropriate word
2553                   we "jump" to the appopriate tail node. Essentailly we turn
2554                   a nested if into a case structure of sorts.
2555
2556                 */
2557
2558                     int made=0;
2559                     if (!re_trie_maxbuff) {
2560                         re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
2561                         if (!SvIOK(re_trie_maxbuff))
2562                             sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
2563                     }
2564                     if ( SvIV(re_trie_maxbuff)>=0  ) {
2565                         regnode *cur;
2566                         regnode *first = (regnode *)NULL;
2567                         regnode *last = (regnode *)NULL;
2568                         regnode *tail = scan;
2569                         U8 optype = 0;
2570                         U32 count=0;
2571
2572 #ifdef DEBUGGING
2573                         SV * const mysv = sv_newmortal();       /* for dumping */
2574 #endif
2575                         /* var tail is used because there may be a TAIL
2576                            regop in the way. Ie, the exacts will point to the
2577                            thing following the TAIL, but the last branch will
2578                            point at the TAIL. So we advance tail. If we
2579                            have nested (?:) we may have to move through several
2580                            tails.
2581                          */
2582
2583                         while ( OP( tail ) == TAIL ) {
2584                             /* this is the TAIL generated by (?:) */
2585                             tail = regnext( tail );
2586                         }
2587
2588
2589                         DEBUG_OPTIMISE_r({
2590                             regprop(RExC_rx, mysv, tail );
2591                             PerlIO_printf( Perl_debug_log, "%*s%s%s\n",
2592                                 (int)depth * 2 + 2, "",
2593                                 "Looking for TRIE'able sequences. Tail node is: ",
2594                                 SvPV_nolen_const( mysv )
2595                             );
2596                         });
2597
2598                         /*
2599
2600                            step through the branches, cur represents each
2601                            branch, noper is the first thing to be matched
2602                            as part of that branch and noper_next is the
2603                            regnext() of that node. if noper is an EXACT
2604                            and noper_next is the same as scan (our current
2605                            position in the regex) then the EXACT branch is
2606                            a possible optimization target. Once we have
2607                            two or more consequetive such branches we can
2608                            create a trie of the EXACT's contents and stich
2609                            it in place. If the sequence represents all of
2610                            the branches we eliminate the whole thing and
2611                            replace it with a single TRIE. If it is a
2612                            subsequence then we need to stitch it in. This
2613                            means the first branch has to remain, and needs
2614                            to be repointed at the item on the branch chain
2615                            following the last branch optimized. This could
2616                            be either a BRANCH, in which case the
2617                            subsequence is internal, or it could be the
2618                            item following the branch sequence in which
2619                            case the subsequence is at the end.
2620
2621                         */
2622
2623                         /* dont use tail as the end marker for this traverse */
2624                         for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
2625                             regnode * const noper = NEXTOPER( cur );
2626 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
2627                             regnode * const noper_next = regnext( noper );
2628 #endif
2629
2630                             DEBUG_OPTIMISE_r({
2631                                 regprop(RExC_rx, mysv, cur);
2632                                 PerlIO_printf( Perl_debug_log, "%*s- %s (%d)",
2633                                    (int)depth * 2 + 2,"", SvPV_nolen_const( mysv ), REG_NODE_NUM(cur) );
2634
2635                                 regprop(RExC_rx, mysv, noper);
2636                                 PerlIO_printf( Perl_debug_log, " -> %s",
2637                                     SvPV_nolen_const(mysv));
2638
2639                                 if ( noper_next ) {
2640                                   regprop(RExC_rx, mysv, noper_next );
2641                                   PerlIO_printf( Perl_debug_log,"\t=> %s\t",
2642                                     SvPV_nolen_const(mysv));
2643                                 }
2644                                 PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d)\n",
2645                                    REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur) );
2646                             });
2647                             if ( (((first && optype!=NOTHING) ? OP( noper ) == optype
2648                                          : PL_regkind[ OP( noper ) ] == EXACT )
2649                                   || OP(noper) == NOTHING )
2650 #ifdef NOJUMPTRIE
2651                                   && noper_next == tail
2652 #endif
2653                                   && count < U16_MAX)
2654                             {
2655                                 count++;
2656                                 if ( !first || optype == NOTHING ) {
2657                                     if (!first) first = cur;
2658                                     optype = OP( noper );
2659                                 } else {
2660                                     last = cur;
2661                                 }
2662                             } else {
2663                                 if ( last ) {
2664                                     make_trie( pRExC_state,
2665                                             startbranch, first, cur, tail, count,
2666                                             optype, depth+1 );
2667                                 }
2668                                 if ( PL_regkind[ OP( noper ) ] == EXACT
2669 #ifdef NOJUMPTRIE
2670                                      && noper_next == tail
2671 #endif
2672                                 ){
2673                                     count = 1;
2674                                     first = cur;
2675                                     optype = OP( noper );
2676                                 } else {
2677                                     count = 0;
2678                                     first = NULL;
2679                                     optype = 0;
2680                                 }
2681                                 last = NULL;
2682                             }
2683                         }
2684                         DEBUG_OPTIMISE_r({
2685                             regprop(RExC_rx, mysv, cur);
2686                             PerlIO_printf( Perl_debug_log,
2687                               "%*s- %s (%d) <SCAN FINISHED>\n", (int)depth * 2 + 2,
2688                               "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
2689
2690                         });
2691                         if ( last ) {
2692                             made= make_trie( pRExC_state, startbranch, first, scan, tail, count, optype, depth+1 );
2693 #ifdef TRIE_STUDY_OPT
2694                             if ( ((made == MADE_EXACT_TRIE &&
2695                                  startbranch == first)
2696                                  || ( first_non_open == first )) &&
2697                                  depth==0 ) {
2698                                 flags |= SCF_TRIE_RESTUDY;
2699                                 if ( startbranch == first
2700                                      && scan == tail )
2701                                 {
2702                                     RExC_seen &=~REG_TOP_LEVEL_BRANCHES;
2703                                 }
2704                             }
2705 #endif
2706                         }
2707                     }
2708
2709                 } /* do trie */
2710
2711             }
2712             else if ( code == BRANCHJ ) {  /* single branch is optimized. */
2713                 scan = NEXTOPER(NEXTOPER(scan));
2714             } else                      /* single branch is optimized. */
2715                 scan = NEXTOPER(scan);
2716             continue;
2717         } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB || OP(scan) == GOSTART) {
2718             scan_frame *newframe = NULL;
2719             I32 paren;
2720             regnode *start;
2721             regnode *end;
2722
2723             if (OP(scan) != SUSPEND) {
2724             /* set the pointer */
2725                 if (OP(scan) == GOSUB) {
2726                     paren = ARG(scan);
2727                     RExC_recurse[ARG2L(scan)] = scan;
2728                     start = RExC_open_parens[paren-1];
2729                     end   = RExC_close_parens[paren-1];
2730                 } else {
2731                     paren = 0;
2732                     start = RExC_rxi->program + 1;
2733                     end   = RExC_opend;
2734                 }
2735                 if (!recursed) {
2736                     Newxz(recursed, (((RExC_npar)>>3) +1), U8);
2737                     SAVEFREEPV(recursed);
2738                 }
2739                 if (!PAREN_TEST(recursed,paren+1)) {
2740                     PAREN_SET(recursed,paren+1);
2741                     Newx(newframe,1,scan_frame);
2742                 } else {
2743                     if (flags & SCF_DO_SUBSTR) {
2744                         scan_commit(pRExC_state,data,minlenp);
2745                         data->longest = &(data->longest_float);
2746                     }
2747                     is_inf = is_inf_internal = 1;
2748                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
2749                         cl_anything(pRExC_state, data->start_class);
2750                     flags &= ~SCF_DO_STCLASS;
2751                 }
2752             } else {
2753                 Newx(newframe,1,scan_frame);
2754                 paren = stopparen;
2755                 start = scan+2;
2756                 end = regnext(scan);
2757             }
2758             if (newframe) {
2759                 assert(start);
2760                 assert(end);
2761                 SAVEFREEPV(newframe);
2762                 newframe->next = regnext(scan);
2763                 newframe->last = last;
2764                 newframe->stop = stopparen;
2765                 newframe->prev = frame;
2766
2767                 frame = newframe;
2768                 scan =  start;
2769                 stopparen = paren;
2770                 last = end;
2771
2772                 continue;
2773             }
2774         }
2775         else if (OP(scan) == EXACT) {
2776             I32 l = STR_LEN(scan);
2777             UV uc;
2778             if (UTF) {
2779                 const U8 * const s = (U8*)STRING(scan);
2780                 l = utf8_length(s, s + l);
2781                 uc = utf8_to_uvchr(s, NULL);
2782             } else {
2783                 uc = *((U8*)STRING(scan));
2784             }
2785             min += l;
2786             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
2787                 /* The code below prefers earlier match for fixed
2788                    offset, later match for variable offset.  */
2789                 if (data->last_end == -1) { /* Update the start info. */
2790                     data->last_start_min = data->pos_min;
2791                     data->last_start_max = is_inf
2792                         ? I32_MAX : data->pos_min + data->pos_delta;
2793                 }
2794                 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
2795                 if (UTF)
2796                     SvUTF8_on(data->last_found);
2797                 {
2798                     SV * const sv = data->last_found;
2799                     MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
2800                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
2801                     if (mg && mg->mg_len >= 0)
2802                         mg->mg_len += utf8_length((U8*)STRING(scan),
2803                                                   (U8*)STRING(scan)+STR_LEN(scan));
2804                 }
2805                 data->last_end = data->pos_min + l;
2806                 data->pos_min += l; /* As in the first entry. */
2807                 data->flags &= ~SF_BEFORE_EOL;
2808             }
2809             if (flags & SCF_DO_STCLASS_AND) {
2810                 /* Check whether it is compatible with what we know already! */
2811                 int compat = 1;
2812
2813                 if (uc >= 0x100 ||
2814                     (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
2815                     && !ANYOF_BITMAP_TEST(data->start_class, uc)
2816                     && (!(data->start_class->flags & ANYOF_FOLD)
2817                         || !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc])))
2818                     )
2819                     compat = 0;
2820                 ANYOF_CLASS_ZERO(data->start_class);
2821                 ANYOF_BITMAP_ZERO(data->start_class);
2822                 if (compat)
2823                     ANYOF_BITMAP_SET(data->start_class, uc);
2824                 data->start_class->flags &= ~ANYOF_EOS;
2825                 if (uc < 0x100)
2826                   data->start_class->flags &= ~ANYOF_UNICODE_ALL;
2827             }
2828             else if (flags & SCF_DO_STCLASS_OR) {
2829                 /* false positive possible if the class is case-folded */
2830                 if (uc < 0x100)
2831                     ANYOF_BITMAP_SET(data->start_class, uc);
2832                 else
2833                     data->start_class->flags |= ANYOF_UNICODE_ALL;
2834                 data->start_class->flags &= ~ANYOF_EOS;
2835                 cl_and(data->start_class, and_withp);
2836             }
2837             flags &= ~SCF_DO_STCLASS;
2838         }
2839         else if (PL_regkind[OP(scan)] == EXACT) { /* But OP != EXACT! */
2840             I32 l = STR_LEN(scan);
2841             UV uc = *((U8*)STRING(scan));
2842
2843             /* Search for fixed substrings supports EXACT only. */
2844             if (flags & SCF_DO_SUBSTR) {
2845                 assert(data);
2846                 scan_commit(pRExC_state, data, minlenp);
2847             }
2848             if (UTF) {
2849                 const U8 * const s = (U8 *)STRING(scan);
2850                 l = utf8_length(s, s + l);
2851                 uc = utf8_to_uvchr(s, NULL);
2852             }
2853             min += l;
2854             if (flags & SCF_DO_SUBSTR)
2855                 data->pos_min += l;
2856             if (flags & SCF_DO_STCLASS_AND) {
2857                 /* Check whether it is compatible with what we know already! */
2858                 int compat = 1;
2859
2860                 if (uc >= 0x100 ||
2861                     (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
2862                     && !ANYOF_BITMAP_TEST(data->start_class, uc)
2863                      && !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc])))
2864                     compat = 0;
2865                 ANYOF_CLASS_ZERO(data->start_class);
2866                 ANYOF_BITMAP_ZERO(data->start_class);
2867                 if (compat) {
2868                     ANYOF_BITMAP_SET(data->start_class, uc);
2869                     data->start_class->flags &= ~ANYOF_EOS;
2870                     data->start_class->flags |= ANYOF_FOLD;
2871                     if (OP(scan) == EXACTFL)
2872                         data->start_class->flags |= ANYOF_LOCALE;
2873                 }
2874             }
2875             else if (flags & SCF_DO_STCLASS_OR) {
2876                 if (data->start_class->flags & ANYOF_FOLD) {
2877                     /* false positive possible if the class is case-folded.
2878                        Assume that the locale settings are the same... */
2879                     if (uc < 0x100)
2880                         ANYOF_BITMAP_SET(data->start_class, uc);
2881                     data->start_class->flags &= ~ANYOF_EOS;
2882                 }
2883                 cl_and(data->start_class, and_withp);
2884             }
2885             flags &= ~SCF_DO_STCLASS;
2886         }
2887         else if (strchr((const char*)PL_varies,OP(scan))) {
2888             I32 mincount, maxcount, minnext, deltanext, fl = 0;
2889             I32 f = flags, pos_before = 0;
2890             regnode * const oscan = scan;
2891             struct regnode_charclass_class this_class;
2892             struct regnode_charclass_class *oclass = NULL;
2893             I32 next_is_eval = 0;
2894
2895             switch (PL_regkind[OP(scan)]) {
2896             case WHILEM:                /* End of (?:...)* . */
2897                 scan = NEXTOPER(scan);
2898                 goto finish;
2899             case PLUS:
2900                 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
2901                     next = NEXTOPER(scan);
2902                     if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
2903                         mincount = 1;
2904                         maxcount = REG_INFTY;
2905                         next = regnext(scan);
2906                         scan = NEXTOPER(scan);
2907                         goto do_curly;
2908                     }
2909                 }
2910                 if (flags & SCF_DO_SUBSTR)
2911                     data->pos_min++;
2912                 min++;
2913                 /* Fall through. */
2914             case STAR:
2915                 if (flags & SCF_DO_STCLASS) {
2916                     mincount = 0;
2917                     maxcount = REG_INFTY;
2918                     next = regnext(scan);
2919                     scan = NEXTOPER(scan);
2920                     goto do_curly;
2921                 }
2922                 is_inf = is_inf_internal = 1;
2923                 scan = regnext(scan);
2924                 if (flags & SCF_DO_SUBSTR) {
2925                     scan_commit(pRExC_state, data, minlenp); /* Cannot extend fixed substrings */
2926                     data->longest = &(data->longest_float);
2927                 }
2928                 goto optimize_curly_tail;
2929             case CURLY:
2930                 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
2931                     && (scan->flags == stopparen))
2932                 {
2933                     mincount = 1;
2934                     maxcount = 1;
2935                 } else {
2936                     mincount = ARG1(scan);
2937                     maxcount = ARG2(scan);
2938                 }
2939                 next = regnext(scan);
2940                 if (OP(scan) == CURLYX) {
2941                     I32 lp = (data ? *(data->last_closep) : 0);
2942                     scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
2943                 }
2944                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
2945                 next_is_eval = (OP(scan) == EVAL);
2946               do_curly:
2947                 if (flags & SCF_DO_SUBSTR) {
2948                     if (mincount == 0) scan_commit(pRExC_state,data,minlenp); /* Cannot extend fixed substrings */
2949                     pos_before = data->pos_min;
2950                 }
2951                 if (data) {
2952                     fl = data->flags;
2953                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
2954                     if (is_inf)
2955                         data->flags |= SF_IS_INF;
2956                 }
2957                 if (flags & SCF_DO_STCLASS) {
2958                     cl_init(pRExC_state, &this_class);
2959                     oclass = data->start_class;
2960                     data->start_class = &this_class;
2961                     f |= SCF_DO_STCLASS_AND;
2962                     f &= ~SCF_DO_STCLASS_OR;
2963                 }
2964                 /* These are the cases when once a subexpression
2965                    fails at a particular position, it cannot succeed
2966                    even after backtracking at the enclosing scope.
2967
2968                    XXXX what if minimal match and we are at the
2969                         initial run of {n,m}? */
2970                 if ((mincount != maxcount - 1) && (maxcount != REG_INFTY))
2971                     f &= ~SCF_WHILEM_VISITED_POS;
2972
2973                 /* This will finish on WHILEM, setting scan, or on NULL: */
2974                 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
2975                                       last, data, stopparen, recursed, NULL,
2976                                       (mincount == 0
2977                                         ? (f & ~SCF_DO_SUBSTR) : f),depth+1);
2978
2979                 if (flags & SCF_DO_STCLASS)
2980                     data->start_class = oclass;
2981                 if (mincount == 0 || minnext == 0) {
2982                     if (flags & SCF_DO_STCLASS_OR) {
2983                         cl_or(pRExC_state, data->start_class, &this_class);
2984                     }
2985                     else if (flags & SCF_DO_STCLASS_AND) {
2986                         /* Switch to OR mode: cache the old value of
2987                          * data->start_class */
2988                         INIT_AND_WITHP;
2989                         StructCopy(data->start_class, and_withp,
2990                                    struct regnode_charclass_class);
2991                         flags &= ~SCF_DO_STCLASS_AND;
2992                         StructCopy(&this_class, data->start_class,
2993                                    struct regnode_charclass_class);
2994                         flags |= SCF_DO_STCLASS_OR;
2995                         data->start_class->flags |= ANYOF_EOS;
2996                     }
2997                 } else {                /* Non-zero len */
2998                     if (flags & SCF_DO_STCLASS_OR) {
2999                         cl_or(pRExC_state, data->start_class, &this_class);
3000                         cl_and(data->start_class, and_withp);
3001                     }
3002                     else if (flags & SCF_DO_STCLASS_AND)
3003                         cl_and(data->start_class, &this_class);
3004                     flags &= ~SCF_DO_STCLASS;
3005                 }
3006                 if (!scan)              /* It was not CURLYX, but CURLY. */
3007                     scan = next;
3008                 if ( /* ? quantifier ok, except for (?{ ... }) */
3009                     (next_is_eval || !(mincount == 0 && maxcount == 1))
3010                     && (minnext == 0) && (deltanext == 0)
3011                     && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
3012                     && maxcount <= REG_INFTY/3 /* Complement check for big count */
3013                     && ckWARN(WARN_REGEXP))
3014                 {
3015                     vWARN(RExC_parse,
3016                           "Quantifier unexpected on zero-length expression");
3017                 }
3018
3019                 min += minnext * mincount;
3020                 is_inf_internal |= ((maxcount == REG_INFTY
3021                                      && (minnext + deltanext) > 0)
3022                                     || deltanext == I32_MAX);
3023                 is_inf |= is_inf_internal;
3024                 delta += (minnext + deltanext) * maxcount - minnext * mincount;
3025
3026                 /* Try powerful optimization CURLYX => CURLYN. */
3027                 if (  OP(oscan) == CURLYX && data
3028                       && data->flags & SF_IN_PAR
3029                       && !(data->flags & SF_HAS_EVAL)
3030                       && !deltanext && minnext == 1 ) {
3031                     /* Try to optimize to CURLYN.  */
3032                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
3033                     regnode * const nxt1 = nxt;
3034 #ifdef DEBUGGING
3035                     regnode *nxt2;
3036 #endif
3037
3038                     /* Skip open. */
3039                     nxt = regnext(nxt);
3040                     if (!strchr((const char*)PL_simple,OP(nxt))
3041                         && !(PL_regkind[OP(nxt)] == EXACT
3042                              && STR_LEN(nxt) == 1))
3043                         goto nogo;
3044 #ifdef DEBUGGING
3045                     nxt2 = nxt;
3046 #endif
3047                     nxt = regnext(nxt);
3048                     if (OP(nxt) != CLOSE)
3049                         goto nogo;
3050                     if (RExC_open_parens) {
3051                         RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3052                         RExC_close_parens[ARG(nxt1)-1]=nxt+2; /*close->while*/
3053                     }
3054                     /* Now we know that nxt2 is the only contents: */
3055                     oscan->flags = (U8)ARG(nxt);
3056                     OP(oscan) = CURLYN;
3057                     OP(nxt1) = NOTHING; /* was OPEN. */
3058
3059 #ifdef DEBUGGING
3060                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3061                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistancy. */
3062                     NEXT_OFF(nxt2) = 0; /* just for consistancy with CURLY. */
3063                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
3064                     OP(nxt + 1) = OPTIMIZED; /* was count. */
3065                     NEXT_OFF(nxt+ 1) = 0; /* just for consistancy. */
3066 #endif
3067                 }
3068               nogo:
3069
3070                 /* Try optimization CURLYX => CURLYM. */
3071                 if (  OP(oscan) == CURLYX && data
3072                       && !(data->flags & SF_HAS_PAR)
3073                       && !(data->flags & SF_HAS_EVAL)
3074                       && !deltanext     /* atom is fixed width */
3075                       && minnext != 0   /* CURLYM can't handle zero width */
3076                 ) {
3077                     /* XXXX How to optimize if data == 0? */
3078                     /* Optimize to a simpler form.  */
3079                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
3080                     regnode *nxt2;
3081
3082                     OP(oscan) = CURLYM;
3083                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
3084                             && (OP(nxt2) != WHILEM))
3085                         nxt = nxt2;
3086                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
3087                     /* Need to optimize away parenths. */
3088                     if (data->flags & SF_IN_PAR) {
3089                         /* Set the parenth number.  */
3090                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
3091
3092                         if (OP(nxt) != CLOSE)
3093                             FAIL("Panic opt close");
3094                         oscan->flags = (U8)ARG(nxt);
3095                         if (RExC_open_parens) {
3096                             RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3097                             RExC_close_parens[ARG(nxt1)-1]=nxt2+1; /*close->NOTHING*/
3098                         }
3099                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
3100                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
3101
3102 #ifdef DEBUGGING
3103                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3104                         OP(nxt + 1) = OPTIMIZED; /* was count. */
3105                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistancy. */
3106                         NEXT_OFF(nxt + 1) = 0; /* just for consistancy. */
3107 #endif
3108 #if 0
3109                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
3110                             regnode *nnxt = regnext(nxt1);
3111
3112                             if (nnxt == nxt) {
3113                                 if (reg_off_by_arg[OP(nxt1)])
3114                                     ARG_SET(nxt1, nxt2 - nxt1);
3115                                 else if (nxt2 - nxt1 < U16_MAX)
3116                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
3117                                 else
3118                                     OP(nxt) = NOTHING;  /* Cannot beautify */
3119                             }
3120                             nxt1 = nnxt;
3121                         }
3122 #endif
3123                         /* Optimize again: */
3124                         study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
3125                                     NULL, stopparen, recursed, NULL, 0,depth+1);
3126                     }
3127                     else
3128                         oscan->flags = 0;
3129                 }
3130                 else if ((OP(oscan) == CURLYX)
3131                          && (flags & SCF_WHILEM_VISITED_POS)
3132                          /* See the comment on a similar expression above.
3133                             However, this time it not a subexpression
3134                             we care about, but the expression itself. */
3135                          && (maxcount == REG_INFTY)
3136                          && data && ++data->whilem_c < 16) {
3137                     /* This stays as CURLYX, we can put the count/of pair. */
3138                     /* Find WHILEM (as in regexec.c) */
3139                     regnode *nxt = oscan + NEXT_OFF(oscan);
3140
3141                     if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
3142                         nxt += ARG(nxt);
3143                     PREVOPER(nxt)->flags = (U8)(data->whilem_c
3144                         | (RExC_whilem_seen << 4)); /* On WHILEM */
3145                 }
3146                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
3147                     pars++;
3148                 if (flags & SCF_DO_SUBSTR) {
3149                     SV *last_str = NULL;
3150                     int counted = mincount != 0;
3151
3152                     if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
3153 #if defined(SPARC64_GCC_WORKAROUND)
3154                         I32 b = 0;
3155                         STRLEN l = 0;
3156                         const char *s = NULL;
3157                         I32 old = 0;
3158
3159                         if (pos_before >= data->last_start_min)
3160                             b = pos_before;
3161                         else
3162                             b = data->last_start_min;
3163
3164                         l = 0;
3165                         s = SvPV_const(data->last_found, l);
3166                         old = b - data->last_start_min;
3167
3168 #else
3169                         I32 b = pos_before >= data->last_start_min
3170                             ? pos_before : data->last_start_min;
3171                         STRLEN l;
3172                         const char * const s = SvPV_const(data->last_found, l);
3173                         I32 old = b - data->last_start_min;
3174 #endif
3175
3176                         if (UTF)
3177                             old = utf8_hop((U8*)s, old) - (U8*)s;
3178
3179                         l -= old;
3180                         /* Get the added string: */
3181                         last_str = newSVpvn(s  + old, l);
3182                         if (UTF)
3183                             SvUTF8_on(last_str);
3184                         if (deltanext == 0 && pos_before == b) {
3185                             /* What was added is a constant string */
3186                             if (mincount > 1) {
3187                                 SvGROW(last_str, (mincount * l) + 1);
3188                                 repeatcpy(SvPVX(last_str) + l,
3189                                           SvPVX_const(last_str), l, mincount - 1);
3190                                 SvCUR_set(last_str, SvCUR(last_str) * mincount);
3191                                 /* Add additional parts. */
3192                                 SvCUR_set(data->last_found,
3193                                           SvCUR(data->last_found) - l);
3194                                 sv_catsv(data->last_found, last_str);
3195                                 {
3196                                     SV * sv = data->last_found;
3197                                     MAGIC *mg =
3198                                         SvUTF8(sv) && SvMAGICAL(sv) ?
3199                                         mg_find(sv, PERL_MAGIC_utf8) : NULL;
3200                                     if (mg && mg->mg_len >= 0)
3201                                         mg->mg_len += CHR_SVLEN(last_str);
3202                                 }
3203                                 data->last_end += l * (mincount - 1);
3204                             }
3205                         } else {
3206                             /* start offset must point into the last copy */
3207                             data->last_start_min += minnext * (mincount - 1);
3208                             data->last_start_max += is_inf ? I32_MAX
3209                                 : (maxcount - 1) * (minnext + data->pos_delta);
3210                         }
3211                     }
3212                     /* It is counted once already... */
3213                     data->pos_min += minnext * (mincount - counted);
3214                     data->pos_delta += - counted * deltanext +
3215                         (minnext + deltanext) * maxcount - minnext * mincount;
3216                     if (mincount != maxcount) {
3217                          /* Cannot extend fixed substrings found inside
3218                             the group.  */
3219                         scan_commit(pRExC_state,data,minlenp);
3220                         if (mincount && last_str) {
3221                             SV * const sv = data->last_found;
3222                             MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3223                                 mg_find(sv, PERL_MAGIC_utf8) : NULL;
3224
3225                             if (mg)
3226                                 mg->mg_len = -1;
3227                             sv_setsv(sv, last_str);
3228                             data->last_end = data->pos_min;
3229                             data->last_start_min =
3230                                 data->pos_min - CHR_SVLEN(last_str);
3231                             data->last_start_max = is_inf
3232                                 ? I32_MAX
3233                                 : data->pos_min + data->pos_delta
3234                                 - CHR_SVLEN(last_str);
3235                         }
3236                         data->longest = &(data->longest_float);
3237                     }
3238                     SvREFCNT_dec(last_str);
3239                 }
3240                 if (data && (fl & SF_HAS_EVAL))
3241                     data->flags |= SF_HAS_EVAL;
3242               optimize_curly_tail:
3243                 if (OP(oscan) != CURLYX) {
3244                     while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
3245                            && NEXT_OFF(next))
3246                         NEXT_OFF(oscan) += NEXT_OFF(next);
3247                 }
3248                 continue;
3249             default:                    /* REF and CLUMP only? */
3250                 if (flags & SCF_DO_SUBSTR) {
3251                     scan_commit(pRExC_state,data,minlenp);      /* Cannot expect anything... */
3252                     data->longest = &(data->longest_float);
3253                 }
3254                 is_inf = is_inf_internal = 1;
3255                 if (flags & SCF_DO_STCLASS_OR)
3256                     cl_anything(pRExC_state, data->start_class);
3257                 flags &= ~SCF_DO_STCLASS;
3258                 break;
3259             }
3260         }
3261         else if (strchr((const char*)PL_simple,OP(scan))) {
3262             int value = 0;
3263
3264             if (flags & SCF_DO_SUBSTR) {
3265                 scan_commit(pRExC_state,data,minlenp);
3266                 data->pos_min++;
3267             }
3268             min++;
3269             if (flags & SCF_DO_STCLASS) {
3270                 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
3271
3272                 /* Some of the logic below assumes that switching
3273                    locale on will only add false positives. */
3274                 switch (PL_regkind[OP(scan)]) {
3275                 case SANY:
3276                 default:
3277                   do_default:
3278                     /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */
3279                     if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3280                         cl_anything(pRExC_state, data->start_class);
3281                     break;
3282                 case REG_ANY:
3283                     if (OP(scan) == SANY)
3284                         goto do_default;
3285                     if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
3286                         value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
3287                                  || (data->start_class->flags & ANYOF_CLASS));
3288                         cl_anything(pRExC_state, data->start_class);
3289                     }
3290                     if (flags & SCF_DO_STCLASS_AND || !value)
3291                         ANYOF_BITMAP_CLEAR(data->start_class,'\n');
3292                     break;
3293                 case ANYOF:
3294                     if (flags & SCF_DO_STCLASS_AND)
3295                         cl_and(data->start_class,
3296                                (struct regnode_charclass_class*)scan);
3297                     else
3298                         cl_or(pRExC_state, data->start_class,
3299                               (struct regnode_charclass_class*)scan);
3300                     break;
3301                 case ALNUM:
3302                     if (flags & SCF_DO_STCLASS_AND) {
3303                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3304                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
3305                             for (value = 0; value < 256; value++)
3306                                 if (!isALNUM(value))
3307                                     ANYOF_BITMAP_CLEAR(data->start_class, value);
3308                         }
3309                     }
3310                     else {
3311                         if (data->start_class->flags & ANYOF_LOCALE)
3312                             ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
3313                         else {
3314                             for (value = 0; value < 256; value++)
3315                                 if (isALNUM(value))
3316                                     ANYOF_BITMAP_SET(data->start_class, value);
3317                         }
3318                     }
3319                     break;
3320                 case ALNUML:
3321                     if (flags & SCF_DO_STCLASS_AND) {
3322                         if (data->start_class->flags & ANYOF_LOCALE)
3323                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
3324                     }
3325                     else {
3326                         ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
3327                         data->start_class->flags |= ANYOF_LOCALE;
3328                     }
3329                     break;
3330                 case NALNUM:
3331                     if (flags & SCF_DO_STCLASS_AND) {
3332                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3333                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
3334                             for (value = 0; value < 256; value++)
3335                                 if (isALNUM(value))
3336                                     ANYOF_BITMAP_CLEAR(data->start_class, value);
3337                         }
3338                     }
3339                     else {
3340                         if (data->start_class->flags & ANYOF_LOCALE)
3341                             ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
3342                         else {
3343                             for (value = 0; value < 256; value++)
3344                                 if (!isALNUM(value))
3345                                     ANYOF_BITMAP_SET(data->start_class, value);
3346                         }
3347                     }
3348                     break;
3349                 case NALNUML:
3350                     if (flags & SCF_DO_STCLASS_AND) {
3351                         if (data->start_class->flags & ANYOF_LOCALE)
3352                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
3353                     }
3354                     else {
3355                         data->start_class->flags |= ANYOF_LOCALE;
3356                         ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
3357                     }
3358                     break;
3359                 case SPACE:
3360                     if (flags & SCF_DO_STCLASS_AND) {
3361                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3362                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
3363                             for (value = 0; value < 256; value++)
3364                                 if (!isSPACE(value))
3365                                     ANYOF_BITMAP_CLEAR(data->start_class, value);
3366                         }
3367                     }
3368                     else {
3369                         if (data->start_class->flags & ANYOF_LOCALE)
3370                             ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
3371                         else {
3372                             for (value = 0; value < 256; value++)
3373                                 if (isSPACE(value))
3374                                     ANYOF_BITMAP_SET(data->start_class, value);
3375                         }
3376                     }
3377                     break;
3378                 case SPACEL:
3379                     if (flags & SCF_DO_STCLASS_AND) {
3380                         if (data->start_class->flags & ANYOF_LOCALE)
3381                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
3382                     }
3383                     else {
3384                         data->start_class->flags |= ANYOF_LOCALE;
3385                         ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
3386                     }
3387                     break;
3388                 case NSPACE:
3389                     if (flags & SCF_DO_STCLASS_AND) {
3390                         if (!(data->start_class->flags & ANYOF_LOCALE)) {
3391                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
3392                             for (value = 0; value < 256; value++)
3393                                 if (isSPACE(value))
3394                                     ANYOF_BITMAP_CLEAR(data->start_class, value);
3395                         }
3396                     }
3397                     else {
3398                         if (data->start_class->flags & ANYOF_LOCALE)
3399                             ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
3400                         else {
3401                             for (value = 0; value < 256; value++)
3402                                 if (!isSPACE(value))
3403                                     ANYOF_BITMAP_SET(data->start_class, value);
3404                         }
3405                     }
3406                     break;
3407                 case NSPACEL:
3408                     if (flags & SCF_DO_STCLASS_AND) {
3409                         if (data->start_class->flags & ANYOF_LOCALE) {
3410                             ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
3411                             for (value = 0; value < 256; value++)
3412                                 if (!isSPACE(value))
3413                                     ANYOF_BITMAP_CLEAR(data->start_class, value);
3414                         }
3415                     }
3416                     else {
3417                         data->start_class->flags |= ANYOF_LOCALE;
3418                         ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
3419                     }
3420                     break;
3421                 case DIGIT:
3422                     if (flags & SCF_DO_STCLASS_AND) {
3423                         ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NDIGIT);
3424                         for (value = 0; value < 256; value++)
3425                             if (!isDIGIT(value))
3426                                 ANYOF_BITMAP_CLEAR(data->start_class, value);
3427                     }
3428                     else {
3429                         if (data->start_class->flags & ANYOF_LOCALE)
3430                             ANYOF_CLASS_SET(data->start_class,ANYOF_DIGIT);
3431                         else {
3432                             for (value = 0; value < 256; value++)
3433                                 if (isDIGIT(value))
3434                                     ANYOF_BITMAP_SET(data->start_class, value);
3435                         }
3436                     }
3437                     break;
3438                 case NDIGIT:
3439                     if (flags & SCF_DO_STCLASS_AND) {
3440                         ANYOF_CLASS_CLEAR(data->start_class,ANYOF_DIGIT);
3441                         for (value = 0; value < 256; value++)
3442                             if (isDIGIT(value))
3443                                 ANYOF_BITMAP_CLEAR(data->start_class, value);
3444                     }
3445                     else {
3446                         if (data->start_class->flags & ANYOF_LOCALE)
3447                             ANYOF_CLASS_SET(data->start_class,ANYOF_NDIGIT);
3448                         else {
3449                             for (value = 0; value < 256; value++)
3450                                 if (!isDIGIT(value))
3451                                     ANYOF_BITMAP_SET(data->start_class, value);
3452                         }
3453                     }
3454                     break;
3455                 }
3456                 if (flags & SCF_DO_STCLASS_OR)
3457                     cl_and(data->start_class, and_withp);
3458                 flags &= ~SCF_DO_STCLASS;
3459             }
3460         }
3461         else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
3462             data->flags |= (OP(scan) == MEOL
3463                             ? SF_BEFORE_MEOL
3464                             : SF_BEFORE_SEOL);
3465         }
3466         else if (  PL_regkind[OP(scan)] == BRANCHJ
3467                  /* Lookbehind, or need to calculate parens/evals/stclass: */
3468                    && (scan->flags || data || (flags & SCF_DO_STCLASS))
3469                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
3470             if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY
3471                 || OP(scan) == UNLESSM )
3472             {
3473                 /* Negative Lookahead/lookbehind
3474                    In this case we can't do fixed string optimisation.
3475                 */
3476
3477                 I32 deltanext, minnext, fake = 0;
3478                 regnode *nscan;
3479                 struct regnode_charclass_class intrnl;
3480                 int f = 0;
3481
3482                 data_fake.flags = 0;
3483                 if (data) {
3484                     data_fake.whilem_c = data->whilem_c;
3485                     data_fake.last_closep = data->last_closep;
3486                 }
3487                 else
3488                     data_fake.last_closep = &fake;
3489                 data_fake.pos_delta = delta;
3490                 if ( flags & SCF_DO_STCLASS && !scan->flags
3491                      && OP(scan) == IFMATCH ) { /* Lookahead */
3492                     cl_init(pRExC_state, &intrnl);
3493                     data_fake.start_class = &intrnl;
3494                     f |= SCF_DO_STCLASS_AND;
3495                 }
3496                 if (flags & SCF_WHILEM_VISITED_POS)
3497                     f |= SCF_WHILEM_VISITED_POS;
3498                 next = regnext(scan);
3499                 nscan = NEXTOPER(NEXTOPER(scan));
3500                 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext,
3501                     last, &data_fake, stopparen, recursed, NULL, f, depth+1);
3502                 if (scan->flags) {
3503                     if (deltanext) {
3504                         FAIL("Variable length lookbehind not implemented");
3505                     }
3506                     else if (minnext > (I32)U8_MAX) {
3507                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
3508                     }
3509                     scan->flags = (U8)minnext;
3510                 }
3511                 if (data) {
3512                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3513                         pars++;
3514                     if (data_fake.flags & SF_HAS_EVAL)
3515                         data->flags |= SF_HAS_EVAL;
3516                     data->whilem_c = data_fake.whilem_c;
3517                 }
3518                 if (f & SCF_DO_STCLASS_AND) {
3519                     const int was = (data->start_class->flags & ANYOF_EOS);
3520
3521                     cl_and(data->start_class, &intrnl);
3522                     if (was)
3523                         data->start_class->flags |= ANYOF_EOS;
3524                 }
3525             }
3526 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
3527             else {
3528                 /* Positive Lookahead/lookbehind
3529                    In this case we can do fixed string optimisation,
3530                    but we must be careful about it. Note in the case of
3531                    lookbehind the positions will be offset by the minimum
3532                    length of the pattern, something we won't know about
3533                    until after the recurse.
3534                 */
3535                 I32 deltanext, fake = 0;
3536                 regnode *nscan;
3537                 struct regnode_charclass_class intrnl;
3538                 int f = 0;
3539                 /* We use SAVEFREEPV so that when the full compile
3540                     is finished perl will clean up the allocated
3541                     minlens when its all done. This was we don't
3542                     have to worry about freeing them when we know
3543                     they wont be used, which would be a pain.
3544                  */
3545                 I32 *minnextp;
3546                 Newx( minnextp, 1, I32 );
3547                 SAVEFREEPV(minnextp);
3548
3549                 if (data) {
3550                     StructCopy(data, &data_fake, scan_data_t);
3551                     if ((flags & SCF_DO_SUBSTR) && data->last_found) {
3552                         f |= SCF_DO_SUBSTR;
3553                         if (scan->flags)
3554                             scan_commit(pRExC_state, &data_fake,minlenp);
3555                         data_fake.last_found=newSVsv(data->last_found);
3556                     }
3557                 }
3558                 else
3559                     data_fake.last_closep = &fake;
3560                 data_fake.flags = 0;
3561                 data_fake.pos_delta = delta;
3562                 if (is_inf)
3563                     data_fake.flags |= SF_IS_INF;
3564                 if ( flags & SCF_DO_STCLASS && !scan->flags
3565                      && OP(scan) == IFMATCH ) { /* Lookahead */
3566                     cl_init(pRExC_state, &intrnl);
3567                     data_fake.start_class = &intrnl;
3568                     f |= SCF_DO_STCLASS_AND;
3569                 }
3570                 if (flags & SCF_WHILEM_VISITED_POS)
3571                     f |= SCF_WHILEM_VISITED_POS;
3572                 next = regnext(scan);
3573                 nscan = NEXTOPER(NEXTOPER(scan));
3574
3575                 *minnextp = study_chunk(pRExC_state, &nscan, minnextp, &deltanext,
3576                     last, &data_fake, stopparen, recursed, NULL, f,depth+1);
3577                 if (scan->flags) {
3578                     if (deltanext) {
3579                         FAIL("Variable length lookbehind not implemented");
3580                     }
3581                     else if (*minnextp > (I32)U8_MAX) {
3582                         FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
3583                     }
3584                     scan->flags = (U8)*minnextp;
3585                 }
3586
3587                 *minnextp += min;
3588
3589                 if (f & SCF_DO_STCLASS_AND) {
3590                     const int was = (data->start_class->flags & ANYOF_EOS);
3591
3592                     cl_and(data->start_class, &intrnl);
3593                     if (was)
3594                         data->start_class->flags |= ANYOF_EOS;
3595                 }
3596                 if (data) {
3597                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3598                         pars++;
3599                     if (data_fake.flags & SF_HAS_EVAL)
3600                         data->flags |= SF_HAS_EVAL;
3601                     data->whilem_c = data_fake.whilem_c;
3602                     if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
3603                         if (RExC_rx->minlen<*minnextp)
3604                             RExC_rx->minlen=*minnextp;
3605                         scan_commit(pRExC_state, &data_fake, minnextp);
3606                         SvREFCNT_dec(data_fake.last_found);
3607
3608                         if ( data_fake.minlen_fixed != minlenp )
3609                         {
3610                             data->offset_fixed= data_fake.offset_fixed;
3611                             data->minlen_fixed= data_fake.minlen_fixed;
3612                             data->lookbehind_fixed+= scan->flags;
3613                         }
3614                         if ( data_fake.minlen_float != minlenp )
3615                         {
3616                             data->minlen_float= data_fake.minlen_float;
3617                             data->offset_float_min=data_fake.offset_float_min;
3618                             data->offset_float_max=data_fake.offset_float_max;
3619                             data->lookbehind_float+= scan->flags;
3620                         }
3621                     }
3622                 }
3623
3624
3625             }
3626 #endif
3627         }
3628         else if (OP(scan) == OPEN) {
3629             if (stopparen != (I32)ARG(scan))
3630                 pars++;
3631         }
3632         else if (OP(scan) == CLOSE) {
3633             if (stopparen == (I32)ARG(scan)) {
3634                 break;
3635             }
3636             if ((I32)ARG(scan) == is_par) {
3637                 next = regnext(scan);
3638
3639                 if ( next && (OP(next) != WHILEM) && next < last)
3640                     is_par = 0;         /* Disable optimization */
3641             }
3642             if (data)
3643                 *(data->last_closep) = ARG(scan);
3644         }
3645         else if (OP(scan) == EVAL) {
3646                 if (data)
3647                     data->flags |= SF_HAS_EVAL;
3648         }
3649         else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
3650             if (flags & SCF_DO_SUBSTR) {
3651                 scan_commit(pRExC_state,data,minlenp);
3652                 flags &= ~SCF_DO_SUBSTR;
3653             }
3654             if (data && OP(scan)==ACCEPT) {
3655                 data->flags |= SCF_SEEN_ACCEPT;
3656                 if (stopmin > min)
3657                     stopmin = min;
3658             }
3659         }
3660         else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
3661         {
3662                 if (flags & SCF_DO_SUBSTR) {
3663                     scan_commit(pRExC_state,data,minlenp);
3664                     data->longest = &(data->longest_float);
3665                 }
3666                 is_inf = is_inf_internal = 1;
3667                 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3668                     cl_anything(pRExC_state, data->start_class);
3669                 flags &= ~SCF_DO_STCLASS;
3670         }
3671         else if (OP(scan) == GPOS) {
3672             if (!(RExC_rx->extflags & RXf_GPOS_FLOAT) &&
3673                 !(delta || is_inf || (data && data->pos_delta)))
3674             {
3675                 if (!(RExC_rx->extflags & RXf_ANCH) && (flags & SCF_DO_SUBSTR))
3676                     RExC_rx->extflags |= RXf_ANCH_GPOS;
3677                 if (RExC_rx->gofs < (U32)min)
3678                     RExC_rx->gofs = min;
3679             } else {
3680                 RExC_rx->extflags |= RXf_GPOS_FLOAT;
3681                 RExC_rx->gofs = 0;
3682             }
3683         }
3684 #ifdef TRIE_STUDY_OPT
3685 #ifdef FULL_TRIE_STUDY
3686         else if (PL_regkind[OP(scan)] == TRIE) {
3687             /* NOTE - There is similar code to this block above for handling
3688                BRANCH nodes on the initial study.  If you change stuff here
3689                check there too. */
3690             regnode *trie_node= scan;
3691             regnode *tail= regnext(scan);
3692             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
3693             I32 max1 = 0, min1 = I32_MAX;
3694             struct regnode_charclass_class accum;
3695
3696             if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
3697                 scan_commit(pRExC_state, data,minlenp); /* Cannot merge strings after this. */
3698             if (flags & SCF_DO_STCLASS)
3699                 cl_init_zero(pRExC_state, &accum);
3700
3701             if (!trie->jump) {
3702                 min1= trie->minlen;
3703                 max1= trie->maxlen;
3704             } else {
3705                 const regnode *nextbranch= NULL;
3706                 U32 word;
3707
3708                 for ( word=1 ; word <= trie->wordcount ; word++)
3709                 {
3710                     I32 deltanext=0, minnext=0, f = 0, fake;
3711                     struct regnode_charclass_class this_class;
3712
3713                     data_fake.flags = 0;
3714                     if (data) {
3715                         data_fake.whilem_c = data->whilem_c;
3716                         data_fake.last_closep = data->last_closep;
3717                     }
3718                     else
3719                         data_fake.last_closep = &fake;
3720                     data_fake.pos_delta = delta;
3721                     if (flags & SCF_DO_STCLASS) {
3722                         cl_init(pRExC_state, &this_class);
3723                         data_fake.start_class = &this_class;
3724                         f = SCF_DO_STCLASS_AND;
3725                     }
3726                     if (flags & SCF_WHILEM_VISITED_POS)
3727                         f |= SCF_WHILEM_VISITED_POS;
3728
3729                     if (trie->jump[word]) {
3730                         if (!nextbranch)
3731                             nextbranch = trie_node + trie->jump[0];
3732                         scan= trie_node + trie->jump[word];
3733                         /* We go from the jump point to the branch that follows
3734                            it. Note this means we need the vestigal unused branches
3735                            even though they arent otherwise used.
3736                          */
3737                         minnext = study_chunk(pRExC_state, &scan, minlenp,
3738                             &deltanext, (regnode *)nextbranch, &data_fake,
3739                             stopparen, recursed, NULL, f,depth+1);
3740                     }
3741                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
3742                         nextbranch= regnext((regnode*)nextbranch);
3743
3744                     if (min1 > (I32)(minnext + trie->minlen))
3745                         min1 = minnext + trie->minlen;
3746                     if (max1 < (I32)(minnext + deltanext + trie->maxlen))
3747                         max1 = minnext + deltanext + trie->maxlen;
3748                     if (deltanext == I32_MAX)
3749                         is_inf = is_inf_internal = 1;
3750
3751                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3752                         pars++;
3753                     if (data_fake.flags & SCF_SEEN_ACCEPT) {
3754                         if ( stopmin > min + min1)
3755                             stopmin = min + min1;
3756                         flags &= ~SCF_DO_SUBSTR;
3757                         if (data)
3758                             data->flags |= SCF_SEEN_ACCEPT;
3759                     }
3760                     if (data) {
3761                         if (data_fake.flags & SF_HAS_EVAL)
3762                             data->flags |= SF_HAS_EVAL;
3763                         data->whilem_c = data_fake.whilem_c;
3764                     }
3765                     if (flags & SCF_DO_STCLASS)
3766                         cl_or(pRExC_state, &accum, &this_class);
3767                 }
3768             }
3769             if (flags & SCF_DO_SUBSTR) {
3770                 data->pos_min += min1;
3771                 data->pos_delta += max1 - min1;
3772                 if (max1 != min1 || is_inf)
3773                     data->longest = &(data->longest_float);
3774             }
3775             min += min1;
3776             delta += max1 - min1;
3777             if (flags & SCF_DO_STCLASS_OR) {
3778                 cl_or(pRExC_state, data->start_class, &accum);
3779                 if (min1) {
3780                     cl_and(data->start_class, and_withp);
3781                     flags &= ~SCF_DO_STCLASS;
3782                 }
3783             }
3784             else if (flags & SCF_DO_STCLASS_AND) {
3785                 if (min1) {
3786                     cl_and(data->start_class, &accum);
3787                     flags &= ~SCF_DO_STCLASS;
3788                 }
3789                 else {
3790                     /* Switch to OR mode: cache the old value of
3791                      * data->start_class */
3792                     INIT_AND_WITHP;
3793                     StructCopy(data->start_class, and_withp,
3794                                struct regnode_charclass_class);
3795                     flags &= ~SCF_DO_STCLASS_AND;
3796                     StructCopy(&accum, data->start_class,
3797                                struct regnode_charclass_class);
3798                     flags |= SCF_DO_STCLASS_OR;
3799                     data->start_class->flags |= ANYOF_EOS;
3800                 }
3801             }
3802             scan= tail;
3803             continue;
3804         }
3805 #else
3806         else if (PL_regkind[OP(scan)] == TRIE) {
3807             reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
3808             U8*bang=NULL;
3809
3810             min += trie->minlen;
3811             delta += (trie->maxlen - trie->minlen);
3812             flags &= ~SCF_DO_STCLASS; /* xxx */
3813             if (flags & SCF_DO_SUBSTR) {
3814                 scan_commit(pRExC_state,data,minlenp);  /* Cannot expect anything... */
3815                 data->pos_min += trie->minlen;
3816                 data->pos_delta += (trie->maxlen - trie->minlen);
3817                 if (trie->maxlen != trie->minlen)
3818                     data->longest = &(data->longest_float);
3819             }
3820             if (trie->jump) /* no more substrings -- for now /grr*/
3821                 flags &= ~SCF_DO_SUBSTR;
3822         }
3823 #endif /* old or new */
3824 #endif /* TRIE_STUDY_OPT */
3825         /* Else: zero-length, ignore. */
3826         scan = regnext(scan);
3827     }
3828     if (frame) {
3829         last = frame->last;
3830         scan = frame->next;
3831         stopparen = frame->stop;
3832         frame = frame->prev;
3833         goto fake_study_recurse;
3834     }
3835
3836   finish:
3837     assert(!frame);
3838
3839     *scanp = scan;
3840     *deltap = is_inf_internal ? I32_MAX : delta;
3841     if (flags & SCF_DO_SUBSTR && is_inf)
3842         data->pos_delta = I32_MAX - data->pos_min;
3843     if (is_par > (I32)U8_MAX)
3844         is_par = 0;
3845     if (is_par && pars==1 && data) {
3846         data->flags |= SF_IN_PAR;
3847         data->flags &= ~SF_HAS_PAR;
3848     }
3849     else if (pars && data) {
3850         data->flags |= SF_HAS_PAR;
3851         data->flags &= ~SF_IN_PAR;
3852     }
3853     if (flags & SCF_DO_STCLASS_OR)
3854         cl_and(data->start_class, and_withp);
3855     if (flags & SCF_TRIE_RESTUDY)
3856         data->flags |=  SCF_TRIE_RESTUDY;
3857
3858     DEBUG_STUDYDATA(data,depth);
3859
3860     return min < stopmin ? min : stopmin;
3861 }
3862
3863 STATIC I32
3864 S_add_data(RExC_state_t *pRExC_state, I32 n, const char *s)
3865 {
3866     if (RExC_rxi->data) {
3867         const U32 count = RExC_rxi->data->count;
3868         Renewc(RExC_rxi->data,
3869                sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
3870                char, struct reg_data);
3871         Renew(RExC_rxi->data->what, count + n, U8);
3872         RExC_rxi->data->count += n;
3873     }
3874     else {
3875         Newxc(RExC_rxi->data, sizeof(*RExC_rxi->data) + sizeof(void*) * (n - 1),
3876              char, struct reg_data);
3877         Newx(RExC_rxi->data->what, n, U8);
3878         RExC_rxi->data->count = n;
3879     }
3880     Copy(s, RExC_rxi->data->what + RExC_rxi->data->count - n, n, U8);
3881     return RExC_rxi->data->count - n;
3882 }
3883
3884 #ifndef PERL_IN_XSUB_RE
3885 void
3886 Perl_reginitcolors(pTHX)
3887 {
3888     dVAR;
3889     const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
3890     if (s) {
3891         char *t = savepv(s);
3892         int i = 0;
3893         PL_colors[0] = t;
3894         while (++i < 6) {
3895             t = strchr(t, '\t');
3896             if (t) {
3897                 *t = '\0';
3898                 PL_colors[i] = ++t;
3899             }
3900             else
3901                 PL_colors[i] = t = (char *)"";
3902         }
3903     } else {
3904         int i = 0;
3905         while (i < 6)
3906             PL_colors[i++] = (char *)"";
3907     }
3908     PL_colorset = 1;
3909 }
3910 #endif
3911
3912
3913 #ifdef TRIE_STUDY_OPT
3914 #define CHECK_RESTUDY_GOTO                                  \
3915         if (                                                \
3916               (data.flags & SCF_TRIE_RESTUDY)               \
3917               && ! restudied++                              \
3918         )     goto reStudy
3919 #else
3920 #define CHECK_RESTUDY_GOTO
3921 #endif
3922
3923 /*
3924  - pregcomp - compile a regular expression into internal code
3925  *
3926  * We can't allocate space until we know how big the compiled form will be,
3927  * but we can't compile it (and thus know how big it is) until we've got a
3928  * place to put the code.  So we cheat:  we compile it twice, once with code
3929  * generation turned off and size counting turned on, and once "for real".
3930  * This also means that we don't allocate space until we are sure that the
3931  * thing really will compile successfully, and we never have to move the
3932  * code and thus invalidate pointers into it.  (Note that it has to be in
3933  * one piece because free() must be able to free it all.) [NB: not true in perl]
3934  *
3935  * Beware that the optimization-preparation code in here knows about some
3936  * of the structure of the compiled regexp.  [I'll say.]
3937  */
3938
3939
3940
3941 #ifndef PERL_IN_XSUB_RE
3942 #define RE_ENGINE_PTR &PL_core_reg_engine
3943 #else
3944 extern const struct regexp_engine my_reg_engine;
3945 #define RE_ENGINE_PTR &my_reg_engine
3946 #endif
3947 /* these make a few things look better, to avoid indentation */
3948 #define BEGIN_BLOCK {
3949 #define END_BLOCK }
3950
3951 regexp *
3952 Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
3953 {
3954     dVAR;
3955     GET_RE_DEBUG_FLAGS_DECL;
3956     DEBUG_r(if (!PL_colorset) reginitcolors());
3957 #ifndef PERL_IN_XSUB_RE
3958     BEGIN_BLOCK
3959     /* Dispatch a request to compile a regexp to correct
3960        regexp engine. */
3961     HV * const table = GvHV(PL_hintgv);
3962     if (table) {
3963         SV **ptr= hv_fetchs(table, "regcomp", FALSE);
3964         if (ptr && SvIOK(*ptr) && SvIV(*ptr)) {
3965             const regexp_engine *eng=INT2PTR(regexp_engine*,SvIV(*ptr));
3966             DEBUG_COMPILE_r({
3967                 PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
3968                     SvIV(*ptr));
3969             });
3970             return CALLREGCOMP_ENG(eng, exp, xend, pm);
3971         }
3972     }
3973     END_BLOCK
3974 #endif
3975     BEGIN_BLOCK
3976     register regexp *r;
3977     register regexp_internal *ri;
3978     regnode *scan;
3979     regnode *first;
3980     I32 flags;
3981     I32 minlen = 0;
3982     I32 sawplus = 0;
3983     I32 sawopen = 0;
3984     scan_data_t data;
3985     RExC_state_t RExC_state;
3986     RExC_state_t * const pRExC_state = &RExC_state;
3987 #ifdef TRIE_STUDY_OPT
3988     int restudied= 0;
3989     RExC_state_t copyRExC_state;
3990 #endif
3991     if (exp == NULL)
3992         FAIL("NULL regexp argument");
3993
3994     RExC_utf8 = pm->op_pmdynflags & PMdf_CMP_UTF8;
3995
3996     RExC_precomp = exp;
3997     DEBUG_COMPILE_r({
3998         SV *dsv= sv_newmortal();
3999         RE_PV_QUOTED_DECL(s, RExC_utf8,
4000             dsv, RExC_precomp, (xend - exp), 60);
4001         PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
4002                        PL_colors[4],PL_colors[5],s);
4003     });
4004     RExC_flags = pm->op_pmflags;
4005     RExC_sawback = 0;
4006
4007     RExC_seen = 0;
4008     RExC_seen_zerolen = *exp == '^' ? -1 : 0;
4009     RExC_seen_evals = 0;
4010     RExC_extralen = 0;
4011
4012     /* First pass: determine size, legality. */
4013     RExC_parse = exp;
4014     RExC_start = exp;
4015     RExC_end = xend;
4016     RExC_naughty = 0;
4017     RExC_npar = 1;
4018     RExC_cpar = 1;
4019     RExC_nestroot = 0;
4020     RExC_size = 0L;
4021     RExC_emit = &PL_regdummy;
4022     RExC_whilem_seen = 0;
4023     RExC_charnames = NULL;
4024     RExC_open_parens = NULL;
4025     RExC_close_parens = NULL;
4026     RExC_opend = NULL;
4027     RExC_paren_names = NULL;
4028     RExC_recurse = NULL;
4029     RExC_recurse_count = 0;
4030
4031 #if 0 /* REGC() is (currently) a NOP at the first pass.
4032        * Clever compilers notice this and complain. --jhi */
4033     REGC((U8)REG_MAGIC, (char*)RExC_emit);
4034 #endif
4035     DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n"));
4036     if (reg(pRExC_state, 0, &flags,1) == NULL) {
4037         RExC_precomp = NULL;
4038         return(NULL);
4039     }
4040     DEBUG_PARSE_r({
4041         PerlIO_printf(Perl_debug_log,
4042             "Required size %"IVdf" nodes\n"
4043             "Starting second pass (creation)\n",
4044             (IV)RExC_size);
4045         RExC_lastnum=0;
4046         RExC_lastparse=NULL;
4047     });
4048     /* Small enough for pointer-storage convention?
4049        If extralen==0, this means that we will not need long jumps. */
4050     if (RExC_size >= 0x10000L && RExC_extralen)
4051         RExC_size += RExC_extralen;
4052     else
4053         RExC_extralen = 0;
4054     if (RExC_whilem_seen > 15)
4055         RExC_whilem_seen = 15;
4056
4057 #ifdef DEBUGGING
4058     /* Make room for a sentinel value at the end of the program */
4059     RExC_size++;
4060 #endif
4061
4062     /* Allocate space and zero-initialize. Note, the two step process
4063        of zeroing when in debug mode, thus anything assigned has to
4064        happen after that */
4065     Newxz(r, 1, regexp);
4066     Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
4067          char, regexp_internal);
4068     if ( r == NULL || ri == NULL )
4069         FAIL("Regexp out of space");
4070 #ifdef DEBUGGING
4071     /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
4072     Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode), char);
4073 #else
4074     /* bulk initialize base fields with 0. */
4075     Zero(ri, sizeof(regexp_internal), char);
4076 #endif
4077
4078     /* non-zero initialization begins here */
4079     RXi_SET( r, ri );
4080     r->engine= RE_ENGINE_PTR;
4081     r->refcnt = 1;
4082     r->prelen = xend - exp;
4083     r->precomp = savepvn(RExC_precomp, r->prelen);
4084     r->extflags = pm->op_pmflags & RXf_PMf_COMPILETIME;
4085     r->intflags = 0;
4086     r->nparens = RExC_npar - 1; /* set early to validate backrefs */
4087
4088     if (RExC_seen & REG_SEEN_RECURSE) {
4089         Newxz(RExC_open_parens, RExC_npar,regnode *);
4090         SAVEFREEPV(RExC_open_parens);
4091         Newxz(RExC_close_parens,RExC_npar,regnode *);
4092         SAVEFREEPV(RExC_close_parens);
4093     }
4094
4095     /* Useful during FAIL. */
4096     Newxz(ri->offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
4097     if (ri->offsets) {
4098         ri->offsets[0] = RExC_size;
4099     }
4100     DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log,
4101                           "%s %"UVuf" bytes for offset annotations.\n",
4102                           ri->offsets ? "Got" : "Couldn't get",
4103                           (UV)((2*RExC_size+1) * sizeof(U32))));
4104
4105     RExC_rx = r;
4106     RExC_rxi = ri;
4107
4108     /* Second pass: emit code. */
4109     RExC_flags = pm->op_pmflags;        /* don't let top level (?i) bleed */
4110     RExC_parse = exp;
4111     RExC_end = xend;
4112     RExC_naughty = 0;
4113     RExC_npar = 1;
4114     RExC_cpar = 1;
4115     RExC_emit_start = ri->program;
4116     RExC_emit = ri->program;
4117 #ifdef DEBUGGING
4118     /* put a sentinal on the end of the program so we can check for
4119        overwrites */
4120     ri->program[RExC_size].type = 255;
4121 #endif
4122     /* Store the count of eval-groups for security checks: */
4123     RExC_emit->next_off = (RExC_seen_evals > (I32)U16_MAX) ? U16_MAX : (U16)RExC_seen_evals;
4124     REGC((U8)REG_MAGIC, (char*) RExC_emit++);
4125     if (reg(pRExC_state, 0, &flags,1) == NULL)
4126         return(NULL);
4127
4128     /* XXXX To minimize changes to RE engine we always allocate
4129        3-units-long substrs field. */
4130     Newx(r->substrs, 1, struct reg_substr_data);
4131     if (RExC_recurse_count) {
4132         Newxz(RExC_recurse,RExC_recurse_count,regnode *);
4133         SAVEFREEPV(RExC_recurse);
4134     }
4135
4136 reStudy:
4137     r->minlen = minlen = sawplus = sawopen = 0;
4138     Zero(r->substrs, 1, struct reg_substr_data);
4139
4140 #ifdef TRIE_STUDY_OPT
4141     if ( restudied ) {
4142         U32 seen=RExC_seen;
4143         DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n"));
4144
4145         RExC_state = copyRExC_state;
4146         if (seen & REG_TOP_LEVEL_BRANCHES)
4147             RExC_seen |= REG_TOP_LEVEL_BRANCHES;
4148         else
4149             RExC_seen &= ~REG_TOP_LEVEL_BRANCHES;
4150         if (data.last_found) {
4151             SvREFCNT_dec(data.longest_fixed);
4152             SvREFCNT_dec(data.longest_float);
4153             SvREFCNT_dec(data.last_found);
4154         }
4155         StructCopy(&zero_scan_data, &data, scan_data_t);
4156     } else {
4157         StructCopy(&zero_scan_data, &data, scan_data_t);
4158         copyRExC_state = RExC_state;
4159     }
4160 #else
4161     StructCopy(&zero_scan_data, &data, scan_data_t);
4162 #endif
4163
4164     /* Dig out information for optimizations. */
4165     r->extflags = pm->op_pmflags & RXf_PMf_COMPILETIME; /* Again? */
4166     pm->op_pmflags = RExC_flags;
4167     if (UTF)
4168         r->extflags |= RXf_UTF8;        /* Unicode in it? */
4169     ri->regstclass = NULL;
4170     if (RExC_naughty >= 10)     /* Probably an expensive pattern. */
4171         r->intflags |= PREGf_NAUGHTY;
4172     scan = ri->program + 1;             /* First BRANCH. */
4173
4174     /* testing for BRANCH here tells us whether there is "must appear"
4175        data in the pattern. If there is then we can use it for optimisations */
4176     if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES)) { /*  Only one top-level choice. */
4177         I32 fake;
4178         STRLEN longest_float_length, longest_fixed_length;
4179         struct regnode_charclass_class ch_class; /* pointed to by data */
4180         int stclass_flag;
4181         I32 last_close = 0; /* pointed to by data */
4182
4183         first = scan;
4184         /* Skip introductions and multiplicators >= 1. */
4185         while ((OP(first) == OPEN && (sawopen = 1)) ||
4186                /* An OR of *one* alternative - should not happen now. */
4187             (OP(first) == BRANCH && OP(regnext(first)) != BRANCH) ||
4188             /* for now we can't handle lookbehind IFMATCH*/
4189             (OP(first) == IFMATCH && !first->flags) ||
4190             (OP(first) == PLUS) ||
4191             (OP(first) == MINMOD) ||
4192                /* An {n,m} with n>0 */
4193             (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) )
4194         {
4195
4196                 if (OP(first) == PLUS)
4197                     sawplus = 1;
4198                 else
4199                     first += regarglen[OP(first)];
4200                 if (OP(first) == IFMATCH) {
4201                     first = NEXTOPER(first);
4202                     first += EXTRA_STEP_2ARGS;
4203                 } else  /* XXX possible optimisation for /(?=)/  */
4204                     first = NEXTOPER(first);
4205         }
4206
4207         /* Starting-point info. */
4208       again:
4209         DEBUG_PEEP("first:",first,0);
4210         /* Ignore EXACT as we deal with it later. */
4211         if (PL_regkind[OP(first)] == EXACT) {
4212             if (OP(first) == EXACT)
4213                 NOOP;   /* Empty, get anchored substr later. */
4214             else if ((OP(first) == EXACTF || OP(first) == EXACTFL))
4215                 ri->regstclass = first;
4216         }
4217 #ifdef TRIE_STCLASS
4218         else if (PL_regkind[OP(first)] == TRIE &&
4219                 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0)
4220         {
4221             regnode *trie_op;
4222             /* this can happen only on restudy */
4223             if ( OP(first) == TRIE ) {
4224                 struct regnode_1 *trieop;
4225                 Newxz(trieop,1,struct regnode_1);
4226                 StructCopy(first,trieop,struct regnode_1);
4227                 trie_op=(regnode *)trieop;
4228             } else {
4229                 struct regnode_charclass *trieop;
4230                 Newxz(trieop,1,struct regnode_charclass);
4231                 StructCopy(first,trieop,struct regnode_charclass);
4232                 trie_op=(regnode *)trieop;
4233             }
4234             OP(trie_op)+=2;
4235             make_trie_failtable(pRExC_state, (regnode *)first, trie_op, 0);
4236             ri->regstclass = trie_op;
4237         }
4238 #endif
4239         else if (strchr((const char*)PL_simple,OP(first)))
4240             ri->regstclass = first;
4241         else if (PL_regkind[OP(first)] == BOUND ||
4242                  PL_regkind[OP(first)] == NBOUND)
4243             ri->regstclass = first;
4244         else if (PL_regkind[OP(first)] == BOL) {
4245             r->extflags |= (OP(first) == MBOL
4246                            ? RXf_ANCH_MBOL
4247                            : (OP(first) == SBOL
4248                               ? RXf_ANCH_SBOL
4249                               : RXf_ANCH_BOL));
4250             first = NEXTOPER(first);
4251             goto again;
4252         }
4253         else if (OP(first) == GPOS) {
4254             r->extflags |= RXf_ANCH_GPOS;
4255             first = NEXTOPER(first);
4256             goto again;
4257         }
4258         else if ((!sawopen || !RExC_sawback) &&
4259             (OP(first) == STAR &&
4260             PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
4261             !(r->extflags & RXf_ANCH) && !(RExC_seen & REG_SEEN_EVAL))
4262         {
4263             /* turn .* into ^.* with an implied $*=1 */
4264             const int type =
4265                 (OP(NEXTOPER(first)) == REG_ANY)
4266                     ? RXf_ANCH_MBOL
4267                     : RXf_ANCH_SBOL;
4268             r->extflags |= type;
4269             r->intflags |= PREGf_IMPLICIT;
4270             first = NEXTOPER(first);
4271             goto again;
4272         }
4273         if (sawplus && (!sawopen || !RExC_sawback)
4274             && !(RExC_seen & REG_SEEN_EVAL)) /* May examine pos and $& */
4275             /* x+ must match at the 1st pos of run of x's */
4276             r->intflags |= PREGf_SKIP;
4277
4278         /* Scan is after the zeroth branch, first is atomic matcher. */
4279 #ifdef TRIE_STUDY_OPT
4280         DEBUG_PARSE_r(
4281             if (!restudied)
4282                 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
4283                               (IV)(first - scan + 1))
4284         );
4285 #else
4286         DEBUG_PARSE_r(
4287             PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
4288                 (IV)(first - scan + 1))
4289         );
4290 #endif
4291
4292
4293         /*
4294         * If there's something expensive in the r.e., find the
4295         * longest literal string that must appear and make it the
4296         * regmust.  Resolve ties in favor of later strings, since
4297         * the regstart check works with the beginning of the r.e.
4298         * and avoiding duplication strengthens checking.  Not a
4299         * strong reason, but sufficient in the absence of others.
4300         * [Now we resolve ties in favor of the earlier string if
4301         * it happens that c_offset_min has been invalidated, since the
4302         * earlier string may buy us something the later one won't.]
4303         */
4304
4305         data.longest_fixed = newSVpvs("");
4306         data.longest_float = newSVpvs("");
4307         data.last_found = newSVpvs("");
4308         data.longest = &(data.longest_fixed);
4309         first = scan;
4310         if (!ri->regstclass) {
4311             cl_init(pRExC_state, &ch_class);
4312             data.start_class = &ch_class;
4313             stclass_flag = SCF_DO_STCLASS_AND;
4314         } else                          /* XXXX Check for BOUND? */
4315             stclass_flag = 0;
4316         data.last_closep = &last_close;
4317
4318         minlen = study_chunk(pRExC_state, &first, &minlen, &fake, scan + RExC_size, /* Up to end */
4319             &data, -1, NULL, NULL,
4320             SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0);
4321
4322
4323         CHECK_RESTUDY_GOTO;
4324
4325
4326         if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
4327              && data.last_start_min == 0 && data.last_end > 0
4328              && !RExC_seen_zerolen
4329              && (!(RExC_seen & REG_SEEN_GPOS) || (r->extflags & RXf_ANCH_GPOS)))
4330             r->extflags |= RXf_CHECK_ALL;
4331         scan_commit(pRExC_state, &data,&minlen);
4332         SvREFCNT_dec(data.last_found);
4333
4334         /* Note that code very similar to this but for anchored string
4335            follows immediately below, changes may need to be made to both.
4336            Be careful.
4337          */
4338         longest_float_length = CHR_SVLEN(data.longest_float);
4339         if (longest_float_length
4340             || (data.flags & SF_FL_BEFORE_EOL
4341                 && (!(data.flags & SF_FL_BEFORE_MEOL)
4342                     || (RExC_flags & RXf_PMf_MULTILINE))))
4343         {
4344             I32 t,ml;
4345
4346             if (SvCUR(data.longest_fixed)  /* ok to leave SvCUR */
4347                 && data.offset_fixed == data.offset_float_min
4348                 && SvCUR(data.longest_fixed) == SvCUR(data.longest_float))
4349                     goto remove_float;          /* As in (a)+. */
4350
4351             /* copy the information about the longest float from the reg_scan_data
4352                over to the program. */
4353             if (SvUTF8(data.longest_float)) {
4354                 r->float_utf8 = data.longest_float;
4355                 r->float_substr = NULL;
4356             } else {
4357                 r->float_substr = data.longest_float;
4358                 r->float_utf8 = NULL;
4359             }
4360             /* float_end_shift is how many chars that must be matched that
4361                follow this item. We calculate it ahead of time as once the
4362                lookbehind offset is added in we lose the ability to correctly
4363                calculate it.*/
4364             ml = data.minlen_float ? *(data.minlen_float)
4365                                    : (I32)longest_float_length;
4366             r->float_end_shift = ml - data.offset_float_min
4367                 - longest_float_length + (SvTAIL(data.longest_float) != 0)
4368                 + data.lookbehind_float;
4369             r->float_min_offset = data.offset_float_min - data.lookbehind_float;
4370             r->float_max_offset = data.offset_float_max;
4371             if (data.offset_float_max < I32_MAX) /* Don't offset infinity */
4372                 r->float_max_offset -= data.lookbehind_float;
4373
4374             t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */
4375                        && (!(data.flags & SF_FL_BEFORE_MEOL)
4376                            || (RExC_flags & RXf_PMf_MULTILINE)));
4377             fbm_compile(data.longest_float, t ? FBMcf_TAIL : 0);
4378         }
4379         else {
4380           remove_float:
4381             r->float_substr = r->float_utf8 = NULL;
4382             SvREFCNT_dec(data.longest_float);
4383             longest_float_length = 0;
4384         }
4385
4386         /* Note that code very similar to this but for floating string
4387            is immediately above, changes may need to be made to both.
4388            Be careful.
4389          */
4390         longest_fixed_length = CHR_SVLEN(data.longest_fixed);
4391         if (longest_fixed_length
4392             || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
4393                 && (!(data.flags & SF_FIX_BEFORE_MEOL)
4394                     || (RExC_flags & RXf_PMf_MULTILINE))))
4395         {
4396             I32 t,ml;
4397
4398             /* copy the information about the longest fixed
4399                from the reg_scan_data over to the program. */
4400             if (SvUTF8(data.longest_fixed)) {
4401                 r->anchored_utf8 = data.longest_fixed;
4402                 r->anchored_substr = NULL;
4403             } else {
4404                 r->anchored_substr = data.longest_fixed;
4405                 r->anchored_utf8 = NULL;
4406             }
4407             /* fixed_end_shift is how many chars that must be matched that
4408                follow this item. We calculate it ahead of time as once the
4409                lookbehind offset is added in we lose the ability to correctly
4410                calculate it.*/
4411             ml = data.minlen_fixed ? *(data.minlen_fixed)
4412                                    : (I32)longest_fixed_length;
4413             r->anchored_end_shift = ml - data.offset_fixed
4414                 - longest_fixed_length + (SvTAIL(data.longest_fixed) != 0)
4415                 + data.lookbehind_fixed;
4416             r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
4417
4418             t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */
4419                  && (!(data.flags & SF_FIX_BEFORE_MEOL)
4420                      || (RExC_flags & RXf_PMf_MULTILINE)));
4421             fbm_compile(data.longest_fixed, t ? FBMcf_TAIL : 0);
4422         }
4423         else {
4424             r->anchored_substr = r->anchored_utf8 = NULL;
4425             SvREFCNT_dec(data.longest_fixed);
4426             longest_fixed_length = 0;
4427         }
4428         if (ri->regstclass
4429             && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
4430             ri->regstclass = NULL;
4431         if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
4432             && stclass_flag
4433             && !(data.start_class->flags & ANYOF_EOS)
4434             && !cl_is_anything(data.start_class))
4435         {
4436             const I32 n = add_data(pRExC_state, 1, "f");
4437
4438             Newx(RExC_rxi->data->data[n], 1,
4439                 struct regnode_charclass_class);
4440             StructCopy(data.start_class,
4441                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
4442                        struct regnode_charclass_class);
4443             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
4444             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
4445             DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
4446                       regprop(r, sv, (regnode*)data.start_class);
4447                       PerlIO_printf(Perl_debug_log,
4448                                     "synthetic stclass \"%s\".\n",
4449                                     SvPVX_const(sv));});
4450         }
4451
4452         /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
4453         if (longest_fixed_length > longest_float_length) {
4454             r->check_end_shift = r->anchored_end_shift;
4455             r->check_substr = r->anchored_substr;
4456             r->check_utf8 = r->anchored_utf8;
4457             r->check_offset_min = r->check_offset_max = r->anchored_offset;
4458             if (r->extflags & RXf_ANCH_SINGLE)
4459                 r->extflags |= RXf_NOSCAN;
4460         }
4461         else {
4462             r->check_end_shift = r->float_end_shift;
4463             r->check_substr = r->float_substr;
4464             r->check_utf8 = r->float_utf8;
4465             r->check_offset_min = r->float_min_offset;
4466             r->check_offset_max = r->float_max_offset;
4467         }
4468         /* XXXX Currently intuiting is not compatible with ANCH_GPOS.
4469            This should be changed ASAP!  */
4470         if ((r->check_substr || r->check_utf8) && !(r->extflags & RXf_ANCH_GPOS)) {
4471             r->extflags |= RXf_USE_INTUIT;
4472             if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
4473                 r->extflags |= RXf_INTUIT_TAIL;
4474         }
4475         /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
4476         if ( (STRLEN)minlen < longest_float_length )
4477             minlen= longest_float_length;
4478         if ( (STRLEN)minlen < longest_fixed_length )
4479             minlen= longest_fixed_length;
4480         */
4481     }
4482     else {
4483         /* Several toplevels. Best we can is to set minlen. */
4484         I32 fake;
4485         struct regnode_charclass_class ch_class;
4486         I32 last_close = 0;
4487
4488         DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n"));
4489
4490         scan = ri->program + 1;
4491         cl_init(pRExC_state, &ch_class);
4492         data.start_class = &ch_class;
4493         data.last_closep = &last_close;
4494
4495
4496         minlen = study_chunk(pRExC_state, &scan, &minlen, &fake, scan + RExC_size,
4497             &data, -1, NULL, NULL, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0);
4498
4499         CHECK_RESTUDY_GOTO;
4500
4501         r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
4502                 = r->float_substr = r->float_utf8 = NULL;
4503         if (!(data.start_class->flags & ANYOF_EOS)
4504             && !cl_is_anything(data.start_class))
4505         {
4506             const I32 n = add_data(pRExC_state, 1, "f");
4507
4508             Newx(RExC_rxi->data->data[n], 1,
4509                 struct regnode_charclass_class);
4510             StructCopy(data.start_class,
4511                        (struct regnode_charclass_class*)RExC_rxi->data->data[n],
4512                        struct regnode_charclass_class);
4513             ri->regstclass = (regnode*)RExC_rxi->data->data[n];
4514             r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
4515             DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
4516                       regprop(r, sv, (regnode*)data.start_class);
4517                       PerlIO_printf(Perl_debug_log,
4518                                     "synthetic stclass \"%s\".\n",
4519                                     SvPVX_const(sv));});
4520         }
4521     }
4522
4523     /* Guard against an embedded (?=) or (?<=) with a longer minlen than
4524        the "real" pattern. */
4525     DEBUG_OPTIMISE_r({
4526         PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf"\n",
4527             minlen, r->minlen);
4528     });
4529     r->minlenret = minlen;
4530     if (r->minlen < minlen)
4531         r->minlen = minlen;
4532
4533     if (RExC_seen & REG_SEEN_GPOS)
4534         r->extflags |= RXf_GPOS_SEEN;
4535     if (RExC_seen & REG_SEEN_LOOKBEHIND)
4536         r->extflags |= RXf_LOOKBEHIND_SEEN;
4537     if (RExC_seen & REG_SEEN_EVAL)
4538         r->extflags |= RXf_EVAL_SEEN;
4539     if (RExC_seen & REG_SEEN_CANY)
4540         r->extflags |= RXf_CANY_SEEN;
4541     if (RExC_seen & REG_SEEN_VERBARG)
4542         r->intflags |= PREGf_VERBARG_SEEN;
4543     if (RExC_seen & REG_SEEN_CUTGROUP)
4544         r->intflags |= PREGf_CUTGROUP_SEEN;
4545     if (RExC_paren_names)
4546         r->paren_names = (HV*)SvREFCNT_inc(RExC_paren_names);
4547     else
4548         r->paren_names = NULL;
4549
4550     if (RExC_recurse_count) {
4551         for ( ; RExC_recurse_count ; RExC_recurse_count-- ) {
4552             const regnode *scan = RExC_recurse[RExC_recurse_count-1];
4553             ARG2L_SET( scan, RExC_open_parens[ARG(scan)-1] - scan );
4554         }
4555     }
4556     Newxz(r->startp, RExC_npar, I32);
4557     Newxz(r->endp, RExC_npar, I32);
4558     /* assume we don't need to swap parens around before we match */
4559
4560     DEBUG_DUMP_r({
4561         PerlIO_printf(Perl_debug_log,"Final program:\n");
4562         regdump(r);
4563     });
4564     DEBUG_OFFSETS_r(if (ri->offsets) {
4565         const U32 len = ri->offsets[0];
4566         U32 i;
4567         GET_RE_DEBUG_FLAGS_DECL;
4568         PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)ri->offsets[0]);
4569         for (i = 1; i <= len; i++) {
4570             if (ri->offsets[i*2-1] || ri->offsets[i*2])
4571                 PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
4572                 (UV)i, (UV)ri->offsets[i*2-1], (UV)ri->offsets[i*2]);
4573             }
4574         PerlIO_printf(Perl_debug_log, "\n");
4575     });
4576     return(r);
4577     END_BLOCK
4578 }
4579
4580 #undef CORE_ONLY_BLOCK
4581 #undef END_BLOCK
4582 #undef RE_ENGINE_PTR
4583
4584 #ifndef PERL_IN_XSUB_RE
4585 SV*
4586 Perl_reg_named_buff_sv(pTHX_ SV* namesv)
4587 {
4588     I32 parno = 0; /* no match */
4589     if (PL_curpm) {
4590         const REGEXP * const rx = PM_GETRE(PL_curpm);
4591         if (rx && rx->paren_names) {
4592             HE *he_str = hv_fetch_ent( rx->paren_names, namesv, 0, 0 );
4593             if (he_str) {
4594                 IV i;
4595                 SV* sv_dat=HeVAL(he_str);
4596                 I32 *nums=(I32*)SvPVX(sv_dat);
4597                 for ( i=0; i<SvIVX(sv_dat); i++ ) {
4598                     if ((I32)(rx->lastparen) >= nums[i] &&
4599                         rx->endp[nums[i]] != -1)
4600                     {
4601                         parno = nums[i];
4602                         break;
4603                     }
4604                 }
4605             }
4606         }
4607     }
4608     if ( !parno ) {
4609         return 0;
4610     } else {
4611         GV *gv_paren;
4612         SV *sv= sv_newmortal();
4613         Perl_sv_setpvf(aTHX_ sv, "%"IVdf,(IV)parno);
4614         gv_paren= Perl_gv_fetchsv(aTHX_ sv, GV_ADD, SVt_PVGV);
4615         return GvSVn(gv_paren);
4616     }
4617 }
4618 #endif
4619
4620 /* Scans the name of a named buffer from the pattern.
4621  * If flags is REG_RSN_RETURN_NULL returns null.
4622  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
4623  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
4624  * to the parsed name as looked up in the RExC_paren_names hash.
4625  * If there is an error throws a vFAIL().. type exception.
4626  */
4627
4628 #define REG_RSN_RETURN_NULL    0
4629 #define REG_RSN_RETURN_NAME    1
4630 #define REG_RSN_RETURN_DATA    2
4631
4632 STATIC SV*
4633 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags) {
4634     char *name_start = RExC_parse;
4635     if ( UTF ) {
4636         STRLEN numlen;
4637         while( isIDFIRST_uni(utf8n_to_uvchr((U8*)RExC_parse,
4638             RExC_end - RExC_parse, &numlen, UTF8_ALLOW_DEFAULT)))
4639         {
4640                 RExC_parse += numlen;
4641         }
4642     } else {
4643         while( isIDFIRST(*RExC_parse) )
4644             RExC_parse++;
4645     }
4646     if ( flags ) {
4647         SV* sv_name = sv_2mortal(Perl_newSVpvn(aTHX_ name_start,
4648             (int)(RExC_parse - name_start)));
4649         if (UTF)
4650             SvUTF8_on(sv_name);
4651         if ( flags == REG_RSN_RETURN_NAME)
4652             return sv_name;
4653         else if (flags==REG_RSN_RETURN_DATA) {
4654             HE *he_str = NULL;
4655             SV *sv_dat = NULL;
4656             if ( ! sv_name )      /* should not happen*/
4657                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
4658             if (RExC_paren_names)
4659                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
4660             if ( he_str )
4661                 sv_dat = HeVAL(he_str);
4662             if ( ! sv_dat )
4663                 vFAIL("Reference to nonexistent named group");
4664             return sv_dat;
4665         }
4666         else {
4667             Perl_croak(aTHX_ "panic: bad flag in reg_scan_name");
4668         }
4669         /* NOT REACHED */
4670     }
4671     return NULL;
4672 }
4673
4674 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
4675     int rem=(int)(RExC_end - RExC_parse);                       \
4676     int cut;                                                    \
4677     int num;                                                    \
4678     int iscut=0;                                                \
4679     if (rem>10) {                                               \
4680         rem=10;                                                 \
4681         iscut=1;                                                \
4682     }                                                           \
4683     cut=10-rem;                                                 \
4684     if (RExC_lastparse!=RExC_parse)                             \
4685         PerlIO_printf(Perl_debug_log," >%.*s%-*s",              \
4686             rem, RExC_parse,                                    \
4687             cut + 4,                                            \
4688             iscut ? "..." : "<"                                 \
4689         );                                                      \
4690     else                                                        \
4691         PerlIO_printf(Perl_debug_log,"%16s","");                \
4692                                                                 \
4693     if (SIZE_ONLY)                                              \
4694        num=RExC_size;                                           \
4695     else                                                        \
4696        num=REG_NODE_NUM(RExC_emit);                             \
4697     if (RExC_lastnum!=num)                                      \
4698        PerlIO_printf(Perl_debug_log,"|%4d",num);                \
4699     else                                                        \
4700        PerlIO_printf(Perl_debug_log,"|%4s","");                 \
4701     PerlIO_printf(Perl_debug_log,"|%*s%-4s",                    \
4702         (int)((depth*2)), "",                                   \
4703         (funcname)                                              \
4704     );                                                          \
4705     RExC_lastnum=num;                                           \
4706     RExC_lastparse=RExC_parse;                                  \
4707 })
4708
4709
4710
4711 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
4712     DEBUG_PARSE_MSG((funcname));                            \
4713     PerlIO_printf(Perl_debug_log,"%4s","\n");               \
4714 })
4715 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({           \
4716     DEBUG_PARSE_MSG((funcname));                            \
4717     PerlIO_printf(Perl_debug_log,fmt "\n",args);               \
4718 })
4719 /*
4720  - reg - regular expression, i.e. main body or parenthesized thing
4721  *
4722  * Caller must absorb opening parenthesis.
4723  *
4724  * Combining parenthesis handling with the base level of regular expression
4725  * is a trifle forced, but the need to tie the tails of the branches to what
4726  * follows makes it hard to avoid.
4727  */
4728 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
4729 #ifdef DEBUGGING
4730 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
4731 #else
4732 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
4733 #endif
4734
4735 /* this idea is borrowed from STR_WITH_LEN in handy.h */
4736 #define CHECK_WORD(s,v,l)  \
4737     (((sizeof(s)-1)==(l)) && (strnEQ(start_verb, (s ""), (sizeof(s)-1))))
4738
4739 STATIC regnode *
4740 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
4741     /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
4742 {
4743     dVAR;
4744     register regnode *ret;              /* Will be the head of the group. */
4745     register regnode *br;
4746     register regnode *lastbr;
4747     register regnode *ender = NULL;
4748     register I32 parno = 0;
4749     I32 flags;
4750     const I32 oregflags = RExC_flags;
4751     bool have_branch = 0;
4752     bool is_open = 0;
4753
4754     /* for (?g), (?gc), and (?o) warnings; warning
4755        about (?c) will warn about (?g) -- japhy    */
4756
4757 #define WASTED_O  0x01
4758 #define WASTED_G  0x02
4759 #define WASTED_C  0x04
4760 #define WASTED_GC (0x02|0x04)
4761     I32 wastedflags = 0x00;
4762
4763     char * parse_start = RExC_parse; /* MJD */
4764     char * const oregcomp_parse = RExC_parse;
4765
4766     GET_RE_DEBUG_FLAGS_DECL;
4767     DEBUG_PARSE("reg ");
4768
4769
4770     *flagp = 0;                         /* Tentatively. */
4771
4772
4773     /* Make an OPEN node, if parenthesized. */
4774     if (paren) {
4775         if ( *RExC_parse == '*') { /* (*VERB:ARG) */
4776             char *start_verb = RExC_parse;
4777             STRLEN verb_len = 0;
4778             char *start_arg = NULL;
4779             unsigned char op = 0;
4780             int argok = 1;
4781             int internal_argval = 0; /* internal_argval is only useful if !argok */
4782             while ( *RExC_parse && *RExC_parse != ')' ) {
4783                 if ( *RExC_parse == ':' ) {
4784                     start_arg = RExC_parse + 1;
4785                     break;
4786                 }
4787                 RExC_parse++;
4788             }
4789             ++start_verb;
4790             verb_len = RExC_parse - start_verb;
4791             if ( start_arg ) {
4792                 RExC_parse++;
4793                 while ( *RExC_parse && *RExC_parse != ')' )
4794                     RExC_parse++;
4795                 if ( *RExC_parse != ')' )
4796                     vFAIL("Unterminated verb pattern argument");
4797                 if ( RExC_parse == start_arg )
4798                     start_arg = NULL;
4799             } else {
4800                 if ( *RExC_parse != ')' )
4801                     vFAIL("Unterminated verb pattern");
4802             }
4803
4804             switch ( *start_verb ) {
4805             case 'A':  /* (*ACCEPT) */
4806                 if ( CHECK_WORD("ACCEPT",start_verb,verb_len) ) {
4807                     op = ACCEPT;
4808                     internal_argval = RExC_nestroot;
4809                 }
4810                 break;
4811             case 'C':  /* (*COMMIT) */
4812                 if ( CHECK_WORD("COMMIT",start_verb,verb_len) )
4813                     op = COMMIT;
4814                 break;
4815             case 'F':  /* (*FAIL) */
4816                 if ( verb_len==1 || CHECK_WORD("FAIL",start_verb,verb_len) ) {
4817                     op = OPFAIL;
4818                     argok = 0;
4819                 }
4820                 break;
4821             case ':':  /* (*:NAME) */
4822             case 'M':  /* (*MARK:NAME) */
4823                 if ( verb_len==0 || CHECK_WORD("MARK",start_verb,verb_len) ) {
4824                     op = MARKPOINT;
4825                     argok = -1;
4826                 }
4827                 break;
4828             case 'P':  /* (*PRUNE) */
4829                 if ( CHECK_WORD("PRUNE",start_verb,verb_len) )
4830                     op = PRUNE;
4831                 break;
4832             case 'S':   /* (*SKIP) */
4833                 if ( CHECK_WORD("SKIP",start_verb,verb_len) )
4834                     op = SKIP;
4835                 break;
4836             case 'T':  /* (*THEN) */
4837                 /* [19:06] <TimToady> :: is then */
4838                 if ( CHECK_WORD("THEN",start_verb,verb_len) ) {
4839                     op = CUTGROUP;
4840                     RExC_seen |= REG_SEEN_CUTGROUP;
4841                 }
4842                 break;
4843             }
4844             if ( ! op ) {
4845                 RExC_parse++;
4846                 vFAIL3("Unknown verb pattern '%.*s'",
4847                     verb_len, start_verb);
4848             }
4849             if ( argok ) {
4850                 if ( start_arg && internal_argval ) {
4851                     vFAIL3("Verb pattern '%.*s' may not have an argument",
4852                         verb_len, start_verb);
4853                 } else if ( argok < 0 && !start_arg ) {
4854                     vFAIL3("Verb pattern '%.*s' has a mandatory argument",
4855                         verb_len, start_verb);
4856                 } else {
4857                     ret = reganode(pRExC_state, op, internal_argval);
4858                     if ( ! internal_argval && ! SIZE_ONLY ) {
4859                         if (start_arg) {
4860                             SV *sv = newSVpvn( start_arg, RExC_parse - start_arg);
4861                             ARG(ret) = add_data( pRExC_state, 1, "S" );
4862                             RExC_rxi->data->data[ARG(ret)]=(void*)sv;
4863                             ret->flags = 0;
4864                         } else {
4865                             ret->flags = 1;
4866                         }
4867                     }
4868                 }
4869                 if (!internal_argval)
4870                     RExC_seen |= REG_SEEN_VERBARG;
4871             } else if ( start_arg ) {
4872                 vFAIL3("Verb pattern '%.*s' may not have an argument",
4873                         verb_len, start_verb);
4874             } else {
4875                 ret = reg_node(pRExC_state, op);
4876             }
4877             nextchar(pRExC_state);
4878             return ret;
4879         } else
4880         if (*RExC_parse == '?') { /* (?...) */
4881             U32 posflags = 0, negflags = 0;
4882             U32 *flagsp = &posflags;
4883             bool is_logical = 0;
4884             const char * const seqstart = RExC_parse;
4885
4886             RExC_parse++;
4887             paren = *RExC_parse++;
4888             ret = NULL;                 /* For look-ahead/behind. */
4889             switch (paren) {
4890
4891             case '<':           /* (?<...) */
4892                 if (*RExC_parse == '!')
4893                     paren = ',';
4894                 else if (*RExC_parse != '=')
4895                 {               /* (?<...>) */
4896                     char *name_start;
4897                     SV *svname;
4898                     paren= '>';
4899             case '\'':          /* (?'...') */
4900                     name_start= RExC_parse;
4901                     svname = reg_scan_name(pRExC_state,
4902                         SIZE_ONLY ?  /* reverse test from the others */
4903                         REG_RSN_RETURN_NAME :
4904                         REG_RSN_RETURN_NULL);
4905                     if (RExC_parse == name_start)
4906                         goto unknown;
4907                     if (*RExC_parse != paren)
4908                         vFAIL2("Sequence (?%c... not terminated",
4909                             paren=='>' ? '<' : paren);
4910                     if (SIZE_ONLY) {
4911                         HE *he_str;
4912                         SV *sv_dat = NULL;
4913                         if (!svname) /* shouldnt happen */
4914                             Perl_croak(aTHX_
4915                                 "panic: reg_scan_name returned NULL");
4916                         if (!RExC_paren_names) {
4917                             RExC_paren_names= newHV();
4918                             sv_2mortal((SV*)RExC_paren_names);
4919                         }
4920                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
4921                         if ( he_str )
4922                             sv_dat = HeVAL(he_str);
4923                         if ( ! sv_dat ) {
4924                             /* croak baby croak */
4925                             Perl_croak(aTHX_
4926                                 "panic: paren_name hash element allocation failed");
4927                         } else if ( SvPOK(sv_dat) ) {
4928                             IV count=SvIV(sv_dat);
4929                             I32 *pv=(I32*)SvGROW(sv_dat,SvCUR(sv_dat)+sizeof(I32)+1);
4930                             SvCUR_set(sv_dat,SvCUR(sv_dat)+sizeof(I32));
4931                             pv[count]=RExC_npar;
4932                             SvIVX(sv_dat)++;
4933                         } else {
4934                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
4935                             sv_setpvn(sv_dat, (char *)&(RExC_npar), sizeof(I32));
4936                             SvIOK_on(sv_dat);
4937                             SvIVX(sv_dat)= 1;
4938                         }
4939
4940                         /*sv_dump(sv_dat);*/
4941                     }
4942                     nextchar(pRExC_state);
4943                     paren = 1;
4944                     goto capturing_parens;
4945                 }
4946                 RExC_seen |= REG_SEEN_LOOKBEHIND;
4947                 RExC_parse++;
4948             case '=':           /* (?=...) */
4949             case '!':           /* (?!...) */
4950                 RExC_seen_zerolen++;
4951                 if (*RExC_parse == ')') {
4952                     ret=reg_node(pRExC_state, OPFAIL);
4953                     nextchar(pRExC_state);
4954                     return ret;
4955                 }
4956             case ':':           /* (?:...) */
4957             case '>':           /* (?>...) */
4958                 break;
4959             case '$':           /* (?$...) */
4960             case '@':           /* (?@...) */
4961                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
4962                 break;
4963             case '#':           /* (?#...) */
4964                 while (*RExC_parse && *RExC_parse != ')')
4965                     RExC_parse++;
4966                 if (*RExC_parse != ')')
4967                     FAIL("Sequence (?#... not terminated");
4968                 nextchar(pRExC_state);
4969                 *flagp = TRYAGAIN;
4970                 return NULL;
4971             case '0' :           /* (?0) */
4972             case 'R' :           /* (?R) */
4973                 if (*RExC_parse != ')')
4974                     FAIL("Sequence (?R) not terminated");
4975                 ret = reg_node(pRExC_state, GOSTART);
4976                 nextchar(pRExC_state);
4977                 return ret;
4978                 /*notreached*/
4979             { /* named and numeric backreferences */
4980                 I32 num;
4981                 char * parse_start;
4982             case '&':            /* (?&NAME) */
4983                 parse_start = RExC_parse - 1;
4984                 {
4985                     SV *sv_dat = reg_scan_name(pRExC_state,
4986                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
4987                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
4988                 }
4989                 goto gen_recurse_regop;
4990                 /* NOT REACHED */
4991             case '+':
4992                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
4993                     RExC_parse++;
4994                     vFAIL("Illegal pattern");
4995                 }
4996                 goto parse_recursion;
4997                 /* NOT REACHED*/
4998             case '-': /* (?-1) */
4999                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
5000                     RExC_parse--; /* rewind to let it be handled later */
5001                     goto parse_flags;
5002                 }
5003                 /*FALLTHROUGH */
5004             case '1': case '2': case '3': case '4': /* (?1) */
5005             case '5': case '6': case '7': case '8': case '9':
5006                 RExC_parse--;
5007               parse_recursion:
5008                 num = atoi(RExC_parse);
5009                 parse_start = RExC_parse - 1; /* MJD */
5010                 if (*RExC_parse == '-')
5011                     RExC_parse++;
5012                 while (isDIGIT(*RExC_parse))
5013                         RExC_parse++;
5014                 if (*RExC_parse!=')')
5015                     vFAIL("Expecting close bracket");
5016
5017               gen_recurse_regop:
5018                 if ( paren == '-' ) {
5019                     /*
5020                     Diagram of capture buffer numbering.
5021                     Top line is the normal capture buffer numbers
5022                     Botton line is the negative indexing as from
5023                     the X (the (?-2))
5024
5025                     +   1 2    3 4 5 X          6 7
5026                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
5027                     -   5 4    3 2 1 X          x x
5028
5029                     */
5030                     num = RExC_npar + num;
5031                     if (num < 1)  {
5032                         RExC_parse++;
5033                         vFAIL("Reference to nonexistent group");
5034                     }
5035                 } else if ( paren == '+' ) {
5036                     num = RExC_npar + num - 1;
5037                 }
5038
5039                 ret = reganode(pRExC_state, GOSUB, num);
5040                 if (!SIZE_ONLY) {
5041                     if (num > (I32)RExC_rx->nparens) {
5042                         RExC_parse++;
5043                         vFAIL("Reference to nonexistent group");
5044                     }
5045                     ARG2L_SET( ret, RExC_recurse_count++);
5046                     RExC_emit++;
5047                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
5048                         "Recurse #%"UVuf" to %"IVdf"\n", (UV)ARG(ret), (IV)ARG2L(ret)));
5049                 } else {
5050                     RExC_size++;
5051                 }
5052                 RExC_seen |= REG_SEEN_RECURSE;
5053                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
5054                 Set_Node_Offset(ret, parse_start); /* MJD */
5055
5056                 nextchar(pRExC_state);
5057                 return ret;
5058             } /* named and numeric backreferences */
5059             /* NOT REACHED */
5060
5061             case 'p':           /* (?p...) */
5062                 if (SIZE_ONLY && ckWARN2(WARN_DEPRECATED, WARN_REGEXP))
5063                     vWARNdep(RExC_parse, "(?p{}) is deprecated - use (??{})");
5064                 /* FALL THROUGH*/
5065             case '?':           /* (??...) */
5066                 is_logical = 1;
5067                 if (*RExC_parse != '{')
5068                     goto unknown;
5069                 paren = *RExC_parse++;
5070                 /* FALL THROUGH */
5071             case '{':           /* (?{...}) */
5072             {
5073                 I32 count = 1, n = 0;
5074                 char c;
5075                 char *s = RExC_parse;
5076
5077                 RExC_seen_zerolen++;
5078                 RExC_seen |= REG_SEEN_EVAL;
5079                 while (count && (c = *RExC_parse)) {
5080                     if (c == '\\') {
5081                         if (RExC_parse[1])
5082                             RExC_parse++;
5083                     }
5084                     else if (c == '{')
5085                         count++;
5086                     else if (c == '}')
5087                         count--;
5088                     RExC_parse++;
5089                 }
5090                 if (*RExC_parse != ')') {
5091                     RExC_parse = s;
5092                     vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
5093                 }
5094                 if (!SIZE_ONLY) {
5095                     PAD *pad;
5096                     OP_4tree *sop, *rop;
5097                     SV * const sv = newSVpvn(s, RExC_parse - 1 - s);
5098
5099                     ENTER;
5100                     Perl_save_re_context(aTHX);
5101                     rop = sv_compile_2op(sv, &sop, "re", &pad);
5102                     sop->op_private |= OPpREFCOUNTED;
5103                     /* re_dup will OpREFCNT_inc */
5104                     OpREFCNT_set(sop, 1);
5105                     LEAVE;
5106
5107                     n = add_data(pRExC_state, 3, "nop");
5108                     RExC_rxi->data->data[n] = (void*)rop;
5109                     RExC_rxi->data->data[n+1] = (void*)sop;
5110                     RExC_rxi->data->data[n+2] = (void*)pad;
5111                     SvREFCNT_dec(sv);
5112                 }
5113                 else {                                          /* First pass */
5114                     if (PL_reginterp_cnt < ++RExC_seen_evals
5115                         && IN_PERL_RUNTIME)
5116                         /* No compiled RE interpolated, has runtime
5117                            components ===> unsafe.  */
5118                         FAIL("Eval-group not allowed at runtime, use re 'eval'");
5119                     if (PL_tainting && PL_tainted)
5120                         FAIL("Eval-group in insecure regular expression");
5121 #if PERL_VERSION > 8
5122                     if (IN_PERL_COMPILETIME)
5123                         PL_cv_has_eval = 1;
5124 #endif
5125                 }
5126
5127                 nextchar(pRExC_state);
5128                 if (is_logical) {
5129                     ret = reg_node(pRExC_state, LOGICAL);
5130                     if (!SIZE_ONLY)
5131                         ret->flags = 2;
5132                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, EVAL, n));
5133                     /* deal with the length of this later - MJD */
5134                     return ret;
5135                 }
5136                 ret = reganode(pRExC_state, EVAL, n);
5137                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
5138                 Set_Node_Offset(ret, parse_start);
5139                 return ret;
5140             }
5141             case '(':           /* (?(?{...})...) and (?(?=...)...) */
5142             {
5143                 int is_define= 0;
5144                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
5145                     if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
5146                         || RExC_parse[1] == '<'
5147                         || RExC_parse[1] == '{') { /* Lookahead or eval. */
5148                         I32 flag;
5149
5150                         ret = reg_node(pRExC_state, LOGICAL);
5151                         if (!SIZE_ONLY)
5152                             ret->flags = 1;
5153                         REGTAIL(pRExC_state, ret, reg(pRExC_state, 1, &flag,depth+1));
5154                         goto insert_if;
5155                     }
5156                 }
5157                 else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
5158                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
5159                 {
5160                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
5161                     char *name_start= RExC_parse++;
5162                     I32 num = 0;
5163                     SV *sv_dat=reg_scan_name(pRExC_state,
5164                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
5165                     if (RExC_parse == name_start || *RExC_parse != ch)
5166                         vFAIL2("Sequence (?(%c... not terminated",
5167                             (ch == '>' ? '<' : ch));
5168                     RExC_parse++;
5169                     if (!SIZE_ONLY) {
5170                         num = add_data( pRExC_state, 1, "S" );
5171                         RExC_rxi->data->data[num]=(void*)sv_dat;
5172                         SvREFCNT_inc(sv_dat);
5173                     }
5174                     ret = reganode(pRExC_state,NGROUPP,num);
5175                     goto insert_if_check_paren;
5176                 }
5177                 else if (RExC_parse[0] == 'D' &&
5178                          RExC_parse[1] == 'E' &&
5179                          RExC_parse[2] == 'F' &&
5180                          RExC_parse[3] == 'I' &&
5181                          RExC_parse[4] == 'N' &&
5182                          RExC_parse[5] == 'E')
5183                 {
5184                     ret = reganode(pRExC_state,DEFINEP,0);
5185                     RExC_parse +=6 ;
5186                     is_define = 1;
5187                     goto insert_if_check_paren;
5188                 }
5189                 else if (RExC_parse[0] == 'R') {
5190                     RExC_parse++;
5191                     parno = 0;
5192                     if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
5193                         parno = atoi(RExC_parse++);
5194                         while (isDIGIT(*RExC_parse))
5195                             RExC_parse++;
5196                     } else if (RExC_parse[0] == '&') {
5197                         SV *sv_dat;
5198                         RExC_parse++;
5199                         sv_dat = reg_scan_name(pRExC_state,
5200                             SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
5201                         parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
5202                     }
5203                     ret = reganode(pRExC_state,INSUBP,parno);
5204                     goto insert_if_check_paren;
5205                 }
5206                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
5207                     /* (?(1)...) */
5208                     char c;
5209                     parno = atoi(RExC_parse++);
5210
5211                     while (isDIGIT(*RExC_parse))
5212                         RExC_parse++;
5213                     ret = reganode(pRExC_state, GROUPP, parno);
5214
5215                  insert_if_check_paren:
5216                     if ((c = *nextchar(pRExC_state)) != ')')
5217                         vFAIL("Switch condition not recognized");
5218                   insert_if:
5219                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
5220                     br = regbranch(pRExC_state, &flags, 1,depth+1);
5221                     if (br == NULL)
5222                         br = reganode(pRExC_state, LONGJMP, 0);
5223                     else
5224                         REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
5225                     c = *nextchar(pRExC_state);
5226                     if (flags&HASWIDTH)
5227                         *flagp |= HASWIDTH;
5228                     if (c == '|') {
5229                         if (is_define)
5230                             vFAIL("(?(DEFINE)....) does not allow branches");
5231                         lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
5232                         regbranch(pRExC_state, &flags, 1,depth+1);
5233                         REGTAIL(pRExC_state, ret, lastbr);
5234                         if (flags&HASWIDTH)
5235                             *flagp |= HASWIDTH;
5236                         c = *nextchar(pRExC_state);
5237                     }
5238                     else
5239                         lastbr = NULL;
5240                     if (c != ')')
5241                         vFAIL("Switch (?(condition)... contains too many branches");
5242                     ender = reg_node(pRExC_state, TAIL);
5243                     REGTAIL(pRExC_state, br, ender);
5244                     if (lastbr) {
5245                         REGTAIL(pRExC_state, lastbr, ender);
5246                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
5247                     }
5248                     else
5249                         REGTAIL(pRExC_state, ret, ender);
5250                     return ret;
5251                 }
5252                 else {
5253                     vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
5254                 }
5255             }
5256             case 0:
5257                 RExC_parse--; /* for vFAIL to print correctly */
5258                 vFAIL("Sequence (? incomplete");
5259                 break;
5260             default:
5261                 --RExC_parse;
5262               parse_flags:      /* (?i) */
5263                 while (*RExC_parse && strchr("iogcmsx", *RExC_parse)) {
5264                     /* (?g), (?gc) and (?o) are useless here
5265                        and must be globally applied -- japhy */
5266
5267                     if (*RExC_parse == 'o' || *RExC_parse == 'g') {
5268                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
5269                             const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
5270                             if (! (wastedflags & wflagbit) ) {
5271                                 wastedflags |= wflagbit;
5272                                 vWARN5(
5273                                     RExC_parse + 1,
5274                                     "Useless (%s%c) - %suse /%c modifier",
5275                                     flagsp == &negflags ? "?-" : "?",
5276                                     *RExC_parse,
5277                                     flagsp == &negflags ? "don't " : "",
5278                                     *RExC_parse
5279                                 );
5280                             }
5281                         }
5282                     }
5283                     else if (*RExC_parse == 'c') {
5284                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
5285                             if (! (wastedflags & WASTED_C) ) {
5286                                 wastedflags |= WASTED_GC;
5287                                 vWARN3(
5288                                     RExC_parse + 1,
5289                                     "Useless (%sc) - %suse /gc modifier",
5290                                     flagsp == &negflags ? "?-" : "?",
5291                                     flagsp == &negflags ? "don't " : ""
5292                                 );
5293                             }
5294                         }
5295                     }
5296                     else { pmflag(flagsp, *RExC_parse); }
5297
5298                     ++RExC_parse;
5299                 }
5300                 if (*RExC_parse == '-') {
5301                     flagsp = &negflags;
5302                     wastedflags = 0;  /* reset so (?g-c) warns twice */
5303                     ++RExC_parse;
5304                     goto parse_flags;
5305                 }
5306                 RExC_flags |= posflags;
5307                 RExC_flags &= ~negflags;
5308                 if (*RExC_parse == ':') {
5309                     RExC_parse++;
5310                     paren = ':';
5311                     break;
5312                 }
5313               unknown:
5314                 if (*RExC_parse != ')') {
5315                     RExC_parse++;
5316                     vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
5317                 }
5318                 nextchar(pRExC_state);
5319                 *flagp = TRYAGAIN;
5320                 return NULL;
5321             }
5322         }
5323         else {                  /* (...) */
5324           capturing_parens:
5325             parno = RExC_npar;
5326             RExC_npar++;
5327
5328             ret = reganode(pRExC_state, OPEN, parno);
5329             if (!SIZE_ONLY ){
5330                 if (!RExC_nestroot)
5331                     RExC_nestroot = parno;
5332                 if (RExC_seen & REG_SEEN_RECURSE) {
5333                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
5334                         "Setting open paren #%"IVdf" to %d\n",
5335                         (IV)parno, REG_NODE_NUM(ret)));
5336                     RExC_open_parens[parno-1]= ret;
5337                 }
5338             }
5339             Set_Node_Length(ret, 1); /* MJD */
5340             Set_Node_Offset(ret, RExC_parse); /* MJD */
5341             is_open = 1;
5342         }
5343     }
5344     else                        /* ! paren */
5345         ret = NULL;
5346
5347     /* Pick up the branches, linking them together. */
5348     parse_start = RExC_parse;   /* MJD */
5349     br = regbranch(pRExC_state, &flags, 1,depth+1);
5350     /*     branch_len = (paren != 0); */
5351
5352     if (br == NULL)
5353         return(NULL);
5354     if (*RExC_parse == '|') {
5355         if (!SIZE_ONLY && RExC_extralen) {
5356             reginsert(pRExC_state, BRANCHJ, br, depth+1);
5357         }
5358         else {                  /* MJD */
5359             reginsert(pRExC_state, BRANCH, br, depth+1);
5360             Set_Node_Length(br, paren != 0);
5361             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
5362         }
5363         have_branch = 1;
5364         if (SIZE_ONLY)
5365             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
5366     }
5367     else if (paren == ':') {
5368         *flagp |= flags&SIMPLE;
5369     }
5370     if (is_open) {                              /* Starts with OPEN. */
5371         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
5372     }
5373     else if (paren != '?')              /* Not Conditional */
5374         ret = br;
5375     *flagp |= flags & (SPSTART | HASWIDTH);
5376     lastbr = br;
5377     while (*RExC_parse == '|') {
5378         if (!SIZE_ONLY && RExC_extralen) {
5379             ender = reganode(pRExC_state, LONGJMP,0);
5380             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
5381         }
5382         if (SIZE_ONLY)
5383             RExC_extralen += 2;         /* Account for LONGJMP. */
5384         nextchar(pRExC_state);
5385         br = regbranch(pRExC_state, &flags, 0, depth+1);
5386
5387         if (br == NULL)
5388             return(NULL);
5389         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
5390         lastbr = br;
5391         if (flags&HASWIDTH)
5392             *flagp |= HASWIDTH;
5393         *flagp |= flags&SPSTART;
5394     }
5395
5396     if (have_branch || paren != ':') {
5397         /* Make a closing node, and hook it on the end. */
5398         switch (paren) {
5399         case ':':
5400             ender = reg_node(pRExC_state, TAIL);
5401             break;
5402         case 1:
5403             RExC_cpar++;
5404             ender = reganode(pRExC_state, CLOSE, parno);
5405             if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) {
5406                 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
5407                         "Setting close paren #%"IVdf" to %d\n",
5408                         (IV)parno, REG_NODE_NUM(ender)));
5409                 RExC_close_parens[parno-1]= ender;
5410                 if (RExC_nestroot == parno)
5411                     RExC_nestroot = 0;
5412             }
5413             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
5414             Set_Node_Length(ender,1); /* MJD */
5415             break;
5416         case '<':
5417         case ',':
5418         case '=':
5419         case '!':
5420             *flagp &= ~HASWIDTH;
5421             /* FALL THROUGH */
5422         case '>':
5423             ender = reg_node(pRExC_state, SUCCEED);
5424             break;
5425         case 0:
5426             ender = reg_node(pRExC_state, END);
5427             if (!SIZE_ONLY) {
5428                 assert(!RExC_opend); /* there can only be one! */
5429                 RExC_opend = ender;
5430             }
5431             break;
5432         }
5433         REGTAIL(pRExC_state, lastbr, ender);
5434
5435         if (have_branch && !SIZE_ONLY) {
5436             if (depth==1)
5437                 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
5438
5439             /* Hook the tails of the branches to the closing node. */
5440             for (br = ret; br; br = regnext(br)) {
5441                 const U8 op = PL_regkind[OP(br)];
5442                 if (op == BRANCH) {
5443                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
5444                 }
5445                 else if (op == BRANCHJ) {
5446                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
5447                 }
5448             }
5449         }
5450     }
5451
5452     {
5453         const char *p;
5454         static const char parens[] = "=!<,>";
5455
5456         if (paren && (p = strchr(parens, paren))) {
5457             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
5458             int flag = (p - parens) > 1;
5459
5460             if (paren == '>')
5461                 node = SUSPEND, flag = 0;
5462             reginsert(pRExC_state, node,ret, depth+1);
5463             Set_Node_Cur_Length(ret);
5464             Set_Node_Offset(ret, parse_start + 1);
5465             ret->flags = flag;
5466             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
5467         }
5468     }
5469
5470     /* Check for proper termination. */
5471     if (paren) {
5472         RExC_flags = oregflags;
5473         if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
5474             RExC_parse = oregcomp_parse;
5475             vFAIL("Unmatched (");
5476         }
5477     }
5478     else if (!paren && RExC_parse < RExC_end) {
5479         if (*RExC_parse == ')') {
5480             RExC_parse++;
5481             vFAIL("Unmatched )");
5482         }
5483         else
5484             FAIL("Junk on end of regexp");      /* "Can't happen". */
5485         /* NOTREACHED */
5486     }
5487
5488     return(ret);
5489 }
5490
5491 /*
5492  - regbranch - one alternative of an | operator
5493  *
5494  * Implements the concatenation operator.
5495  */
5496 STATIC regnode *
5497 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
5498 {
5499     dVAR;
5500     register regnode *ret;
5501     register regnode *chain = NULL;
5502     register regnode *latest;
5503     I32 flags = 0, c = 0;
5504     GET_RE_DEBUG_FLAGS_DECL;
5505     DEBUG_PARSE("brnc");
5506     if (first)
5507         ret = NULL;
5508     else {
5509         if (!SIZE_ONLY && RExC_extralen)
5510             ret = reganode(pRExC_state, BRANCHJ,0);
5511         else {
5512             ret = reg_node(pRExC_state, BRANCH);
5513             Set_Node_Length(ret, 1);
5514         }
5515     }
5516
5517     if (!first && SIZE_ONLY)
5518         RExC_extralen += 1;                     /* BRANCHJ */
5519
5520     *flagp = WORST;                     /* Tentatively. */
5521
5522     RExC_parse--;
5523     nextchar(pRExC_state);
5524     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
5525         flags &= ~TRYAGAIN;
5526         latest = regpiece(pRExC_state, &flags,depth+1);
5527         if (latest == NULL) {
5528             if (flags & TRYAGAIN)
5529                 continue;
5530             return(NULL);
5531         }
5532         else if (ret == NULL)
5533             ret = latest;
5534         *flagp |= flags&HASWIDTH;
5535         if (chain == NULL)      /* First piece. */
5536             *flagp |= flags&SPSTART;
5537         else {
5538             RExC_naughty++;
5539             REGTAIL(pRExC_state, chain, latest);
5540         }
5541         chain = latest;
5542         c++;
5543     }
5544     if (chain == NULL) {        /* Loop ran zero times. */
5545         chain = reg_node(pRExC_state, NOTHING);
5546         if (ret == NULL)
5547             ret = chain;
5548     }
5549     if (c == 1) {
5550         *flagp |= flags&SIMPLE;
5551     }
5552
5553     return ret;
5554 }
5555
5556 /*
5557  - regpiece - something followed by possible [*+?]
5558  *
5559  * Note that the branching code sequences used for ? and the general cases
5560  * of * and + are somewhat optimized:  they use the same NOTHING node as
5561  * both the endmarker for their branch list and the body of the last branch.
5562  * It might seem that this node could be dispensed with entirely, but the
5563  * endmarker role is not redundant.
5564  */
5565 STATIC regnode *
5566 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
5567 {
5568     dVAR;
5569     register regnode *ret;
5570     register char op;
5571     register char *next;
5572     I32 flags;
5573     const char * const origparse = RExC_parse;
5574     I32 min;
5575     I32 max = REG_INFTY;
5576     char *parse_start;
5577     const char *maxpos = NULL;
5578     GET_RE_DEBUG_FLAGS_DECL;
5579     DEBUG_PARSE("piec");
5580
5581     ret = regatom(pRExC_state, &flags,depth+1);
5582     if (ret == NULL) {
5583         if (flags & TRYAGAIN)
5584             *flagp |= TRYAGAIN;
5585         return(NULL);
5586     }
5587
5588     op = *RExC_parse;
5589
5590     if (op == '{' && regcurly(RExC_parse)) {
5591         maxpos = NULL;
5592         parse_start = RExC_parse; /* MJD */
5593         next = RExC_parse + 1;
5594         while (isDIGIT(*next) || *next == ',') {
5595             if (*next == ',') {
5596                 if (maxpos)
5597                     break;
5598                 else
5599                     maxpos = next;
5600             }
5601             next++;
5602         }
5603         if (*next == '}') {             /* got one */
5604             if (!maxpos)
5605                 maxpos = next;
5606             RExC_parse++;
5607             min = atoi(RExC_parse);
5608             if (*maxpos == ',')
5609                 maxpos++;
5610             else
5611                 maxpos = RExC_parse;
5612             max = atoi(maxpos);
5613             if (!max && *maxpos != '0')
5614                 max = REG_INFTY;                /* meaning "infinity" */
5615             else if (max >= REG_INFTY)
5616                 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
5617             RExC_parse = next;
5618             nextchar(pRExC_state);
5619
5620         do_curly:
5621             if ((flags&SIMPLE)) {
5622                 RExC_naughty += 2 + RExC_naughty / 2;
5623                 reginsert(pRExC_state, CURLY, ret, depth+1);
5624                 Set_Node_Offset(ret, parse_start+1); /* MJD */
5625                 Set_Node_Cur_Length(ret);
5626             }
5627             else {
5628                 regnode * const w = reg_node(pRExC_state, WHILEM);
5629
5630                 w->flags = 0;
5631                 REGTAIL(pRExC_state, ret, w);
5632                 if (!SIZE_ONLY && RExC_extralen) {
5633                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
5634                     reginsert(pRExC_state, NOTHING,ret, depth+1);
5635                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
5636                 }
5637                 reginsert(pRExC_state, CURLYX,ret, depth+1);
5638                                 /* MJD hk */
5639                 Set_Node_Offset(ret, parse_start+1);
5640                 Set_Node_Length(ret,
5641                                 op == '{' ? (RExC_parse - parse_start) : 1);
5642
5643                 if (!SIZE_ONLY && RExC_extralen)
5644                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
5645                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
5646                 if (SIZE_ONLY)
5647                     RExC_whilem_seen++, RExC_extralen += 3;
5648                 RExC_naughty += 4 + RExC_naughty;       /* compound interest */
5649             }
5650             ret->flags = 0;
5651
5652             if (min > 0)
5653                 *flagp = WORST;
5654             if (max > 0)
5655                 *flagp |= HASWIDTH;
5656             if (max && max < min)
5657                 vFAIL("Can't do {n,m} with n > m");
5658             if (!SIZE_ONLY) {
5659                 ARG1_SET(ret, (U16)min);
5660                 ARG2_SET(ret, (U16)max);
5661             }
5662
5663             goto nest_check;
5664         }
5665     }
5666
5667     if (!ISMULT1(op)) {
5668         *flagp = flags;
5669         return(ret);
5670     }
5671
5672 #if 0                           /* Now runtime fix should be reliable. */
5673
5674     /* if this is reinstated, don't forget to put this back into perldiag:
5675
5676             =item Regexp *+ operand could be empty at {#} in regex m/%s/
5677
5678            (F) The part of the regexp subject to either the * or + quantifier
5679            could match an empty string. The {#} shows in the regular
5680            expression about where the problem was discovered.
5681
5682     */
5683
5684     if (!(flags&HASWIDTH) && op != '?')
5685       vFAIL("Regexp *+ operand could be empty");
5686 #endif
5687
5688     parse_start = RExC_parse;
5689     nextchar(pRExC_state);
5690
5691     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
5692
5693     if (op == '*' && (flags&SIMPLE)) {
5694         reginsert(pRExC_state, STAR, ret, depth+1);
5695         ret->flags = 0;
5696         RExC_naughty += 4;
5697     }
5698     else if (op == '*') {
5699         min = 0;
5700         goto do_curly;
5701     }
5702     else if (op == '+' && (flags&SIMPLE)) {
5703         reginsert(pRExC_state, PLUS, ret, depth+1);
5704         ret->flags = 0;
5705         RExC_naughty += 3;
5706     }
5707     else if (op == '+') {
5708         min = 1;
5709         goto do_curly;
5710     }
5711     else if (op == '?') {
5712         min = 0; max = 1;
5713         goto do_curly;
5714     }
5715   nest_check:
5716     if (!SIZE_ONLY && !(flags&HASWIDTH) && max > REG_INFTY/3 && ckWARN(WARN_REGEXP)) {
5717         vWARN3(RExC_parse,
5718                "%.*s matches null string many times",
5719                (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0),
5720                origparse);
5721     }
5722
5723     if (RExC_parse < RExC_end && *RExC_parse == '?') {
5724         nextchar(pRExC_state);
5725         reginsert(pRExC_state, MINMOD, ret, depth+1);
5726         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
5727     }
5728 #ifndef REG_ALLOW_MINMOD_SUSPEND
5729     else
5730 #endif
5731     if (RExC_parse < RExC_end && *RExC_parse == '+') {
5732         regnode *ender;
5733         nextchar(pRExC_state);
5734         ender = reg_node(pRExC_state, SUCCEED);
5735         REGTAIL(pRExC_state, ret, ender);
5736         reginsert(pRExC_state, SUSPEND, ret, depth+1);
5737         ret->flags = 0;
5738         ender = reg_node(pRExC_state, TAIL);
5739         REGTAIL(pRExC_state, ret, ender);
5740         /*ret= ender;*/
5741     }
5742
5743     if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) {
5744         RExC_parse++;
5745         vFAIL("Nested quantifiers");
5746     }
5747
5748     return(ret);
5749 }
5750
5751
5752 /* reg_namedseq(pRExC_state,UVp)
5753
5754    This is expected to be called by a parser routine that has
5755    recognized'\N' and needs to handle the rest. RExC_parse is
5756    expected to point at the first char following the N at the time
5757    of the call.
5758
5759    If valuep is non-null then it is assumed that we are parsing inside
5760    of a charclass definition and the first codepoint in the resolved
5761    string is returned via *valuep and the routine will return NULL.
5762    In this mode if a multichar string is returned from the charnames
5763    handler a warning will be issued, and only the first char in the
5764    sequence will be examined. If the string returned is zero length
5765    then the value of *valuep is undefined and NON-NULL will
5766    be returned to indicate failure. (This will NOT be a valid pointer
5767    to a regnode.)
5768
5769    If value is null then it is assumed that we are parsing normal text
5770    and inserts a new EXACT node into the program containing the resolved
5771    string and returns a pointer to the new node. If the string is
5772    zerolength a NOTHING node is emitted.
5773
5774    On success RExC_parse is set to the char following the endbrace.
5775    Parsing failures will generate a fatal errorvia vFAIL(...)
5776
5777    NOTE: We cache all results from the charnames handler locally in
5778    the RExC_charnames hash (created on first use) to prevent a charnames
5779    handler from playing silly-buggers and returning a short string and
5780    then a long string for a given pattern. Since the regexp program
5781    size is calculated during an initial parse this would result
5782    in a buffer overrun so we cache to prevent the charname result from
5783    changing during the course of the parse.
5784
5785  */
5786 STATIC regnode *
5787 S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep)
5788 {
5789     char * name;        /* start of the content of the name */
5790     char * endbrace;    /* endbrace following the name */
5791     SV *sv_str = NULL;
5792     SV *sv_name = NULL;
5793     STRLEN len; /* this has various purposes throughout the code */
5794     bool cached = 0; /* if this is true then we shouldn't refcount dev sv_str */
5795     regnode *ret = NULL;
5796
5797     if (*RExC_parse != '{') {
5798         vFAIL("Missing braces on \\N{}");
5799     }
5800     name = RExC_parse+1;
5801     endbrace = strchr(RExC_parse, '}');
5802     if ( ! endbrace ) {
5803         RExC_parse++;
5804         vFAIL("Missing right brace on \\N{}");
5805     }
5806     RExC_parse = endbrace + 1;
5807
5808
5809     /* RExC_parse points at the beginning brace,
5810        endbrace points at the last */
5811     if ( name[0]=='U' && name[1]=='+' ) {
5812         /* its a "unicode hex" notation {U+89AB} */
5813         I32 fl = PERL_SCAN_ALLOW_UNDERSCORES
5814             | PERL_SCAN_DISALLOW_PREFIX
5815             | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
5816         UV cp;
5817         len = (STRLEN)(endbrace - name - 2);
5818         cp = grok_hex(name + 2, &len, &fl, NULL);
5819         if ( len != (STRLEN)(endbrace - name - 2) ) {
5820             cp = 0xFFFD;
5821         }
5822         if (cp > 0xff)
5823             RExC_utf8 = 1;
5824         if ( valuep ) {
5825             *valuep = cp;
5826             return NULL;
5827         }
5828         sv_str= Perl_newSVpvf_nocontext("%c",(int)cp);
5829     } else {
5830         /* fetch the charnames handler for this scope */
5831         HV * const table = GvHV(PL_hintgv);
5832         SV **cvp= table ?
5833             hv_fetchs(table, "charnames", FALSE) :
5834             NULL;
5835         SV *cv= cvp ? *cvp : NULL;
5836         HE *he_str;
5837         int count;
5838         /* create an SV with the name as argument */
5839         sv_name = newSVpvn(name, endbrace - name);
5840
5841         if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
5842             vFAIL2("Constant(\\N{%s}) unknown: "
5843                   "(possibly a missing \"use charnames ...\")",
5844                   SvPVX(sv_name));
5845         }
5846         if (!cvp || !SvOK(*cvp)) { /* when $^H{charnames} = undef; */
5847             vFAIL2("Constant(\\N{%s}): "
5848                   "$^H{charnames} is not defined",SvPVX(sv_name));
5849         }
5850
5851
5852
5853         if (!RExC_charnames) {
5854             /* make sure our cache is allocated */
5855             RExC_charnames = newHV();
5856             sv_2mortal((SV*)RExC_charnames);
5857         }
5858             /* see if we have looked this one up before */
5859         he_str = hv_fetch_ent( RExC_charnames, sv_name, 0, 0 );
5860         if ( he_str ) {
5861             sv_str = HeVAL(he_str);
5862             cached = 1;
5863         } else {
5864             dSP ;
5865
5866             ENTER ;
5867             SAVETMPS ;
5868             PUSHMARK(SP) ;
5869
5870             XPUSHs(sv_name);
5871
5872             PUTBACK ;
5873
5874             count= call_sv(cv, G_SCALAR);
5875
5876             if (count == 1) { /* XXXX is this right? dmq */
5877                 sv_str = POPs;
5878                 SvREFCNT_inc_simple_void(sv_str);
5879             }
5880
5881             SPAGAIN ;
5882             PUTBACK ;
5883             FREETMPS ;
5884             LEAVE ;
5885
5886             if ( !sv_str || !SvOK(sv_str) ) {
5887                 vFAIL2("Constant(\\N{%s}): Call to &{$^H{charnames}} "
5888                       "did not return a defined value",SvPVX(sv_name));
5889             }
5890             if (hv_store_ent( RExC_charnames, sv_name, sv_str, 0))
5891                 cached = 1;
5892         }
5893     }
5894     if (valuep) {
5895         char *p = SvPV(sv_str, len);
5896         if (len) {
5897             STRLEN numlen = 1;
5898             if ( SvUTF8(sv_str) ) {
5899                 *valuep = utf8_to_uvchr((U8*)p, &numlen);
5900                 if (*valuep > 0x7F)
5901                     RExC_utf8 = 1;
5902                 /* XXXX
5903                   We have to turn on utf8 for high bit chars otherwise
5904                   we get failures with
5905
5906                    "ss" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i
5907                    "SS" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i
5908
5909                   This is different from what \x{} would do with the same
5910                   codepoint, where the condition is > 0xFF.
5911                   - dmq
5912                 */
5913
5914
5915             } else {
5916                 *valuep = (UV)*p;
5917                 /* warn if we havent used the whole string? */
5918             }
5919             if (numlen<len && SIZE_ONLY && ckWARN(WARN_REGEXP)) {
5920                 vWARN2(RExC_parse,
5921                     "Ignoring excess chars from \\N{%s} in character class",
5922                     SvPVX(sv_name)
5923                 );
5924             }
5925         } else if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
5926             vWARN2(RExC_parse,
5927                     "Ignoring zero length \\N{%s} in character class",
5928                     SvPVX(sv_name)
5929                 );
5930         }
5931         if (sv_name)
5932             SvREFCNT_dec(sv_name);
5933         if (!cached)
5934             SvREFCNT_dec(sv_str);
5935         return len ? NULL : (regnode *)&len;
5936     } else if(SvCUR(sv_str)) {
5937
5938         char *s;
5939         char *p, *pend;
5940         STRLEN charlen = 1;
5941         char * parse_start = name-3; /* needed for the offsets */
5942         GET_RE_DEBUG_FLAGS_DECL;     /* needed for the offsets */
5943
5944         ret = reg_node(pRExC_state,
5945             (U8)(FOLD ? (LOC ? EXACTFL : EXACTF) : EXACT));
5946         s= STRING(ret);
5947
5948         if ( RExC_utf8 && !SvUTF8(sv_str) ) {
5949             sv_utf8_upgrade(sv_str);
5950         } else if ( !RExC_utf8 && SvUTF8(sv_str) ) {
5951             RExC_utf8= 1;
5952         }
5953
5954         p = SvPV(sv_str, len);
5955         pend = p + len;
5956         /* len is the length written, charlen is the size the char read */
5957         for ( len = 0; p < pend; p += charlen ) {
5958             if (UTF) {
5959                 UV uvc = utf8_to_uvchr((U8*)p, &charlen);
5960                 if (FOLD) {
5961                     STRLEN foldlen,numlen;
5962                     U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
5963                     uvc = toFOLD_uni(uvc, tmpbuf, &foldlen);
5964                     /* Emit all the Unicode characters. */
5965
5966                     for (foldbuf = tmpbuf;
5967                         foldlen;
5968                         foldlen -= numlen)
5969                     {
5970                         uvc = utf8_to_uvchr(foldbuf, &numlen);
5971                         if (numlen > 0) {
5972                             const STRLEN unilen = reguni(pRExC_state, uvc, s);
5973                             s       += unilen;
5974                             len     += unilen;
5975                             /* In EBCDIC the numlen
5976                             * and unilen can differ. */
5977                             foldbuf += numlen;
5978                             if (numlen >= foldlen)
5979                                 break;
5980                         }
5981                         else
5982                             break; /* "Can't happen." */
5983                     }
5984                 } else {
5985                     const STRLEN unilen = reguni(pRExC_state, uvc, s);
5986                     if (unilen > 0) {
5987                        s   += unilen;
5988                        len += unilen;
5989                     }
5990                 }
5991             } else {
5992                 len++;
5993                 REGC(*p, s++);
5994             }
5995         }
5996         if (SIZE_ONLY) {
5997             RExC_size += STR_SZ(len);
5998         } else {
5999             STR_LEN(ret) = len;
6000             RExC_emit += STR_SZ(len);
6001         }
6002         Set_Node_Cur_Length(ret); /* MJD */
6003         RExC_parse--;
6004         nextchar(pRExC_state);
6005     } else {
6006         ret = reg_node(pRExC_state,NOTHING);
6007     }
6008     if (!cached) {
6009         SvREFCNT_dec(sv_str);
6010     }
6011     if (sv_name) {
6012         SvREFCNT_dec(sv_name);
6013     }
6014     return ret;
6015
6016 }
6017
6018
6019 /*
6020  * reg_recode
6021  *
6022  * It returns the code point in utf8 for the value in *encp.
6023  *    value: a code value in the source encoding
6024  *    encp:  a pointer to an Encode object
6025  *
6026  * If the result from Encode is not a single character,
6027  * it returns U+FFFD (Replacement character) and sets *encp to NULL.
6028  */
6029 STATIC UV
6030 S_reg_recode(pTHX_ const char value, SV **encp)
6031 {
6032     STRLEN numlen = 1;
6033     SV * const sv = sv_2mortal(newSVpvn(&value, numlen));
6034     const char * const s = encp && *encp ? sv_recode_to_utf8(sv, *encp)
6035                                          : SvPVX(sv);
6036     const STRLEN newlen = SvCUR(sv);
6037     UV uv = UNICODE_REPLACEMENT;
6038
6039     if (newlen)
6040         uv = SvUTF8(sv)
6041              ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
6042              : *(U8*)s;
6043
6044     if (!newlen || numlen != newlen) {
6045         uv = UNICODE_REPLACEMENT;
6046         if (encp)
6047             *encp = NULL;
6048     }
6049     return uv;
6050 }
6051
6052
6053 /*
6054  - regatom - the lowest level
6055  *
6056  * Optimization:  gobbles an entire sequence of ordinary characters so that
6057  * it can turn them into a single node, which is smaller to store and
6058  * faster to run.  Backslashed characters are exceptions, each becoming a
6059  * separate node; the code is simpler that way and it's not worth fixing.
6060  *
6061  * [Yes, it is worth fixing, some scripts can run twice the speed.]
6062  * [It looks like its ok, as in S_study_chunk we merge adjacent EXACT nodes]
6063  */
6064 STATIC regnode *
6065 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
6066 {
6067     dVAR;
6068     register regnode *ret = NULL;
6069     I32 flags;
6070     char *parse_start = RExC_parse;
6071     GET_RE_DEBUG_FLAGS_DECL;
6072     DEBUG_PARSE("atom");
6073     *flagp = WORST;             /* Tentatively. */
6074
6075 tryagain:
6076     switch (*RExC_parse) {
6077     case '^':
6078         RExC_seen_zerolen++;
6079         nextchar(pRExC_state);
6080         if (RExC_flags & RXf_PMf_MULTILINE)
6081             ret = reg_node(pRExC_state, MBOL);
6082         else if (RExC_flags & RXf_PMf_SINGLELINE)
6083             ret = reg_node(pRExC_state, SBOL);
6084         else
6085             ret = reg_node(pRExC_state, BOL);
6086         Set_Node_Length(ret, 1); /* MJD */
6087         break;
6088     case '$':
6089         nextchar(pRExC_state);
6090         if (*RExC_parse)
6091             RExC_seen_zerolen++;
6092         if (RExC_flags & RXf_PMf_MULTILINE)
6093             ret = reg_node(pRExC_state, MEOL);
6094         else if (RExC_flags & RXf_PMf_SINGLELINE)
6095             ret = reg_node(pRExC_state, SEOL);
6096         else
6097             ret = reg_node(pRExC_state, EOL);
6098         Set_Node_Length(ret, 1); /* MJD */
6099         break;
6100     case '.':
6101         nextchar(pRExC_state);
6102         if (RExC_flags & RXf_PMf_SINGLELINE)
6103             ret = reg_node(pRExC_state, SANY);
6104         else
6105             ret = reg_node(pRExC_state, REG_ANY);
6106         *flagp |= HASWIDTH|SIMPLE;
6107         RExC_naughty++;
6108         Set_Node_Length(ret, 1); /* MJD */
6109         break;
6110     case '[':
6111     {
6112         char * const oregcomp_parse = ++RExC_parse;
6113         ret = regclass(pRExC_state,depth+1);
6114         if (*RExC_parse != ']') {
6115             RExC_parse = oregcomp_parse;
6116             vFAIL("Unmatched [");
6117         }
6118         nextchar(pRExC_state);
6119         *flagp |= HASWIDTH|SIMPLE;
6120         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
6121         break;
6122     }
6123     case '(':
6124         nextchar(pRExC_state);
6125         ret = reg(pRExC_state, 1, &flags,depth+1);
6126         if (ret == NULL) {
6127                 if (flags & TRYAGAIN) {
6128                     if (RExC_parse == RExC_end) {
6129                          /* Make parent create an empty node if needed. */
6130                         *flagp |= TRYAGAIN;
6131                         return(NULL);
6132                     }
6133                     goto tryagain;
6134                 }
6135                 return(NULL);
6136         }
6137         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE);
6138         break;
6139     case '|':
6140     case ')':
6141         if (flags & TRYAGAIN) {
6142             *flagp |= TRYAGAIN;
6143             return NULL;
6144         }
6145         vFAIL("Internal urp");
6146                                 /* Supposed to be caught earlier. */
6147         break;
6148     case '{':
6149         if (!regcurly(RExC_parse)) {
6150             RExC_parse++;
6151             goto defchar;
6152         }
6153         /* FALL THROUGH */
6154     case '?':
6155     case '+':
6156     case '*':
6157         RExC_parse++;
6158         vFAIL("Quantifier follows nothing");
6159         break;
6160     case '\\':
6161         switch (*++RExC_parse) {
6162         case 'A':
6163             RExC_seen_zerolen++;
6164             ret = reg_node(pRExC_state, SBOL);
6165             *flagp |= SIMPLE;
6166             nextchar(pRExC_state);
6167             Set_Node_Length(ret, 2); /* MJD */
6168             break;
6169         case 'G':
6170             ret = reg_node(pRExC_state, GPOS);
6171             RExC_seen |= REG_SEEN_GPOS;
6172             *flagp |= SIMPLE;
6173             nextchar(pRExC_state);
6174             Set_Node_Length(ret, 2); /* MJD */
6175             break;
6176         case 'Z':
6177             ret = reg_node(pRExC_state, SEOL);
6178             *flagp |= SIMPLE;
6179             RExC_seen_zerolen++;                /* Do not optimize RE away */
6180             nextchar(pRExC_state);
6181             break;
6182         case 'z':
6183             ret = reg_node(pRExC_state, EOS);
6184             *flagp |= SIMPLE;
6185             RExC_seen_zerolen++;                /* Do not optimize RE away */
6186             nextchar(pRExC_state);
6187             Set_Node_Length(ret, 2); /* MJD */
6188             break;
6189         case 'C':
6190             ret = reg_node(pRExC_state, CANY);
6191             RExC_seen |= REG_SEEN_CANY;
6192             *flagp |= HASWIDTH|SIMPLE;
6193             nextchar(pRExC_state);
6194             Set_Node_Length(ret, 2); /* MJD */
6195             break;
6196         case 'X':
6197             ret = reg_node(pRExC_state, CLUMP);
6198             *flagp |= HASWIDTH;
6199             nextchar(pRExC_state);
6200             Set_Node_Length(ret, 2); /* MJD */
6201             break;
6202         case 'w':
6203             ret = reg_node(pRExC_state, (U8)(LOC ? ALNUML     : ALNUM));
6204             *flagp |= HASWIDTH|SIMPLE;
6205             nextchar(pRExC_state);
6206             Set_Node_Length(ret, 2); /* MJD */
6207             break;
6208         case 'W':
6209             ret = reg_node(pRExC_state, (U8)(LOC ? NALNUML    : NALNUM));
6210             *flagp |= HASWIDTH|SIMPLE;
6211             nextchar(pRExC_state);
6212             Set_Node_Length(ret, 2); /* MJD */
6213             break;
6214         case 'b':
6215             RExC_seen_zerolen++;
6216             RExC_seen |= REG_SEEN_LOOKBEHIND;
6217             ret = reg_node(pRExC_state, (U8)(LOC ? BOUNDL     : BOUND));
6218             *flagp |= SIMPLE;
6219             nextchar(pRExC_state);
6220             Set_Node_Length(ret, 2); /* MJD */
6221             break;
6222         case 'B':
6223             RExC_seen_zerolen++;
6224             RExC_seen |= REG_SEEN_LOOKBEHIND;
6225             ret = reg_node(pRExC_state, (U8)(LOC ? NBOUNDL    : NBOUND));
6226             *flagp |= SIMPLE;
6227             nextchar(pRExC_state);
6228             Set_Node_Length(ret, 2); /* MJD */
6229             break;
6230         case 's':
6231             ret = reg_node(pRExC_state, (U8)(LOC ? SPACEL     : SPACE));
6232             *flagp |= HASWIDTH|SIMPLE;
6233             nextchar(pRExC_state);
6234             Set_Node_Length(ret, 2); /* MJD */
6235             break;
6236         case 'S':
6237             ret = reg_node(pRExC_state, (U8)(LOC ? NSPACEL    : NSPACE));
6238             *flagp |= HASWIDTH|SIMPLE;
6239             nextchar(pRExC_state);
6240             Set_Node_Length(ret, 2); /* MJD */
6241             break;
6242         case 'd':
6243             ret = reg_node(pRExC_state, DIGIT);
6244             *flagp |= HASWIDTH|SIMPLE;
6245             nextchar(pRExC_state);
6246             Set_Node_Length(ret, 2); /* MJD */
6247             break;
6248         case 'D':
6249             ret = reg_node(pRExC_state, NDIGIT);
6250             *flagp |= HASWIDTH|SIMPLE;
6251             nextchar(pRExC_state);
6252             Set_Node_Length(ret, 2); /* MJD */
6253             break;
6254         case 'p':
6255         case 'P':
6256             {
6257                 char* const oldregxend = RExC_end;
6258                 char* parse_start = RExC_parse - 2;
6259
6260                 if (RExC_parse[1] == '{') {
6261                   /* a lovely hack--pretend we saw [\pX] instead */
6262                     RExC_end = strchr(RExC_parse, '}');
6263                     if (!RExC_end) {
6264                         const U8 c = (U8)*RExC_parse;
6265                         RExC_parse += 2;
6266                         RExC_end = oldregxend;
6267                         vFAIL2("Missing right brace on \\%c{}", c);
6268                     }
6269                     RExC_end++;
6270                 }
6271                 else {
6272                     RExC_end = RExC_parse + 2;
6273                     if (RExC_end > oldregxend)
6274                         RExC_end = oldregxend;
6275                 }
6276                 RExC_parse--;
6277
6278                 ret = regclass(pRExC_state,depth+1);
6279
6280                 RExC_end = oldregxend;
6281                 RExC_parse--;
6282
6283                 Set_Node_Offset(ret, parse_start + 2);
6284                 Set_Node_Cur_Length(ret);
6285                 nextchar(pRExC_state);
6286                 *flagp |= HASWIDTH|SIMPLE;
6287             }
6288             break;
6289         case 'N':
6290             /* Handle \N{NAME} here and not below because it can be
6291             multicharacter. join_exact() will join them up later on.
6292             Also this makes sure that things like /\N{BLAH}+/ and
6293             \N{BLAH} being multi char Just Happen. dmq*/
6294             ++RExC_parse;
6295             ret= reg_namedseq(pRExC_state, NULL);
6296             break;
6297         case 'k':    /* Handle \k<NAME> and \k'NAME' */
6298         {
6299             char ch= RExC_parse[1];
6300             if (ch != '<' && ch != '\'') {
6301                 if (SIZE_ONLY)
6302                     vWARN( RExC_parse + 1,
6303                         "Possible broken named back reference treated as literal k");
6304                 parse_start--;
6305                 goto defchar;
6306             } else {
6307                 char* name_start = (RExC_parse += 2);
6308                 I32 num = 0;
6309                 SV *sv_dat = reg_scan_name(pRExC_state,
6310                     SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6311                 ch= (ch == '<') ? '>' : '\'';
6312
6313                 if (RExC_parse == name_start || *RExC_parse != ch)
6314                     vFAIL2("Sequence \\k%c... not terminated",
6315                         (ch == '>' ? '<' : ch));
6316
6317                 RExC_sawback = 1;
6318                 ret = reganode(pRExC_state,
6319                            (U8)(FOLD ? (LOC ? NREFFL : NREFF) : NREF),
6320                            num);
6321                 *flagp |= HASWIDTH;
6322
6323
6324                 if (!SIZE_ONLY) {
6325                     num = add_data( pRExC_state, 1, "S" );
6326                     ARG_SET(ret,num);
6327                     RExC_rxi->data->data[num]=(void*)sv_dat;
6328                     SvREFCNT_inc(sv_dat);
6329                 }
6330                 /* override incorrect value set in reganode MJD */
6331                 Set_Node_Offset(ret, parse_start+1);
6332                 Set_Node_Cur_Length(ret); /* MJD */
6333                 nextchar(pRExC_state);
6334
6335             }
6336             break;
6337         }
6338         case 'n':
6339         case 'r':
6340         case 't':
6341         case 'f':
6342         case 'e':
6343         case 'a':
6344         case 'x':
6345         case 'c':
6346         case '0':
6347             goto defchar;
6348         case 'R':
6349         case '1': case '2': case '3': case '4':
6350         case '5': case '6': case '7': case '8': case '9':
6351             {
6352                 I32 num;
6353                 bool isrel=(*RExC_parse=='R');
6354                 if (isrel)
6355                     RExC_parse++;
6356                 num = atoi(RExC_parse);
6357                 if (isrel) {
6358                     num = RExC_cpar - num;
6359                     if (num < 1)
6360                         vFAIL("Reference to nonexistent or unclosed group");
6361                 }
6362                 if (num > 9 && num >= RExC_npar)
6363                     goto defchar;
6364                 else {
6365                     char * const parse_start = RExC_parse - 1; /* MJD */
6366                     while (isDIGIT(*RExC_parse))
6367                         RExC_parse++;
6368
6369                     if (!SIZE_ONLY) {
6370                         if (num > (I32)RExC_rx->nparens)
6371                             vFAIL("Reference to nonexistent group");
6372                         /* People make this error all the time apparently.
6373                            So we cant fail on it, even though we should
6374
6375                         else if (num >= RExC_cpar)
6376                             vFAIL("Reference to unclosed group will always match");
6377                         */
6378                     }
6379                     RExC_sawback = 1;
6380                     ret = reganode(pRExC_state,
6381                                    (U8)(FOLD ? (LOC ? REFFL : REFF) : REF),
6382                                    num);
6383                     *flagp |= HASWIDTH;
6384
6385                     /* override incorrect value set in reganode MJD */
6386                     Set_Node_Offset(ret, parse_start+1);
6387                     Set_Node_Cur_Length(ret); /* MJD */
6388                     RExC_parse--;
6389                     nextchar(pRExC_state);
6390                 }
6391             }
6392             break;
6393         case '\0':
6394             if (RExC_parse >= RExC_end)
6395                 FAIL("Trailing \\");
6396             /* FALL THROUGH */
6397         default:
6398             /* Do not generate "unrecognized" warnings here, we fall
6399                back into the quick-grab loop below */
6400             parse_start--;
6401             goto defchar;
6402         }
6403         break;
6404
6405     case '#':
6406         if (RExC_flags & RXf_PMf_EXTENDED) {
6407             while (RExC_parse < RExC_end && *RExC_parse != '\n')
6408                 RExC_parse++;
6409             if (RExC_parse < RExC_end)
6410                 goto tryagain;
6411         }
6412         /* FALL THROUGH */
6413
6414     default: {
6415             register STRLEN len;
6416             register UV ender;
6417             register char *p;
6418             char *s;
6419             STRLEN foldlen;
6420             U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
6421
6422             parse_start = RExC_parse - 1;
6423
6424             RExC_parse++;
6425
6426         defchar:
6427             ender = 0;
6428             ret = reg_node(pRExC_state,
6429                            (U8)(FOLD ? (LOC ? EXACTFL : EXACTF) : EXACT));
6430             s = STRING(ret);
6431             for (len = 0, p = RExC_parse - 1;
6432               len < 127 && p < RExC_end;
6433               len++)
6434             {
6435                 char * const oldp = p;
6436
6437                 if (RExC_flags & RXf_PMf_EXTENDED)
6438                     p = regwhite(p, RExC_end);
6439                 switch (*p) {
6440                 case '^':
6441                 case '$':
6442                 case '.':
6443                 case '[':
6444                 case '(':
6445                 case ')':
6446                 case '|':
6447                     goto loopdone;
6448                 case '\\':
6449                     switch (*++p) {
6450                     case 'A':
6451                     case 'C':
6452                     case 'X':
6453                     case 'G':
6454                     case 'Z':
6455                     case 'z':
6456                     case 'w':
6457                     case 'W':
6458                     case 'b':
6459                     case 'B':
6460                     case 's':
6461                     case 'S':
6462                     case 'd':
6463                     case 'D':
6464                     case 'p':
6465                     case 'P':
6466                     case 'N':
6467                     case 'R':
6468                         --p;
6469                         goto loopdone;
6470                     case 'n':
6471                         ender = '\n';
6472                         p++;
6473                         break;
6474                     case 'r':
6475                         ender = '\r';
6476                         p++;
6477                         break;
6478                     case 't':
6479                         ender = '\t';
6480                         p++;
6481                         break;
6482                     case 'f':
6483                         ender = '\f';
6484                         p++;
6485                         break;
6486                     case 'e':
6487                           ender = ASCII_TO_NATIVE('\033');
6488                         p++;
6489                         break;
6490                     case 'a':
6491                           ender = ASCII_TO_NATIVE('\007');
6492                         p++;
6493                         break;
6494                     case 'x':
6495                         if (*++p == '{') {
6496                             char* const e = strchr(p, '}');
6497
6498                             if (!e) {
6499                                 RExC_parse = p + 1;
6500                                 vFAIL("Missing right brace on \\x{}");
6501                             }
6502                             else {
6503                                 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
6504                                     | PERL_SCAN_DISALLOW_PREFIX;
6505                                 STRLEN numlen = e - p - 1;
6506                                 ender = grok_hex(p + 1, &numlen, &flags, NULL);
6507                                 if (ender > 0xff)
6508                                     RExC_utf8 = 1;
6509                                 p = e + 1;
6510                             }
6511                         }
6512                         else {
6513                             I32 flags = PERL_SCAN_DISALLOW_PREFIX;
6514                             STRLEN numlen = 2;
6515                             ender = grok_hex(p, &numlen, &flags, NULL);
6516                             p += numlen;
6517                         }
6518                         if (PL_encoding && ender < 0x100)
6519                             goto recode_encoding;
6520                         break;
6521                     case 'c':
6522                         p++;
6523                         ender = UCHARAT(p++);
6524                         ender = toCTRL(ender);
6525                         break;
6526                     case '0': case '1': case '2': case '3':case '4':
6527                     case '5': case '6': case '7': case '8':case '9':
6528                         if (*p == '0' ||
6529                           (isDIGIT(p[1]) && atoi(p) >= RExC_npar) ) {
6530                             I32 flags = 0;
6531                             STRLEN numlen = 3;
6532                             ender = grok_oct(p, &numlen, &flags, NULL);
6533                             p += numlen;
6534                         }
6535                         else {
6536                             --p;
6537                             goto loopdone;
6538                         }
6539                         if (PL_encoding && ender < 0x100)
6540                             goto recode_encoding;
6541                         break;
6542                     recode_encoding:
6543                         {
6544                             SV* enc = PL_encoding;
6545                             ender = reg_recode((const char)(U8)ender, &enc);
6546                             if (!enc && SIZE_ONLY && ckWARN(WARN_REGEXP))
6547                                 vWARN(p, "Invalid escape in the specified encoding");
6548                             RExC_utf8 = 1;
6549                         }
6550                         break;
6551                     case '\0':
6552                         if (p >= RExC_end)
6553                             FAIL("Trailing \\");
6554                         /* FALL THROUGH */
6555                     default:
6556                         if (!SIZE_ONLY&& isALPHA(*p) && ckWARN(WARN_REGEXP))
6557                             vWARN2(p + 1, "Unrecognized escape \\%c passed through", UCHARAT(p));
6558                         goto normal_default;
6559                     }
6560                     break;
6561                 default:
6562                   normal_default:
6563                     if (UTF8_IS_START(*p) && UTF) {
6564                         STRLEN numlen;
6565                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
6566                                                &numlen, UTF8_ALLOW_DEFAULT);
6567                         p += numlen;
6568                     }
6569                     else
6570                         ender = *p++;
6571                     break;
6572                 }
6573                 if (RExC_flags & RXf_PMf_EXTENDED)
6574                     p = regwhite(p, RExC_end);
6575                 if (UTF && FOLD) {
6576                     /* Prime the casefolded buffer. */
6577                     ender = toFOLD_uni(ender, tmpbuf, &foldlen);
6578                 }
6579                 if (ISMULT2(p)) { /* Back off on ?+*. */
6580                     if (len)
6581                         p = oldp;
6582                     else if (UTF) {
6583                          if (FOLD) {
6584                               /* Emit all the Unicode characters. */
6585                               STRLEN numlen;
6586                               for (foldbuf = tmpbuf;
6587                                    foldlen;
6588                                    foldlen -= numlen) {
6589                                    ender = utf8_to_uvchr(foldbuf, &numlen);
6590                                    if (numlen > 0) {
6591                                         const STRLEN unilen = reguni(pRExC_state, ender, s);
6592                                         s       += unilen;
6593                                         len     += unilen;
6594                                         /* In EBCDIC the numlen
6595                                          * and unilen can differ. */
6596                                         foldbuf += numlen;
6597                                         if (numlen >= foldlen)
6598                                              break;
6599                                    }
6600                                    else
6601                                         break; /* "Can't happen." */
6602                               }
6603                          }
6604                          else {
6605                               const STRLEN unilen = reguni(pRExC_state, ender, s);
6606                               if (unilen > 0) {
6607                                    s   += unilen;
6608                                    len += unilen;
6609                               }
6610                          }
6611                     }
6612                     else {
6613                         len++;
6614                         REGC((char)ender, s++);
6615                     }
6616                     break;
6617                 }
6618                 if (UTF) {
6619                      if (FOLD) {
6620                           /* Emit all the Unicode characters. */
6621                           STRLEN numlen;
6622                           for (foldbuf = tmpbuf;
6623                                foldlen;
6624                                foldlen -= numlen) {
6625                                ender = utf8_to_uvchr(foldbuf, &numlen);
6626                                if (numlen > 0) {
6627                                     const STRLEN unilen = reguni(pRExC_state, ender, s);
6628                                     len     += unilen;
6629                                     s       += unilen;
6630                                     /* In EBCDIC the numlen
6631                                      * and unilen can differ. */
6632                                     foldbuf += numlen;
6633                                     if (numlen >= foldlen)
6634                                          break;
6635                                }
6636                                else
6637                                     break;
6638                           }
6639                      }
6640                      else {
6641                           const STRLEN unilen = reguni(pRExC_state, ender, s);
6642                           if (unilen > 0) {
6643                                s   += unilen;
6644                                len += unilen;
6645                           }
6646                      }
6647                      len--;
6648                 }
6649                 else
6650                     REGC((char)ender, s++);
6651             }
6652         loopdone:
6653             RExC_parse = p - 1;
6654             Set_Node_Cur_Length(ret); /* MJD */
6655             nextchar(pRExC_state);
6656             {
6657                 /* len is STRLEN which is unsigned, need to copy to signed */
6658                 IV iv = len;
6659                 if (iv < 0)
6660                     vFAIL("Internal disaster");
6661             }
6662             if (len > 0)
6663                 *flagp |= HASWIDTH;
6664             if (len == 1 && UNI_IS_INVARIANT(ender))
6665                 *flagp |= SIMPLE;
6666
6667             if (SIZE_ONLY)
6668                 RExC_size += STR_SZ(len);
6669             else {
6670                 STR_LEN(ret) = len;
6671                 RExC_emit += STR_SZ(len);
6672             }
6673         }
6674         break;
6675     }
6676
6677     return(ret);
6678 }
6679
6680 STATIC char *
6681 S_regwhite(char *p, const char *e)
6682 {
6683     while (p < e) {
6684         if (isSPACE(*p))
6685             ++p;
6686         else if (*p == '#') {
6687             do {
6688                 p++;
6689             } while (p < e && *p != '\n');
6690         }
6691         else
6692             break;
6693     }
6694     return p;
6695 }
6696
6697 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
6698    Character classes ([:foo:]) can also be negated ([:^foo:]).
6699    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
6700    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
6701    but trigger failures because they are currently unimplemented. */
6702
6703 #define POSIXCC_DONE(c)   ((c) == ':')
6704 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
6705 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
6706
6707 STATIC I32
6708 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
6709 {
6710     dVAR;
6711     I32 namedclass = OOB_NAMEDCLASS;
6712
6713     if (value == '[' && RExC_parse + 1 < RExC_end &&
6714         /* I smell either [: or [= or [. -- POSIX has been here, right? */
6715         POSIXCC(UCHARAT(RExC_parse))) {
6716         const char c = UCHARAT(RExC_parse);
6717         char* const s = RExC_parse++;
6718
6719         while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
6720             RExC_parse++;
6721         if (RExC_parse == RExC_end)
6722             /* Grandfather lone [:, [=, [. */
6723             RExC_parse = s;
6724         else {
6725             const char* const t = RExC_parse++; /* skip over the c */
6726             assert(*t == c);
6727
6728             if (UCHARAT(RExC_parse) == ']') {
6729                 const char *posixcc = s + 1;
6730                 RExC_parse++; /* skip over the ending ] */
6731
6732                 if (*s == ':') {
6733                     const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
6734                     const I32 skip = t - posixcc;
6735
6736                     /* Initially switch on the length of the name.  */
6737                     switch (skip) {
6738                     case 4:
6739                         if (memEQ(posixcc, "word", 4)) /* this is not POSIX, this is the Perl \w */
6740                             namedclass = complement ? ANYOF_NALNUM : ANYOF_ALNUM;
6741                         break;
6742                     case 5:
6743                         /* Names all of length 5.  */
6744                         /* alnum alpha ascii blank cntrl digit graph lower
6745                            print punct space upper  */
6746                         /* Offset 4 gives the best switch position.  */
6747                         switch (posixcc[4]) {
6748                         case 'a':
6749                             if (memEQ(posixcc, "alph", 4)) /* alpha */
6750                                 namedclass = complement ? ANYOF_NALPHA : ANYOF_ALPHA;
6751                             break;
6752                         case 'e':
6753                             if (memEQ(posixcc, "spac", 4)) /* space */
6754                                 namedclass = complement ? ANYOF_NPSXSPC : ANYOF_PSXSPC;
6755                             break;
6756                         case 'h':
6757                             if (memEQ(posixcc, "grap", 4)) /* graph */
6758                                 namedclass = complement ? ANYOF_NGRAPH : ANYOF_GRAPH;
6759                             break;
6760                         case 'i':
6761                             if (memEQ(posixcc, "asci", 4)) /* ascii */
6762                                 namedclass = complement ? ANYOF_NASCII : ANYOF_ASCII;
6763                             break;
6764                         case 'k':
6765                             if (memEQ(posixcc, "blan", 4)) /* blank */
6766                                 namedclass = complement ? ANYOF_NBLANK : ANYOF_BLANK;
6767                             break;
6768                         case 'l':
6769                             if (memEQ(posixcc, "cntr", 4)) /* cntrl */
6770                                 namedclass = complement ? ANYOF_NCNTRL : ANYOF_CNTRL;
6771                             break;
6772                         case 'm':
6773                             if (memEQ(posixcc, "alnu", 4)) /* alnum */
6774                                 namedclass = complement ? ANYOF_NALNUMC : ANYOF_ALNUMC;
6775                             break;
6776                         case 'r':
6777                             if (memEQ(posixcc, "lowe", 4)) /* lower */
6778                                 namedclass = complement ? ANYOF_NLOWER : ANYOF_LOWER;
6779                             else if (memEQ(posixcc, "uppe", 4)) /* upper */
6780                                 namedclass = complement ? ANYOF_NUPPER : ANYOF_UPPER;
6781                             break;
6782                         case 't':
6783                             if (memEQ(posixcc, "digi", 4)) /* digit */
6784                                 namedclass = complement ? ANYOF_NDIGIT : ANYOF_DIGIT;
6785                             else if (memEQ(posixcc, "prin", 4)) /* print */
6786                                 namedclass = complement ? ANYOF_NPRINT : ANYOF_PRINT;
6787                             else if (memEQ(posixcc, "punc", 4)) /* punct */
6788                                 namedclass = complement ? ANYOF_NPUNCT : ANYOF_PUNCT;
6789                             break;
6790                         }
6791                         break;
6792                     case 6:
6793                         if (memEQ(posixcc, "xdigit", 6))
6794                             namedclass = complement ? ANYOF_NXDIGIT : ANYOF_XDIGIT;
6795                         break;
6796                     }
6797
6798                     if (namedclass == OOB_NAMEDCLASS)
6799                         Simple_vFAIL3("POSIX class [:%.*s:] unknown",
6800                                       t - s - 1, s + 1);
6801                     assert (posixcc[skip] == ':');
6802                     assert (posixcc[skip+1] == ']');
6803                 } else if (!SIZE_ONLY) {
6804                     /* [[=foo=]] and [[.foo.]] are still future. */
6805
6806                     /* adjust RExC_parse so the warning shows after
6807                        the class closes */
6808                     while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
6809                         RExC_parse++;
6810                     Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
6811                 }
6812             } else {
6813                 /* Maternal grandfather:
6814                  * "[:" ending in ":" but not in ":]" */
6815                 RExC_parse = s;
6816             }
6817         }
6818     }
6819
6820     return namedclass;
6821 }
6822
6823 STATIC void
6824 S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
6825 {
6826     dVAR;
6827     if (POSIXCC(UCHARAT(RExC_parse))) {
6828         const char *s = RExC_parse;
6829         const char  c = *s++;
6830
6831         while (isALNUM(*s))
6832             s++;
6833         if (*s && c == *s && s[1] == ']') {
6834             if (ckWARN(WARN_REGEXP))
6835                 vWARN3(s+2,
6836                         "POSIX syntax [%c %c] belongs inside character classes",
6837                         c, c);
6838
6839             /* [[=foo=]] and [[.foo.]] are still future. */
6840             if (POSIXCC_NOTYET(c)) {
6841                 /* adjust RExC_parse so the error shows after
6842                    the class closes */
6843                 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
6844                     NOOP;
6845                 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
6846             }
6847         }
6848     }
6849 }
6850
6851
6852 /*
6853    parse a class specification and produce either an ANYOF node that
6854    matches the pattern. If the pattern matches a single char only and
6855    that char is < 256 then we produce an EXACT node instead.
6856 */
6857 STATIC regnode *
6858 S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth)
6859 {
6860     dVAR;
6861     register UV value = 0;
6862     register UV nextvalue;
6863     register IV prevvalue = OOB_UNICODE;
6864     register IV range = 0;
6865     register regnode *ret;
6866     STRLEN numlen;
6867     IV namedclass;
6868     char *rangebegin = NULL;
6869     bool need_class = 0;
6870     SV *listsv = NULL;
6871     UV n;
6872     bool optimize_invert   = TRUE;
6873     AV* unicode_alternate  = NULL;
6874 #ifdef EBCDIC
6875     UV literal_endpoint = 0;
6876 #endif
6877     UV stored = 0;  /* number of chars stored in the class */
6878
6879     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
6880         case we need to change the emitted regop to an EXACT. */
6881     const char * orig_parse = RExC_parse;
6882     GET_RE_DEBUG_FLAGS_DECL;
6883 #ifndef DEBUGGING
6884     PERL_UNUSED_ARG(depth);
6885 #endif
6886
6887     DEBUG_PARSE("clas");
6888
6889     /* Assume we are going to generate an ANYOF node. */
6890     ret = reganode(pRExC_state, ANYOF, 0);
6891
6892     if (!SIZE_ONLY)
6893         ANYOF_FLAGS(ret) = 0;
6894
6895     if (UCHARAT(RExC_parse) == '^') {   /* Complement of range. */
6896         RExC_naughty++;
6897         RExC_parse++;
6898         if (!SIZE_ONLY)
6899             ANYOF_FLAGS(ret) |= ANYOF_INVERT;
6900     }
6901
6902     if (SIZE_ONLY) {
6903         RExC_size += ANYOF_SKIP;
6904         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
6905     }
6906     else {
6907         RExC_emit += ANYOF_SKIP;
6908         if (FOLD)
6909             ANYOF_FLAGS(ret) |= ANYOF_FOLD;
6910         if (LOC)
6911             ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
6912         ANYOF_BITMAP_ZERO(ret);
6913         listsv = newSVpvs("# comment\n");
6914     }
6915
6916     nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
6917
6918     if (!SIZE_ONLY && POSIXCC(nextvalue))
6919         checkposixcc(pRExC_state);
6920
6921     /* allow 1st char to be ] (allowing it to be - is dealt with later) */
6922     if (UCHARAT(RExC_parse) == ']')
6923         goto charclassloop;
6924
6925 parseit:
6926     while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
6927
6928     charclassloop:
6929
6930         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
6931
6932         if (!range)
6933             rangebegin = RExC_parse;
6934         if (UTF) {
6935             value = utf8n_to_uvchr((U8*)RExC_parse,
6936                                    RExC_end - RExC_parse,
6937                                    &numlen, UTF8_ALLOW_DEFAULT);
6938             RExC_parse += numlen;
6939         }
6940         else
6941             value = UCHARAT(RExC_parse++);
6942
6943         nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
6944         if (value == '[' && POSIXCC(nextvalue))
6945             namedclass = regpposixcc(pRExC_state, value);
6946         else if (value == '\\') {
6947             if (UTF) {
6948                 value = utf8n_to_uvchr((U8*)RExC_parse,
6949                                    RExC_end - RExC_parse,
6950                                    &numlen, UTF8_ALLOW_DEFAULT);
6951                 RExC_parse += numlen;
6952             }
6953             else
6954                 value = UCHARAT(RExC_parse++);
6955             /* Some compilers cannot handle switching on 64-bit integer
6956              * values, therefore value cannot be an UV.  Yes, this will
6957              * be a problem later if we want switch on Unicode.
6958              * A similar issue a little bit later when switching on
6959              * namedclass. --jhi */
6960             switch ((I32)value) {
6961             case 'w':   namedclass = ANYOF_ALNUM;       break;
6962             case 'W':   namedclass = ANYOF_NALNUM;      break;
6963             case 's':   namedclass = ANYOF_SPACE;       break;
6964             case 'S':   namedclass = ANYOF_NSPACE;      break;
6965             case 'd':   namedclass = ANYOF_DIGIT;       break;
6966             case 'D':   namedclass = ANYOF_NDIGIT;      break;
6967             case 'N':  /* Handle \N{NAME} in class */
6968                 {
6969                     /* We only pay attention to the first char of
6970                     multichar strings being returned. I kinda wonder
6971                     if this makes sense as it does change the behaviour
6972                     from earlier versions, OTOH that behaviour was broken
6973                     as well. */
6974                     UV v; /* value is register so we cant & it /grrr */
6975                     if (reg_namedseq(pRExC_state, &v)) {
6976                         goto parseit;
6977                     }
6978                     value= v;
6979                 }
6980                 break;
6981             case 'p':
6982             case 'P':
6983                 {
6984                 char *e;
6985                 if (RExC_parse >= RExC_end)
6986                     vFAIL2("Empty \\%c{}", (U8)value);
6987                 if (*RExC_parse == '{') {
6988                     const U8 c = (U8)value;
6989                     e = strchr(RExC_parse++, '}');
6990                     if (!e)
6991                         vFAIL2("Missing right brace on \\%c{}", c);
6992                     while (isSPACE(UCHARAT(RExC_parse)))
6993                         RExC_parse++;
6994                     if (e == RExC_parse)
6995                         vFAIL2("Empty \\%c{}", c);
6996                     n = e - RExC_parse;
6997                     while (isSPACE(UCHARAT(RExC_parse + n - 1)))
6998                         n--;
6999                 }
7000                 else {
7001                     e = RExC_parse;
7002                     n = 1;
7003                 }
7004                 if (!SIZE_ONLY) {
7005                     if (UCHARAT(RExC_parse) == '^') {
7006                          RExC_parse++;
7007                          n--;
7008                          value = value == 'p' ? 'P' : 'p'; /* toggle */
7009                          while (isSPACE(UCHARAT(RExC_parse))) {
7010                               RExC_parse++;
7011                               n--;
7012                          }
7013                     }
7014                     Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%.*s\n",
7015                         (value=='p' ? '+' : '!'), (int)n, RExC_parse);
7016                 }
7017                 RExC_parse = e + 1;
7018                 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
7019                 namedclass = ANYOF_MAX;  /* no official name, but it's named */
7020                 }
7021                 break;
7022             case 'n':   value = '\n';                   break;
7023             case 'r':   value = '\r';                   break;
7024             case 't':   value = '\t';                   break;
7025             case 'f':   value = '\f';                   break;
7026             case 'b':   value = '\b';                   break;
7027             case 'e':   value = ASCII_TO_NATIVE('\033');break;
7028             case 'a':   value = ASCII_TO_NATIVE('\007');break;
7029             case 'x':
7030                 if (*RExC_parse == '{') {
7031                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
7032                         | PERL_SCAN_DISALLOW_PREFIX;
7033                     char * const e = strchr(RExC_parse++, '}');
7034                     if (!e)
7035                         vFAIL("Missing right brace on \\x{}");
7036
7037                     numlen = e - RExC_parse;
7038                     value = grok_hex(RExC_parse, &numlen, &flags, NULL);
7039                     RExC_parse = e + 1;
7040                 }
7041                 else {
7042                     I32 flags = PERL_SCAN_DISALLOW_PREFIX;
7043                     numlen = 2;
7044                     value = grok_hex(RExC_parse, &numlen, &flags, NULL);
7045                     RExC_parse += numlen;
7046                 }
7047                 if (PL_encoding && value < 0x100)
7048                     goto recode_encoding;
7049                 break;
7050             case 'c':
7051                 value = UCHARAT(RExC_parse++);
7052                 value = toCTRL(value);
7053                 break;
7054             case '0': case '1': case '2': case '3': case '4':
7055             case '5': case '6': case '7': case '8': case '9':
7056                 {
7057                     I32 flags = 0;
7058                     numlen = 3;
7059                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
7060                     RExC_parse += numlen;
7061                     if (PL_encoding && value < 0x100)
7062                         goto recode_encoding;
7063                     break;
7064                 }
7065             recode_encoding:
7066                 {
7067                     SV* enc = PL_encoding;
7068                     value = reg_recode((const char)(U8)value, &enc);
7069                     if (!enc && SIZE_ONLY && ckWARN(WARN_REGEXP))
7070                         vWARN(RExC_parse,
7071                               "Invalid escape in the specified encoding");
7072                     break;
7073                 }
7074             default:
7075                 if (!SIZE_ONLY && isALPHA(value) && ckWARN(WARN_REGEXP))
7076                     vWARN2(RExC_parse,
7077                            "Unrecognized escape \\%c in character class passed through",
7078                            (int)value);
7079                 break;
7080             }
7081         } /* end of \blah */
7082 #ifdef EBCDIC
7083         else
7084             literal_endpoint++;
7085 #endif
7086
7087         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
7088
7089             if (!SIZE_ONLY && !need_class)
7090                 ANYOF_CLASS_ZERO(ret);
7091
7092             need_class = 1;
7093
7094             /* a bad range like a-\d, a-[:digit:] ? */
7095             if (range) {
7096                 if (!SIZE_ONLY) {
7097                     if (ckWARN(WARN_REGEXP)) {
7098                         const int w =
7099                             RExC_parse >= rangebegin ?
7100                             RExC_parse - rangebegin : 0;
7101                         vWARN4(RExC_parse,
7102                                "False [] range \"%*.*s\"",
7103                                w, w, rangebegin);
7104                     }
7105                     if (prevvalue < 256) {
7106                         ANYOF_BITMAP_SET(ret, prevvalue);
7107                         ANYOF_BITMAP_SET(ret, '-');
7108                     }
7109                     else {
7110                         ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
7111                         Perl_sv_catpvf(aTHX_ listsv,
7112                                        "%04"UVxf"\n%04"UVxf"\n", (UV)prevvalue, (UV) '-');
7113                     }
7114                 }
7115
7116                 range = 0; /* this was not a true range */
7117             }
7118
7119             if (!SIZE_ONLY) {
7120                 const char *what = NULL;
7121                 char yesno = 0;
7122
7123                 if (namedclass > OOB_NAMEDCLASS)
7124                     optimize_invert = FALSE;
7125                 /* Possible truncation here but in some 64-bit environments
7126                  * the compiler gets heartburn about switch on 64-bit values.
7127                  * A similar issue a little earlier when switching on value.
7128                  * --jhi */
7129                 switch ((I32)namedclass) {
7130                 case ANYOF_ALNUM:
7131                     if (LOC)
7132                         ANYOF_CLASS_SET(ret, ANYOF_ALNUM);
7133                     else {
7134                         for (value = 0; value < 256; value++)
7135                             if (isALNUM(value))
7136                                 ANYOF_BITMAP_SET(ret, value);
7137                     }
7138                     yesno = '+';
7139                     what = "Word";
7140                     break;
7141                 case ANYOF_NALNUM:
7142                     if (LOC)
7143                         ANYOF_CLASS_SET(ret, ANYOF_NALNUM);
7144                     else {
7145                         for (value = 0; value < 256; value++)
7146                             if (!isALNUM(value))
7147                                 ANYOF_BITMAP_SET(ret, value);
7148                     }
7149                     yesno = '!';
7150                     what = "Word";
7151                     break;
7152                 case ANYOF_ALNUMC:
7153                     if (LOC)
7154                         ANYOF_CLASS_SET(ret, ANYOF_ALNUMC);
7155                     else {
7156                         for (value = 0; value < 256; value++)
7157                             if (isALNUMC(value))
7158                                 ANYOF_BITMAP_SET(ret, value);
7159                     }
7160                     yesno = '+';
7161                     what = "Alnum";
7162                     break;
7163                 case ANYOF_NALNUMC:
7164                     if (LOC)
7165                         ANYOF_CLASS_SET(ret, ANYOF_NALNUMC);
7166                     else {
7167                         for (value = 0; value < 256; value++)
7168                             if (!isALNUMC(value))
7169                                 ANYOF_BITMAP_SET(ret, value);
7170                     }
7171                     yesno = '!';
7172                     what = "Alnum";
7173                     break;
7174                 case ANYOF_ALPHA:
7175                     if (LOC)
7176                         ANYOF_CLASS_SET(ret, ANYOF_ALPHA);
7177                     else {
7178                         for (value = 0; value < 256; value++)
7179                             if (isALPHA(value))
7180                                 ANYOF_BITMAP_SET(ret, value);
7181                     }
7182                     yesno = '+';
7183                     what = "Alpha";
7184                     break;
7185                 case ANYOF_NALPHA:
7186                     if (LOC)
7187                         ANYOF_CLASS_SET(ret, ANYOF_NALPHA);
7188                     else {
7189                         for (value = 0; value < 256; value++)
7190                             if (!isALPHA(value))
7191                                 ANYOF_BITMAP_SET(ret, value);
7192                     }
7193                     yesno = '!';
7194                     what = "Alpha";
7195                     break;
7196                 case ANYOF_ASCII:
7197                     if (LOC)
7198                         ANYOF_CLASS_SET(ret, ANYOF_ASCII);
7199                     else {
7200 #ifndef EBCDIC
7201                         for (value = 0; value < 128; value++)
7202                             ANYOF_BITMAP_SET(ret, value);
7203 #else  /* EBCDIC */
7204                         for (value = 0; value < 256; value++) {
7205                             if (isASCII(value))
7206                                 ANYOF_BITMAP_SET(ret, value);
7207                         }
7208 #endif /* EBCDIC */
7209                     }
7210                     yesno = '+';
7211                     what = "ASCII";
7212                     break;
7213                 case ANYOF_NASCII:
7214                     if (LOC)
7215                         ANYOF_CLASS_SET(ret, ANYOF_NASCII);
7216                     else {
7217 #ifndef EBCDIC
7218                         for (value = 128; value < 256; value++)
7219                             ANYOF_BITMAP_SET(ret, value);
7220 #else  /* EBCDIC */
7221                         for (value = 0; value < 256; value++) {
7222                             if (!isASCII(value))
7223                                 ANYOF_BITMAP_SET(ret, value);
7224                         }
7225 #endif /* EBCDIC */
7226                     }
7227                     yesno = '!';
7228                     what = "ASCII";
7229                     break;
7230                 case ANYOF_BLANK:
7231                     if (LOC)
7232                         ANYOF_CLASS_SET(ret, ANYOF_BLANK);
7233                     else {
7234                         for (value = 0; value < 256; value++)
7235                             if (isBLANK(value))
7236                                 ANYOF_BITMAP_SET(ret, value);
7237                     }
7238                     yesno = '+';
7239                     what = "Blank";
7240                     break;
7241                 case ANYOF_NBLANK:
7242                     if (LOC)
7243                         ANYOF_CLASS_SET(ret, ANYOF_NBLANK);
7244                     else {
7245                         for (value = 0; value < 256; value++)
7246                             if (!isBLANK(value))
7247                                 ANYOF_BITMAP_SET(ret, value);
7248                     }
7249                     yesno = '!';
7250                     what = "Blank";
7251                     break;
7252                 case ANYOF_CNTRL:
7253                     if (LOC)
7254                         ANYOF_CLASS_SET(ret, ANYOF_CNTRL);
7255                     else {
7256                         for (value = 0; value < 256; value++)
7257                             if (isCNTRL(value))
7258                                 ANYOF_BITMAP_SET(ret, value);
7259                     }
7260                     yesno = '+';
7261                     what = "Cntrl";
7262                     break;
7263                 case ANYOF_NCNTRL:
7264                     if (LOC)
7265                         ANYOF_CLASS_SET(ret, ANYOF_NCNTRL);
7266                     else {
7267                         for (value = 0; value < 256; value++)
7268                             if (!isCNTRL(value))
7269                                 ANYOF_BITMAP_SET(ret, value);
7270                     }
7271                     yesno = '!';
7272                     what = "Cntrl";
7273                     break;
7274                 case ANYOF_DIGIT:
7275                     if (LOC)
7276                         ANYOF_CLASS_SET(ret, ANYOF_DIGIT);
7277                     else {
7278                         /* consecutive digits assumed */
7279                         for (value = '0'; value <= '9'; value++)
7280                             ANYOF_BITMAP_SET(ret, value);
7281                     }
7282                     yesno = '+';
7283                     what = "Digit";
7284                     break;
7285                 case ANYOF_NDIGIT:
7286                     if (LOC)
7287                         ANYOF_CLASS_SET(ret, ANYOF_NDIGIT);
7288                     else {
7289                         /* consecutive digits assumed */
7290                         for (value = 0; value < '0'; value++)
7291                             ANYOF_BITMAP_SET(ret, value);
7292                         for (value = '9' + 1; value < 256; value++)
7293                             ANYOF_BITMAP_SET(ret, value);
7294                     }
7295                     yesno = '!';
7296                     what = "Digit";
7297                     break;
7298                 case ANYOF_GRAPH:
7299                     if (LOC)
7300                         ANYOF_CLASS_SET(ret, ANYOF_GRAPH);
7301                     else {
7302                         for (value = 0; value < 256; value++)
7303                             if (isGRAPH(value))
7304                                 ANYOF_BITMAP_SET(ret, value);
7305                     }
7306                     yesno = '+';
7307                     what = "Graph";
7308                     break;
7309                 case ANYOF_NGRAPH:
7310                     if (LOC)
7311                         ANYOF_CLASS_SET(ret, ANYOF_NGRAPH);
7312                     else {
7313                         for (value = 0; value < 256; value++)
7314                             if (!isGRAPH(value))
7315                                 ANYOF_BITMAP_SET(ret, value);
7316                     }
7317                     yesno = '!';
7318                     what = "Graph";
7319                     break;
7320                 case ANYOF_LOWER:
7321                     if (LOC)
7322                         ANYOF_CLASS_SET(ret, ANYOF_LOWER);
7323                     else {
7324                         for (value = 0; value < 256; value++)
7325                             if (isLOWER(value))
7326                                 ANYOF_BITMAP_SET(ret, value);
7327                     }
7328                     yesno = '+';
7329                     what = "Lower";
7330                     break;
7331                 case ANYOF_NLOWER:
7332                     if (LOC)
7333                         ANYOF_CLASS_SET(ret, ANYOF_NLOWER);
7334                     else {
7335                         for (value = 0; value < 256; value++)
7336                             if (!isLOWER(value))
7337                                 ANYOF_BITMAP_SET(ret, value);
7338                     }
7339                     yesno = '!';
7340                     what = "Lower";
7341                     break;
7342                 case ANYOF_PRINT:
7343                     if (LOC)
7344                         ANYOF_CLASS_SET(ret, ANYOF_PRINT);
7345                     else {
7346                         for (value = 0; value < 256; value++)
7347                             if (isPRINT(value))
7348                                 ANYOF_BITMAP_SET(ret, value);
7349                     }
7350                     yesno = '+';
7351                     what = "Print";
7352                     break;
7353                 case ANYOF_NPRINT:
7354                     if (LOC)
7355                         ANYOF_CLASS_SET(ret, ANYOF_NPRINT);
7356                     else {
7357                         for (value = 0; value < 256; value++)
7358                             if (!isPRINT(value))
7359                                 ANYOF_BITMAP_SET(ret, value);
7360                     }
7361                     yesno = '!';
7362                     what = "Print";
7363                     break;
7364                 case ANYOF_PSXSPC:
7365                     if (LOC)
7366                         ANYOF_CLASS_SET(ret, ANYOF_PSXSPC);
7367                     else {
7368                         for (value = 0; value < 256; value++)
7369                             if (isPSXSPC(value))
7370                                 ANYOF_BITMAP_SET(ret, value);
7371                     }
7372                     yesno = '+';
7373                     what = "Space";
7374                     break;
7375                 case ANYOF_NPSXSPC:
7376                     if (LOC)
7377                         ANYOF_CLASS_SET(ret, ANYOF_NPSXSPC);
7378                     else {
7379                         for (value = 0; value < 256; value++)
7380                             if (!isPSXSPC(value))
7381                                 ANYOF_BITMAP_SET(ret, value);
7382                     }
7383                     yesno = '!';
7384                     what = "Space";
7385                     break;
7386                 case ANYOF_PUNCT:
7387                     if (LOC)
7388                         ANYOF_CLASS_SET(ret, ANYOF_PUNCT);
7389                     else {
7390                         for (value = 0; value < 256; value++)
7391                             if (isPUNCT(value))
7392                                 ANYOF_BITMAP_SET(ret, value);
7393                     }
7394                     yesno = '+';
7395                     what = "Punct";
7396                     break;
7397                 case ANYOF_NPUNCT:
7398                     if (LOC)
7399                         ANYOF_CLASS_SET(ret, ANYOF_NPUNCT);
7400                     else {
7401                         for (value = 0; value < 256; value++)
7402                             if (!isPUNCT(value))
7403                                 ANYOF_BITMAP_SET(ret, value);
7404                     }
7405                     yesno = '!';
7406                     what = "Punct";
7407                     break;
7408                 case ANYOF_SPACE:
7409                     if (LOC)
7410                         ANYOF_CLASS_SET(ret, ANYOF_SPACE);
7411                     else {
7412                         for (value = 0; value < 256; value++)
7413                             if (isSPACE(value))
7414                                 ANYOF_BITMAP_SET(ret, value);
7415                     }
7416                     yesno = '+';
7417                     what = "SpacePerl";
7418                     break;
7419                 case ANYOF_NSPACE:
7420                     if (LOC)
7421                         ANYOF_CLASS_SET(ret, ANYOF_NSPACE);
7422                     else {
7423                         for (value = 0; value < 256; value++)
7424                             if (!isSPACE(value))
7425                                 ANYOF_BITMAP_SET(ret, value);
7426                     }
7427                     yesno = '!';
7428                     what = "SpacePerl";
7429                     break;
7430                 case ANYOF_UPPER:
7431                     if (LOC)
7432                         ANYOF_CLASS_SET(ret, ANYOF_UPPER);
7433                     else {
7434                         for (value = 0; value < 256; value++)
7435                             if (isUPPER(value))
7436                                 ANYOF_BITMAP_SET(ret, value);
7437                     }
7438                     yesno = '+';
7439                     what = "Upper";
7440                     break;
7441                 case ANYOF_NUPPER:
7442                     if (LOC)
7443                         ANYOF_CLASS_SET(ret, ANYOF_NUPPER);
7444                     else {
7445                         for (value = 0; value < 256; value++)
7446                             if (!isUPPER(value))
7447                                 ANYOF_BITMAP_SET(ret, value);
7448                     }
7449                     yesno = '!';
7450                     what = "Upper";
7451                     break;
7452                 case ANYOF_XDIGIT:
7453                     if (LOC)
7454                         ANYOF_CLASS_SET(ret, ANYOF_XDIGIT);
7455                     else {
7456                         for (value = 0; value < 256; value++)
7457                             if (isXDIGIT(value))
7458                                 ANYOF_BITMAP_SET(ret, value);
7459                     }
7460                     yesno = '+';
7461                     what = "XDigit";
7462                     break;
7463                 case ANYOF_NXDIGIT:
7464                     if (LOC)
7465                         ANYOF_CLASS_SET(ret, ANYOF_NXDIGIT);
7466                     else {
7467                         for (value = 0; value < 256; value++)
7468                             if (!isXDIGIT(value))
7469                                 ANYOF_BITMAP_SET(ret, value);
7470                     }
7471                     yesno = '!';
7472                     what = "XDigit";
7473                     break;
7474                 case ANYOF_MAX:
7475                     /* this is to handle \p and \P */
7476                     break;
7477                 default:
7478                     vFAIL("Invalid [::] class");
7479                     break;
7480                 }
7481                 if (what) {
7482                     /* Strings such as "+utf8::isWord\n" */
7483                     Perl_sv_catpvf(aTHX_ listsv, "%cutf8::Is%s\n", yesno, what);
7484                 }
7485                 if (LOC)
7486                     ANYOF_FLAGS(ret) |= ANYOF_CLASS;
7487                 continue;
7488             }
7489         } /* end of namedclass \blah */
7490
7491         if (range) {
7492             if (prevvalue > (IV)value) /* b-a */ {
7493                 const int w = RExC_parse - rangebegin;
7494                 Simple_vFAIL4("Invalid [] range \"%*.*s\"", w, w, rangebegin);
7495                 range = 0; /* not a valid range */
7496             }
7497         }
7498         else {
7499             prevvalue = value; /* save the beginning of the range */
7500             if (*RExC_parse == '-' && RExC_parse+1 < RExC_end &&
7501                 RExC_parse[1] != ']') {
7502                 RExC_parse++;
7503
7504                 /* a bad range like \w-, [:word:]- ? */
7505                 if (namedclass > OOB_NAMEDCLASS) {
7506                     if (ckWARN(WARN_REGEXP)) {
7507                         const int w =
7508                             RExC_parse >= rangebegin ?
7509                             RExC_parse - rangebegin : 0;
7510                         vWARN4(RExC_parse,
7511                                "False [] range \"%*.*s\"",
7512                                w, w, rangebegin);
7513                     }
7514                     if (!SIZE_ONLY)
7515                         ANYOF_BITMAP_SET(ret, '-');
7516                 } else
7517                     range = 1;  /* yeah, it's a range! */
7518                 continue;       /* but do it the next time */
7519             }
7520         }
7521
7522         /* now is the next time */
7523         /*stored += (value - prevvalue + 1);*/
7524         if (!SIZE_ONLY) {
7525             if (prevvalue < 256) {
7526                 const IV ceilvalue = value < 256 ? value : 255;
7527                 IV i;
7528 #ifdef EBCDIC
7529                 /* In EBCDIC [\x89-\x91] should include
7530                  * the \x8e but [i-j] should not. */
7531                 if (literal_endpoint == 2 &&
7532                     ((isLOWER(prevvalue) && isLOWER(ceilvalue)) ||
7533                      (isUPPER(prevvalue) && isUPPER(ceilvalue))))
7534                 {
7535                     if (isLOWER(prevvalue)) {
7536                         for (i = prevvalue; i <= ceilvalue; i++)
7537                             if (isLOWER(i))
7538                                 ANYOF_BITMAP_SET(ret, i);
7539                     } else {
7540                         for (i = prevvalue; i <= ceilvalue; i++)
7541                             if (isUPPER(i))
7542                                 ANYOF_BITMAP_SET(ret, i);
7543                     }
7544                 }
7545                 else
7546 #endif
7547                       for (i = prevvalue; i <= ceilvalue; i++) {
7548                         if (!ANYOF_BITMAP_TEST(ret,i)) {
7549                             stored++;
7550                             ANYOF_BITMAP_SET(ret, i);
7551                         }
7552                       }
7553           }
7554           if (value > 255 || UTF) {
7555                 const UV prevnatvalue  = NATIVE_TO_UNI(prevvalue);
7556                 const UV natvalue      = NATIVE_TO_UNI(value);
7557                 stored+=2; /* can't optimize this class */
7558                 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
7559                 if (prevnatvalue < natvalue) { /* what about > ? */
7560                     Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
7561                                    prevnatvalue, natvalue);
7562                 }
7563                 else if (prevnatvalue == natvalue) {
7564                     Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", natvalue);
7565                     if (FOLD) {
7566                          U8 foldbuf[UTF8_MAXBYTES_CASE+1];
7567                          STRLEN foldlen;
7568                          const UV f = to_uni_fold(natvalue, foldbuf, &foldlen);
7569
7570 #ifdef EBCDIC /* RD t/uni/fold ff and 6b */
7571                          if (RExC_precomp[0] == ':' &&
7572                              RExC_precomp[1] == '[' &&
7573                              (f == 0xDF || f == 0x92)) {
7574                              f = NATIVE_TO_UNI(f);
7575                         }
7576 #endif
7577                          /* If folding and foldable and a single
7578                           * character, insert also the folded version
7579                           * to the charclass. */
7580                          if (f != value) {
7581 #ifdef EBCDIC /* RD tunifold ligatures s,t fb05, fb06 */
7582                              if ((RExC_precomp[0] == ':' &&
7583                                   RExC_precomp[1] == '[' &&
7584                                   (f == 0xA2 &&
7585                                    (value == 0xFB05 || value == 0xFB06))) ?
7586                                  foldlen == ((STRLEN)UNISKIP(f) - 1) :
7587                                  foldlen == (STRLEN)UNISKIP(f) )
7588 #else
7589                               if (foldlen == (STRLEN)UNISKIP(f))
7590 #endif
7591                                   Perl_sv_catpvf(aTHX_ listsv,
7592                                                  "%04"UVxf"\n", f);
7593                               else {
7594                                   /* Any multicharacter foldings
7595                                    * require the following transform:
7596                                    * [ABCDEF] -> (?:[ABCabcDEFd]|pq|rst)
7597                                    * where E folds into "pq" and F folds
7598                                    * into "rst", all other characters
7599                                    * fold to single characters.  We save
7600                                    * away these multicharacter foldings,
7601                                    * to be later saved as part of the
7602                                    * additional "s" data. */
7603                                   SV *sv;
7604
7605                                   if (!unicode_alternate)
7606                                       unicode_alternate = newAV();
7607                                   sv = newSVpvn((char*)foldbuf, foldlen);
7608                                   SvUTF8_on(sv);
7609                                   av_push(unicode_alternate, sv);
7610                               }
7611                          }
7612
7613                          /* If folding and the value is one of the Greek
7614                           * sigmas insert a few more sigmas to make the
7615                           * folding rules of the sigmas to work right.
7616                           * Note that not all the possible combinations
7617                           * are handled here: some of them are handled
7618                           * by the standard folding rules, and some of
7619                           * them (literal or EXACTF cases) are handled
7620                           * during runtime in regexec.c:S_find_byclass(). */
7621                          if (value == UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA) {
7622                               Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
7623                                              (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA);
7624                               Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
7625                                              (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
7626                          }
7627                          else if (value == UNICODE_GREEK_CAPITAL_LETTER_SIGMA)
7628                               Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
7629                                              (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
7630                     }
7631                 }
7632             }
7633 #ifdef EBCDIC
7634             literal_endpoint = 0;
7635 #endif
7636         }
7637
7638         range = 0; /* this range (if it was one) is done now */
7639     }
7640
7641     if (need_class) {
7642         ANYOF_FLAGS(ret) |= ANYOF_LARGE;
7643         if (SIZE_ONLY)
7644             RExC_size += ANYOF_CLASS_ADD_SKIP;
7645         else
7646             RExC_emit += ANYOF_CLASS_ADD_SKIP;
7647     }
7648
7649
7650     if (SIZE_ONLY)
7651         return ret;
7652     /****** !SIZE_ONLY AFTER HERE *********/
7653
7654     if( stored == 1 && value < 256
7655         && !( ANYOF_FLAGS(ret) & ( ANYOF_FLAGS_ALL ^ ANYOF_FOLD ) )
7656     ) {
7657         /* optimize single char class to an EXACT node
7658            but *only* when its not a UTF/high char  */
7659         const char * cur_parse= RExC_parse;
7660         RExC_emit = (regnode *)orig_emit;
7661         RExC_parse = (char *)orig_parse;
7662         ret = reg_node(pRExC_state,
7663                        (U8)((ANYOF_FLAGS(ret) & ANYOF_FOLD) ? EXACTF : EXACT));
7664         RExC_parse = (char *)cur_parse;
7665         *STRING(ret)= (char)value;
7666         STR_LEN(ret)= 1;
7667         RExC_emit += STR_SZ(1);
7668         return ret;
7669     }
7670     /* optimize case-insensitive simple patterns (e.g. /[a-z]/i) */
7671     if ( /* If the only flag is folding (plus possibly inversion). */
7672         ((ANYOF_FLAGS(ret) & (ANYOF_FLAGS_ALL ^ ANYOF_INVERT)) == ANYOF_FOLD)
7673        ) {
7674         for (value = 0; value < 256; ++value) {
7675             if (ANYOF_BITMAP_TEST(ret, value)) {
7676                 UV fold = PL_fold[value];
7677
7678                 if (fold != value)
7679                     ANYOF_BITMAP_SET(ret, fold);
7680             }
7681         }
7682         ANYOF_FLAGS(ret) &= ~ANYOF_FOLD;
7683     }
7684
7685     /* optimize inverted simple patterns (e.g. [^a-z]) */
7686     if (optimize_invert &&
7687         /* If the only flag is inversion. */
7688         (ANYOF_FLAGS(ret) & ANYOF_FLAGS_ALL) == ANYOF_INVERT) {
7689         for (value = 0; value < ANYOF_BITMAP_SIZE; ++value)
7690             ANYOF_BITMAP(ret)[value] ^= ANYOF_FLAGS_ALL;
7691         ANYOF_FLAGS(ret) = ANYOF_UNICODE_ALL;
7692     }
7693     {
7694         AV * const av = newAV();
7695         SV *rv;
7696         /* The 0th element stores the character class description
7697          * in its textual form: used later (regexec.c:Perl_regclass_swash())
7698          * to initialize the appropriate swash (which gets stored in
7699          * the 1st element), and also useful for dumping the regnode.
7700          * The 2nd element stores the multicharacter foldings,
7701          * used later (regexec.c:S_reginclass()). */
7702         av_store(av, 0, listsv);
7703         av_store(av, 1, NULL);
7704         av_store(av, 2, (SV*)unicode_alternate);
7705         rv = newRV_noinc((SV*)av);
7706         n = add_data(pRExC_state, 1, "s");
7707         RExC_rxi->data->data[n] = (void*)rv;
7708         ARG_SET(ret, n);
7709     }
7710     return ret;
7711 }
7712
7713 STATIC char*
7714 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
7715 {
7716     char* const retval = RExC_parse++;
7717
7718     for (;;) {
7719         if (*RExC_parse == '(' && RExC_parse[1] == '?' &&
7720                 RExC_parse[2] == '#') {
7721             while (*RExC_parse != ')') {
7722                 if (RExC_parse == RExC_end)
7723                     FAIL("Sequence (?#... not terminated");
7724                 RExC_parse++;
7725             }
7726             RExC_parse++;
7727             continue;
7728         }
7729         if (RExC_flags & RXf_PMf_EXTENDED) {
7730             if (isSPACE(*RExC_parse)) {
7731                 RExC_parse++;
7732                 continue;
7733             }
7734             else if (*RExC_parse == '#') {
7735                 while (RExC_parse < RExC_end)
7736                     if (*RExC_parse++ == '\n') break;
7737                 continue;
7738             }
7739         }
7740         return retval;
7741     }
7742 }
7743
7744 /*
7745 - reg_node - emit a node
7746 */
7747 STATIC regnode *                        /* Location. */
7748 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
7749 {
7750     dVAR;
7751     register regnode *ptr;
7752     regnode * const ret = RExC_emit;
7753     GET_RE_DEBUG_FLAGS_DECL;
7754
7755     if (SIZE_ONLY) {
7756         SIZE_ALIGN(RExC_size);
7757         RExC_size += 1;
7758         return(ret);
7759     }
7760 #ifdef DEBUGGING
7761     if (OP(RExC_emit) == 255)
7762         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %s: %d ",
7763             reg_name[op], OP(RExC_emit));
7764 #endif
7765     NODE_ALIGN_FILL(ret);
7766     ptr = ret;
7767     FILL_ADVANCE_NODE(ptr, op);
7768     if (RExC_offsets) {         /* MJD */
7769         MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n",
7770               "reg_node", __LINE__,
7771               reg_name[op],
7772               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0]
7773                 ? "Overwriting end of array!\n" : "OK",
7774               (UV)(RExC_emit - RExC_emit_start),
7775               (UV)(RExC_parse - RExC_start),
7776               (UV)RExC_offsets[0]));
7777         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
7778     }
7779
7780     RExC_emit = ptr;
7781     return(ret);
7782 }
7783
7784 /*
7785 - reganode - emit a node with an argument
7786 */
7787 STATIC regnode *                        /* Location. */
7788 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
7789 {
7790     dVAR;
7791     register regnode *ptr;
7792     regnode * const ret = RExC_emit;
7793     GET_RE_DEBUG_FLAGS_DECL;
7794
7795     if (SIZE_ONLY) {
7796         SIZE_ALIGN(RExC_size);
7797         RExC_size += 2;
7798         /*
7799            We can't do this:
7800
7801            assert(2==regarglen[op]+1);
7802
7803            Anything larger than this has to allocate the extra amount.
7804            If we changed this to be:
7805
7806            RExC_size += (1 + regarglen[op]);
7807
7808            then it wouldn't matter. Its not clear what side effect
7809            might come from that so its not done so far.
7810            -- dmq
7811         */
7812         return(ret);
7813     }
7814 #ifdef DEBUGGING
7815     if (OP(RExC_emit) == 255)
7816         Perl_croak(aTHX_ "panic: reganode overwriting end of allocated program space");
7817 #endif
7818     NODE_ALIGN_FILL(ret);
7819     ptr = ret;
7820     FILL_ADVANCE_NODE_ARG(ptr, op, arg);
7821     if (RExC_offsets) {         /* MJD */
7822         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n",
7823               "reganode",
7824               __LINE__,
7825               reg_name[op],
7826               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ?
7827               "Overwriting end of array!\n" : "OK",
7828               (UV)(RExC_emit - RExC_emit_start),
7829               (UV)(RExC_parse - RExC_start),
7830               (UV)RExC_offsets[0]));
7831         Set_Cur_Node_Offset;
7832     }
7833
7834     RExC_emit = ptr;
7835     return(ret);
7836 }
7837
7838 /*
7839 - reguni - emit (if appropriate) a Unicode character
7840 */
7841 STATIC STRLEN
7842 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
7843 {
7844     dVAR;
7845     return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
7846 }
7847
7848 /*
7849 - reginsert - insert an operator in front of already-emitted operand
7850 *
7851 * Means relocating the operand.
7852 */
7853 STATIC void
7854 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
7855 {
7856     dVAR;
7857     register regnode *src;
7858     register regnode *dst;
7859     register regnode *place;
7860     const int offset = regarglen[(U8)op];
7861     const int size = NODE_STEP_REGNODE + offset;
7862     GET_RE_DEBUG_FLAGS_DECL;
7863 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
7864     DEBUG_PARSE_FMT("inst"," - %s",reg_name[op]);
7865     if (SIZE_ONLY) {
7866         RExC_size += size;
7867         return;
7868     }
7869
7870     src = RExC_emit;
7871     RExC_emit += size;
7872     dst = RExC_emit;
7873     if (RExC_open_parens) {
7874         int paren;
7875         DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);
7876         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
7877             if ( RExC_open_parens[paren] >= opnd ) {
7878                 DEBUG_PARSE_FMT("open"," - %d",size);
7879                 RExC_open_parens[paren] += size;
7880             } else {
7881                 DEBUG_PARSE_FMT("open"," - %s","ok");
7882             }
7883             if ( RExC_close_parens[paren] >= opnd ) {
7884                 DEBUG_PARSE_FMT("close"," - %d",size);
7885                 RExC_close_parens[paren] += size;
7886             } else {
7887                 DEBUG_PARSE_FMT("close"," - %s","ok");
7888             }
7889         }
7890     }
7891
7892     while (src > opnd) {
7893         StructCopy(--src, --dst, regnode);
7894         if (RExC_offsets) {     /* MJD 20010112 */
7895             MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
7896                   "reg_insert",
7897                   __LINE__,
7898                   reg_name[op],
7899                   (UV)(dst - RExC_emit_start) > RExC_offsets[0]
7900                     ? "Overwriting end of array!\n" : "OK",
7901                   (UV)(src - RExC_emit_start),
7902                   (UV)(dst - RExC_emit_start),
7903                   (UV)RExC_offsets[0]));
7904             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
7905             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
7906         }
7907     }
7908
7909
7910     place = opnd;               /* Op node, where operand used to be. */
7911     if (RExC_offsets) {         /* MJD */
7912         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n",
7913               "reginsert",
7914               __LINE__,
7915               reg_name[op],
7916               (UV)(place - RExC_emit_start) > RExC_offsets[0]
7917               ? "Overwriting end of array!\n" : "OK",
7918               (UV)(place - RExC_emit_start),
7919               (UV)(RExC_parse - RExC_start),
7920               (UV)RExC_offsets[0]));
7921         Set_Node_Offset(place, RExC_parse);
7922         Set_Node_Length(place, 1);
7923     }
7924     src = NEXTOPER(place);
7925     FILL_ADVANCE_NODE(place, op);
7926     Zero(src, offset, regnode);
7927 }
7928
7929 /*
7930 - regtail - set the next-pointer at the end of a node chain of p to val.
7931 - SEE ALSO: regtail_study
7932 */
7933 /* TODO: All three parms should be const */
7934 STATIC void
7935 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
7936 {
7937     dVAR;
7938     register regnode *scan;
7939     GET_RE_DEBUG_FLAGS_DECL;
7940 #ifndef DEBUGGING
7941     PERL_UNUSED_ARG(depth);
7942 #endif
7943
7944     if (SIZE_ONLY)
7945         return;
7946
7947     /* Find last node. */
7948     scan = p;
7949     for (;;) {
7950         regnode * const temp = regnext(scan);
7951         DEBUG_PARSE_r({
7952             SV * const mysv=sv_newmortal();
7953             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
7954             regprop(RExC_rx, mysv, scan);
7955             PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
7956                 SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
7957                     (temp == NULL ? "->" : ""),
7958                     (temp == NULL ? reg_name[OP(val)] : "")
7959             );
7960         });
7961         if (temp == NULL)
7962             break;
7963         scan = temp;
7964     }
7965
7966     if (reg_off_by_arg[OP(scan)]) {
7967         ARG_SET(scan, val - scan);
7968     }
7969     else {
7970         NEXT_OFF(scan) = val - scan;
7971     }
7972 }
7973
7974 #ifdef DEBUGGING
7975 /*
7976 - regtail_study - set the next-pointer at the end of a node chain of p to val.
7977 - Look for optimizable sequences at the same time.
7978 - currently only looks for EXACT chains.
7979
7980 This is expermental code. The idea is to use this routine to perform
7981 in place optimizations on branches and groups as they are constructed,
7982 with the long term intention of removing optimization from study_chunk so
7983 that it is purely analytical.
7984
7985 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
7986 to control which is which.
7987
7988 */
7989 /* TODO: All four parms should be const */
7990
7991 STATIC U8
7992 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
7993 {
7994     dVAR;
7995     register regnode *scan;
7996     U8 exact = PSEUDO;
7997 #ifdef EXPERIMENTAL_INPLACESCAN
7998     I32 min = 0;
7999 #endif
8000
8001     GET_RE_DEBUG_FLAGS_DECL;
8002
8003
8004     if (SIZE_ONLY)
8005         return exact;
8006
8007     /* Find last node. */
8008
8009     scan = p;
8010     for (;;) {
8011         regnode * const temp = regnext(scan);
8012 #ifdef EXPERIMENTAL_INPLACESCAN
8013         if (PL_regkind[OP(scan)] == EXACT)
8014             if (join_exact(pRExC_state,scan,&min,1,val,depth+1))
8015                 return EXACT;
8016 #endif
8017         if ( exact ) {
8018             switch (OP(scan)) {
8019                 case EXACT:
8020                 case EXACTF:
8021                 case EXACTFL:
8022                         if( exact == PSEUDO )
8023                             exact= OP(scan);
8024                         else if ( exact != OP(scan) )
8025                             exact= 0;
8026                 case NOTHING:
8027                     break;
8028                 default:
8029                     exact= 0;
8030             }
8031         }
8032         DEBUG_PARSE_r({
8033             SV * const mysv=sv_newmortal();
8034             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
8035             regprop(RExC_rx, mysv, scan);
8036             PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
8037                 SvPV_nolen_const(mysv),
8038                 REG_NODE_NUM(scan),
8039                 reg_name[exact]);
8040         });
8041         if (temp == NULL)
8042             break;
8043         scan = temp;
8044     }
8045     DEBUG_PARSE_r({
8046         SV * const mysv_val=sv_newmortal();
8047         DEBUG_PARSE_MSG("");
8048         regprop(RExC_rx, mysv_val, val);
8049         PerlIO_printf(Perl_debug_log, "~ attach to %s (%d) offset to %d\n",
8050             SvPV_nolen_const(mysv_val),
8051             REG_NODE_NUM(val),
8052             val - scan
8053         );
8054     });
8055     if (reg_off_by_arg[OP(scan)]) {
8056         ARG_SET(scan, val - scan);
8057     }
8058     else {
8059         NEXT_OFF(scan) = val - scan;
8060     }
8061
8062     return exact;
8063 }
8064 #endif
8065
8066 /*
8067  - regcurly - a little FSA that accepts {\d+,?\d*}
8068  */
8069 STATIC I32
8070 S_regcurly(register const char *s)
8071 {
8072     if (*s++ != '{')
8073         return FALSE;
8074     if (!isDIGIT(*s))
8075         return FALSE;
8076     while (isDIGIT(*s))
8077         s++;
8078     if (*s == ',')
8079         s++;
8080     while (isDIGIT(*s))
8081         s++;
8082     if (*s != '}')
8083         return FALSE;
8084     return TRUE;
8085 }
8086
8087
8088 /*
8089  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
8090  */
8091 void
8092 Perl_regdump(pTHX_ const regexp *r)
8093 {
8094 #ifdef DEBUGGING
8095     dVAR;
8096     SV * const sv = sv_newmortal();
8097     SV *dsv= sv_newmortal();
8098     RXi_GET_DECL(r,ri);
8099
8100     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
8101
8102     /* Header fields of interest. */
8103     if (r->anchored_substr) {
8104         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr),
8105             RE_SV_DUMPLEN(r->anchored_substr), 30);
8106         PerlIO_printf(Perl_debug_log,
8107                       "anchored %s%s at %"IVdf" ",
8108                       s, RE_SV_TAIL(r->anchored_substr),
8109                       (IV)r->anchored_offset);
8110     } else if (r->anchored_utf8) {
8111         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8),
8112             RE_SV_DUMPLEN(r->anchored_utf8), 30);
8113         PerlIO_printf(Perl_debug_log,
8114                       "anchored utf8 %s%s at %"IVdf" ",
8115                       s, RE_SV_TAIL(r->anchored_utf8),
8116                       (IV)r->anchored_offset);
8117     }
8118     if (r->float_substr) {
8119         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr),
8120             RE_SV_DUMPLEN(r->float_substr), 30);
8121         PerlIO_printf(Perl_debug_log,
8122                       "floating %s%s at %"IVdf"..%"UVuf" ",
8123                       s, RE_SV_TAIL(r->float_substr),
8124                       (IV)r->float_min_offset, (UV)r->float_max_offset);
8125     } else if (r->float_utf8) {
8126         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8),
8127             RE_SV_DUMPLEN(r->float_utf8), 30);
8128         PerlIO_printf(Perl_debug_log,
8129                       "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
8130                       s, RE_SV_TAIL(r->float_utf8),
8131                       (IV)r->float_min_offset, (UV)r->float_max_offset);
8132     }
8133     if (r->check_substr || r->check_utf8)
8134         PerlIO_printf(Perl_debug_log,
8135                       (const char *)
8136                       (r->check_substr == r->float_substr
8137                        && r->check_utf8 == r->float_utf8
8138                        ? "(checking floating" : "(checking anchored"));
8139     if (r->extflags & RXf_NOSCAN)
8140         PerlIO_printf(Perl_debug_log, " noscan");
8141     if (r->extflags & RXf_CHECK_ALL)
8142         PerlIO_printf(Perl_debug_log, " isall");
8143     if (r->check_substr || r->check_utf8)
8144         PerlIO_printf(Perl_debug_log, ") ");
8145
8146     if (ri->regstclass) {
8147         regprop(r, sv, ri->regstclass);
8148         PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
8149     }
8150     if (r->extflags & RXf_ANCH) {
8151         PerlIO_printf(Perl_debug_log, "anchored");
8152         if (r->extflags & RXf_ANCH_BOL)
8153             PerlIO_printf(Perl_debug_log, "(BOL)");
8154         if (r->extflags & RXf_ANCH_MBOL)
8155             PerlIO_printf(Perl_debug_log, "(MBOL)");
8156         if (r->extflags & RXf_ANCH_SBOL)
8157             PerlIO_printf(Perl_debug_log, "(SBOL)");
8158         if (r->extflags & RXf_ANCH_GPOS)
8159             PerlIO_printf(Perl_debug_log, "(GPOS)");
8160         PerlIO_putc(Perl_debug_log, ' ');
8161     }
8162     if (r->extflags & RXf_GPOS_SEEN)
8163         PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", r->gofs);
8164     if (r->intflags & PREGf_SKIP)
8165         PerlIO_printf(Perl_debug_log, "plus ");
8166     if (r->intflags & PREGf_IMPLICIT)
8167         PerlIO_printf(Perl_debug_log, "implicit ");
8168     PerlIO_printf(Perl_debug_log, "minlen %ld ", (long) r->minlen);
8169     if (r->extflags & RXf_EVAL_SEEN)
8170         PerlIO_printf(Perl_debug_log, "with eval ");
8171     PerlIO_printf(Perl_debug_log, "\n");
8172 #else
8173     PERL_UNUSED_CONTEXT;
8174     PERL_UNUSED_ARG(r);
8175 #endif  /* DEBUGGING */
8176 }
8177
8178 /*
8179 - regprop - printable representation of opcode
8180 */
8181 void
8182 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
8183 {
8184 #ifdef DEBUGGING
8185     dVAR;
8186     register int k;
8187     RXi_GET_DECL(prog,progi);
8188     GET_RE_DEBUG_FLAGS_DECL;
8189
8190
8191     sv_setpvn(sv, "", 0);
8192
8193     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
8194         /* It would be nice to FAIL() here, but this may be called from
8195            regexec.c, and it would be hard to supply pRExC_state. */
8196         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX);
8197     sv_catpv(sv, reg_name[OP(o)]); /* Take off const! */
8198
8199     k = PL_regkind[OP(o)];
8200
8201     if (k == EXACT) {
8202         SV * const dsv = sv_2mortal(newSVpvs(""));
8203         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT)
8204          * is a crude hack but it may be the best for now since
8205          * we have no flag "this EXACTish node was UTF-8"
8206          * --jhi */
8207         const char * const s =
8208             pv_pretty(dsv, STRING(o), STR_LEN(o), 60,
8209                 PL_colors[0], PL_colors[1],
8210                 PERL_PV_ESCAPE_UNI_DETECT |
8211                 PERL_PV_PRETTY_ELIPSES    |
8212                 PERL_PV_PRETTY_LTGT
8213             );
8214         Perl_sv_catpvf(aTHX_ sv, " %s", s );
8215     } else if (k == TRIE) {
8216         /* print the details of the trie in dumpuntil instead, as
8217          * progi->data isn't available here */
8218         const char op = OP(o);
8219         const I32 n = ARG(o);
8220         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
8221                (reg_ac_data *)progi->data->data[n] :
8222                NULL;
8223         const reg_trie_data * const trie = !IS_TRIE_AC(op) ?
8224             (reg_trie_data*)progi->data->data[n] :
8225             ac->trie;
8226
8227         Perl_sv_catpvf(aTHX_ sv, "-%s",reg_name[o->flags]);
8228         DEBUG_TRIE_COMPILE_r(
8229             Perl_sv_catpvf(aTHX_ sv,
8230                 "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
8231                 (UV)trie->startstate,
8232                 (IV)trie->statecount-1, /* -1 because of the unused 0 element */
8233                 (UV)trie->wordcount,
8234                 (UV)trie->minlen,
8235                 (UV)trie->maxlen,
8236                 (UV)TRIE_CHARCOUNT(trie),
8237                 (UV)trie->uniquecharcount
8238             )
8239         );
8240         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
8241             int i;
8242             int rangestart = -1;
8243             U8* bitmap = IS_ANYOF_TRIE(op) ? (U8*)ANYOF_BITMAP(o) : (U8*)TRIE_BITMAP(trie);
8244             Perl_sv_catpvf(aTHX_ sv, "[");
8245             for (i = 0; i <= 256; i++) {
8246                 if (i < 256 && BITMAP_TEST(bitmap,i)) {
8247                     if (rangestart == -1)
8248                         rangestart = i;
8249                 } else if (rangestart != -1) {
8250                     if (i <= rangestart + 3)
8251                         for (; rangestart < i; rangestart++)
8252                             put_byte(sv, rangestart);
8253                     else {
8254                         put_byte(sv, rangestart);
8255                         sv_catpvs(sv, "-");
8256                         put_byte(sv, i - 1);
8257                     }
8258                     rangestart = -1;
8259                 }
8260             }
8261             Perl_sv_catpvf(aTHX_ sv, "]");
8262         }
8263
8264     } else if (k == CURLY) {
8265         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
8266             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
8267         Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
8268     }
8269     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
8270         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
8271     else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT)
8272         Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o));    /* Parenth number */
8273     else if (k == GOSUB)
8274         Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */
8275     else if (k == VERB) {
8276         if (!o->flags)
8277             Perl_sv_catpvf(aTHX_ sv, ":%"SVf,
8278                 (SV*)progi->data->data[ ARG( o ) ]);
8279     } else if (k == LOGICAL)
8280         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);     /* 2: embedded, otherwise 1 */
8281     else if (k == ANYOF) {
8282         int i, rangestart = -1;
8283         const U8 flags = ANYOF_FLAGS(o);
8284
8285         /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
8286         static const char * const anyofs[] = {
8287             "\\w",
8288             "\\W",
8289             "\\s",
8290             "\\S",
8291             "\\d",
8292             "\\D",
8293             "[:alnum:]",
8294             "[:^alnum:]",
8295             "[:alpha:]",
8296             "[:^alpha:]",
8297             "[:ascii:]",
8298             "[:^ascii:]",
8299             "[:ctrl:]",
8300             "[:^ctrl:]",
8301             "[:graph:]",
8302             "[:^graph:]",
8303             "[:lower:]",
8304             "[:^lower:]",
8305             "[:print:]",
8306             "[:^print:]",
8307             "[:punct:]",
8308             "[:^punct:]",
8309             "[:upper:]",
8310             "[:^upper:]",
8311             "[:xdigit:]",
8312             "[:^xdigit:]",
8313             "[:space:]",
8314             "[:^space:]",
8315             "[:blank:]",
8316             "[:^blank:]"
8317         };
8318
8319         if (flags & ANYOF_LOCALE)
8320             sv_catpvs(sv, "{loc}");
8321         if (flags & ANYOF_FOLD)
8322             sv_catpvs(sv, "{i}");
8323         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
8324         if (flags & ANYOF_INVERT)
8325             sv_catpvs(sv, "^");
8326         for (i = 0; i <= 256; i++) {
8327             if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
8328                 if (rangestart == -1)
8329                     rangestart = i;
8330             } else if (rangestart != -1) {
8331                 if (i <= rangestart + 3)
8332                     for (; rangestart < i; rangestart++)
8333                         put_byte(sv, rangestart);
8334                 else {
8335                     put_byte(sv, rangestart);
8336                     sv_catpvs(sv, "-");
8337                     put_byte(sv, i - 1);
8338                 }
8339                 rangestart = -1;
8340             }
8341         }
8342
8343         if (o->flags & ANYOF_CLASS)
8344             for (i = 0; i < (int)(sizeof(anyofs)/sizeof(char*)); i++)
8345                 if (ANYOF_CLASS_TEST(o,i))
8346                     sv_catpv(sv, anyofs[i]);
8347
8348         if (flags & ANYOF_UNICODE)
8349             sv_catpvs(sv, "{unicode}");
8350         else if (flags & ANYOF_UNICODE_ALL)
8351             sv_catpvs(sv, "{unicode_all}");
8352
8353         {
8354             SV *lv;
8355             SV * const sw = regclass_swash(prog, o, FALSE, &lv, 0);
8356
8357             if (lv) {
8358                 if (sw) {
8359                     U8 s[UTF8_MAXBYTES_CASE+1];
8360
8361                     for (i = 0; i <= 256; i++) { /* just the first 256 */
8362                         uvchr_to_utf8(s, i);
8363
8364                         if (i < 256 && swash_fetch(sw, s, TRUE)) {
8365                             if (rangestart == -1)
8366                                 rangestart = i;
8367                         } else if (rangestart != -1) {
8368                             if (i <= rangestart + 3)
8369                                 for (; rangestart < i; rangestart++) {
8370                                     const U8 * const e = uvchr_to_utf8(s,rangestart);
8371                                     U8 *p;
8372                                     for(p = s; p < e; p++)
8373                                         put_byte(sv, *p);
8374                                 }
8375                             else {
8376                                 const U8 *e = uvchr_to_utf8(s,rangestart);
8377                                 U8 *p;
8378                                 for (p = s; p < e; p++)
8379                                     put_byte(sv, *p);
8380                                 sv_catpvs(sv, "-");
8381                                 e = uvchr_to_utf8(s, i-1);
8382                                 for (p = s; p < e; p++)
8383                                     put_byte(sv, *p);
8384                                 }
8385                                 rangestart = -1;
8386                             }
8387                         }
8388
8389                     sv_catpvs(sv, "..."); /* et cetera */
8390                 }
8391
8392                 {
8393                     char *s = savesvpv(lv);
8394                     char * const origs = s;
8395
8396                     while (*s && *s != '\n')
8397                         s++;
8398
8399                     if (*s == '\n') {
8400                         const char * const t = ++s;
8401
8402                         while (*s) {
8403                             if (*s == '\n')
8404                                 *s = ' ';
8405                             s++;
8406                         }
8407                         if (s[-1] == ' ')
8408                             s[-1] = 0;
8409
8410                         sv_catpv(sv, t);
8411                     }
8412
8413                     Safefree(origs);
8414                 }
8415             }
8416         }
8417
8418         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
8419     }
8420     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
8421         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
8422 #else
8423     PERL_UNUSED_CONTEXT;
8424     PERL_UNUSED_ARG(sv);
8425     PERL_UNUSED_ARG(o);
8426     PERL_UNUSED_ARG(prog);
8427 #endif  /* DEBUGGING */
8428 }
8429
8430 SV *
8431 Perl_re_intuit_string(pTHX_ regexp *prog)
8432 {                               /* Assume that RE_INTUIT is set */
8433     dVAR;
8434     GET_RE_DEBUG_FLAGS_DECL;
8435     PERL_UNUSED_CONTEXT;
8436
8437     DEBUG_COMPILE_r(
8438         {
8439             const char * const s = SvPV_nolen_const(prog->check_substr
8440                       ? prog->check_substr : prog->check_utf8);
8441
8442             if (!PL_colorset) reginitcolors();
8443             PerlIO_printf(Perl_debug_log,
8444                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
8445                       PL_colors[4],
8446                       prog->check_substr ? "" : "utf8 ",
8447                       PL_colors[5],PL_colors[0],
8448                       s,
8449                       PL_colors[1],
8450                       (strlen(s) > 60 ? "..." : ""));
8451         } );
8452
8453     return prog->check_substr ? prog->check_substr : prog->check_utf8;
8454 }
8455
8456 /*
8457    pregfree - free a regexp
8458
8459    See regdupe below if you change anything here.
8460 */
8461
8462 void
8463 Perl_pregfree(pTHX_ struct regexp *r)
8464 {
8465     dVAR;
8466     RXi_GET_DECL(r,ri);
8467     GET_RE_DEBUG_FLAGS_DECL;
8468
8469     if (!r || (--r->refcnt > 0))
8470         return;
8471     DEBUG_COMPILE_r({
8472         if (!PL_colorset)
8473             reginitcolors();
8474         {
8475             SV *dsv= sv_newmortal();
8476             RE_PV_QUOTED_DECL(s, (r->extflags & RXf_UTF8),
8477                 dsv, r->precomp, r->prelen, 60);
8478             PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n",
8479                 PL_colors[4],PL_colors[5],s);
8480         }
8481     });
8482
8483     /* gcov results gave these as non-null 100% of the time, so there's no
8484        optimisation in checking them before calling Safefree  */
8485     Safefree(r->precomp);
8486     Safefree(ri->offsets);             /* 20010421 MJD */
8487     RX_MATCH_COPY_FREE(r);
8488 #ifdef PERL_OLD_COPY_ON_WRITE
8489     if (r->saved_copy)
8490         SvREFCNT_dec(r->saved_copy);
8491 #endif
8492     if (r->substrs) {
8493         if (r->anchored_substr)
8494             SvREFCNT_dec(r->anchored_substr);
8495         if (r->anchored_utf8)
8496             SvREFCNT_dec(r->anchored_utf8);
8497         if (r->float_substr)
8498             SvREFCNT_dec(r->float_substr);
8499         if (r->float_utf8)
8500             SvREFCNT_dec(r->float_utf8);
8501         Safefree(r->substrs);
8502     }
8503     if (r->paren_names)
8504             SvREFCNT_dec(r->paren_names);
8505     if (ri->data) {
8506         int n = ri->data->count;
8507         PAD* new_comppad = NULL;
8508         PAD* old_comppad;
8509         PADOFFSET refcnt;
8510
8511         while (--n >= 0) {
8512           /* If you add a ->what type here, update the comment in regcomp.h */
8513             switch (ri->data->what[n]) {
8514             case 's':
8515             case 'S':
8516                 SvREFCNT_dec((SV*)ri->data->data[n]);
8517                 break;
8518             case 'f':
8519                 Safefree(ri->data->data[n]);
8520                 break;
8521             case 'p':
8522                 new_comppad = (AV*)ri->data->data[n];
8523                 break;
8524             case 'o':
8525                 if (new_comppad == NULL)
8526                     Perl_croak(aTHX_ "panic: pregfree comppad");
8527                 PAD_SAVE_LOCAL(old_comppad,
8528                     /* Watch out for global destruction's random ordering. */
8529                     (SvTYPE(new_comppad) == SVt_PVAV) ? new_comppad : NULL
8530                 );
8531                 OP_REFCNT_LOCK;
8532                 refcnt = OpREFCNT_dec((OP_4tree*)ri->data->data[n]);
8533                 OP_REFCNT_UNLOCK;
8534                 if (!refcnt)
8535                     op_free((OP_4tree*)ri->data->data[n]);
8536
8537                 PAD_RESTORE_LOCAL(old_comppad);
8538                 SvREFCNT_dec((SV*)new_comppad);
8539                 new_comppad = NULL;
8540                 break;
8541             case 'n':
8542                 break;
8543             case 'T':
8544                 { /* Aho Corasick add-on structure for a trie node.
8545                      Used in stclass optimization only */
8546                     U32 refcount;
8547                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
8548                     OP_REFCNT_LOCK;
8549                     refcount = --aho->refcount;
8550                     OP_REFCNT_UNLOCK;
8551                     if ( !refcount ) {
8552                         Safefree(aho->states);
8553                         Safefree(aho->fail);
8554                         aho->trie=NULL; /* not necessary to free this as it is
8555                                            handled by the 't' case */
8556                         Safefree(ri->data->data[n]); /* do this last!!!! */
8557                         Safefree(ri->regstclass);
8558                     }
8559                 }
8560                 break;
8561             case 't':
8562                 {
8563                     /* trie structure. */
8564                     U32 refcount;
8565                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
8566                     OP_REFCNT_LOCK;
8567                     refcount = --trie->refcount;
8568                     OP_REFCNT_UNLOCK;
8569                     if ( !refcount ) {
8570                         Safefree(trie->charmap);
8571                         if (trie->widecharmap)
8572                             SvREFCNT_dec((SV*)trie->widecharmap);
8573                         Safefree(trie->states);
8574                         Safefree(trie->trans);
8575                         if (trie->bitmap)
8576                             Safefree(trie->bitmap);
8577                         if (trie->wordlen)
8578                             Safefree(trie->wordlen);
8579                         if (trie->jump)
8580                             Safefree(trie->jump);
8581                         if (trie->nextword)
8582                             Safefree(trie->nextword);
8583 #ifdef DEBUGGING
8584                         if (trie->words)
8585                             SvREFCNT_dec((SV*)trie->words);
8586                         if (trie->revcharmap)
8587                             SvREFCNT_dec((SV*)trie->revcharmap);
8588 #endif
8589                         Safefree(ri->data->data[n]); /* do this last!!!! */
8590                     }
8591                 }
8592                 break;
8593             default:
8594                 Perl_croak(aTHX_ "panic: regfree data code '%c'", ri->data->what[n]);
8595             }
8596         }
8597         Safefree(ri->data->what);
8598         Safefree(ri->data);
8599     }
8600     Safefree(r->startp);
8601     Safefree(r->endp);
8602     if (ri->swap) {
8603         Safefree(ri->swap->startp);
8604         Safefree(ri->swap->endp);
8605         Safefree(ri->swap);
8606     }
8607     Safefree(ri);
8608     Safefree(r);
8609 }
8610
8611 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
8612 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8613 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8614 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
8615
8616 /*
8617    regdupe - duplicate a regexp.
8618
8619    This routine is called by sv.c's re_dup and is expected to clone a
8620    given regexp structure. It is a no-op when not under USE_ITHREADS.
8621    (Originally this *was* re_dup() for change history see sv.c)
8622
8623    See pregfree() above if you change anything here.
8624 */
8625 #if defined(USE_ITHREADS)
8626 regexp *
8627 Perl_regdupe(pTHX_ const regexp *r, CLONE_PARAMS *param)
8628 {
8629     dVAR;
8630     regexp *ret;
8631     regexp_internal *reti;
8632     int i, len, npar;
8633     struct reg_substr_datum *s;
8634     RXi_GET_DECL(r,ri);
8635
8636     if (!r)
8637         return (REGEXP *)NULL;
8638
8639     if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
8640         return ret;
8641
8642     len = ri->offsets[0];
8643     npar = r->nparens+1;
8644
8645     Newxz(ret, 1, regexp);
8646     Newxc(reti, sizeof(regexp_internal) + (len+1)*sizeof(regnode), char, regexp_internal);
8647     RXi_SET(ret,reti);
8648     Copy(ri->program, reti->program, len+1, regnode);
8649
8650     Newx(ret->startp, npar, I32);
8651     Copy(r->startp, ret->startp, npar, I32);
8652     Newx(ret->endp, npar, I32);
8653     Copy(r->startp, ret->startp, npar, I32);
8654     if(ri->swap) {
8655         Newx(reti->swap, 1, regexp_paren_ofs);
8656         /* no need to copy these */
8657         Newx(reti->swap->startp, npar, I32);
8658         Newx(reti->swap->endp, npar, I32);
8659     } else {
8660         reti->swap = NULL;
8661     }
8662
8663     Newx(ret->substrs, 1, struct reg_substr_data);
8664     for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
8665         s->min_offset = r->substrs->data[i].min_offset;
8666         s->max_offset = r->substrs->data[i].max_offset;
8667         s->end_shift  = r->substrs->data[i].end_shift;
8668         s->substr     = sv_dup_inc(r->substrs->data[i].substr, param);
8669         s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
8670     }
8671
8672     reti->regstclass = NULL;
8673     if (ri->data) {
8674         struct reg_data *d;
8675         const int count = ri->data->count;
8676         int i;
8677
8678         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
8679                 char, struct reg_data);
8680         Newx(d->what, count, U8);
8681
8682         d->count = count;
8683         for (i = 0; i < count; i++) {
8684             d->what[i] = ri->data->what[i];
8685             switch (d->what[i]) {
8686                 /* legal options are one of: sSfpontT
8687                    see also regcomp.h and pregfree() */
8688             case 's':
8689             case 'S':
8690                 d->data[i] = sv_dup_inc((SV *)ri->data->data[i], param);
8691                 break;
8692             case 'p':
8693                 d->data[i] = av_dup_inc((AV *)ri->data->data[i], param);
8694                 break;
8695             case 'f':
8696                 /* This is cheating. */
8697                 Newx(d->data[i], 1, struct regnode_charclass_class);
8698                 StructCopy(ri->data->data[i], d->data[i],
8699                             struct regnode_charclass_class);
8700                 reti->regstclass = (regnode*)d->data[i];
8701                 break;
8702             case 'o':
8703                 /* Compiled op trees are readonly and in shared memory,
8704                    and can thus be shared without duplication. */
8705                 OP_REFCNT_LOCK;
8706                 d->data[i] = (void*)OpREFCNT_inc((OP*)ri->data->data[i]);
8707                 OP_REFCNT_UNLOCK;
8708                 break;
8709             case 'n':
8710                 d->data[i] = ri->data->data[i];
8711                 break;
8712             case 't':
8713                 d->data[i] = ri->data->data[i];
8714                 OP_REFCNT_LOCK;
8715                 ((reg_trie_data*)d->data[i])->refcount++;
8716                 OP_REFCNT_UNLOCK;
8717                 break;
8718             case 'T':
8719                 d->data[i] = ri->data->data[i];
8720                 OP_REFCNT_LOCK;
8721                 ((reg_ac_data*)d->data[i])->refcount++;
8722                 OP_REFCNT_UNLOCK;
8723                 /* Trie stclasses are readonly and can thus be shared
8724                  * without duplication. We free the stclass in pregfree
8725                  * when the corresponding reg_ac_data struct is freed.
8726                  */
8727                 reti->regstclass= ri->regstclass;
8728                 break;
8729             default:
8730                 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", ri->data->what[i]);
8731             }
8732         }
8733
8734         reti->data = d;
8735     }
8736     else
8737         reti->data = NULL;
8738
8739     Newx(reti->offsets, 2*len+1, U32);
8740     Copy(ri->offsets, reti->offsets, 2*len+1, U32);
8741
8742     ret->precomp        = SAVEPVN(r->precomp, r->prelen);
8743     ret->refcnt         = r->refcnt;
8744     ret->minlen         = r->minlen;
8745     ret->minlenret      = r->minlenret;
8746     ret->prelen         = r->prelen;
8747     ret->nparens        = r->nparens;
8748     ret->lastparen      = r->lastparen;
8749     ret->lastcloseparen = r->lastcloseparen;
8750     ret->intflags       = r->intflags;
8751     ret->extflags       = r->extflags;
8752
8753     ret->sublen         = r->sublen;
8754
8755     ret->engine         = r->engine;
8756
8757     ret->paren_names    = hv_dup_inc(r->paren_names, param);
8758
8759     if (RX_MATCH_COPIED(ret))
8760         ret->subbeg  = SAVEPVN(r->subbeg, r->sublen);
8761     else
8762         ret->subbeg = NULL;
8763 #ifdef PERL_OLD_COPY_ON_WRITE
8764     ret->saved_copy = NULL;
8765 #endif
8766
8767     ptr_table_store(PL_ptr_table, r, ret);
8768     return ret;
8769 }
8770 #endif
8771
8772 /*
8773    reg_stringify()
8774
8775    converts a regexp embedded in a MAGIC struct to its stringified form,
8776    caching the converted form in the struct and returns the cached
8777    string.
8778
8779    If lp is nonnull then it is used to return the length of the
8780    resulting string
8781
8782    If flags is nonnull and the returned string contains UTF8 then
8783    (flags & 1) will be true.
8784
8785    If haseval is nonnull then it is used to return whether the pattern
8786    contains evals.
8787
8788    Normally called via macro:
8789
8790         CALLREG_STRINGIFY(mg,0,0);
8791
8792    And internally with
8793
8794         CALLREG_AS_STR(mg,lp,flags,haseval)
8795
8796    See sv_2pv_flags() in sv.c for an example of internal usage.
8797
8798  */
8799
8800 char *
8801 Perl_reg_stringify(pTHX_ MAGIC *mg, STRLEN *lp, U32 *flags, I32 *haseval ) {
8802     dVAR;
8803     const regexp * const re = (regexp *)mg->mg_obj;
8804     RXi_GET_DECL(re,ri);
8805
8806     if (!mg->mg_ptr) {
8807         const char *fptr = "msix";
8808         char reflags[6];
8809         char ch;
8810         int left = 0;
8811         int right = 4;
8812         bool need_newline = 0;
8813         U16 reganch = (U16)((re->extflags & RXf_PMf_COMPILETIME) >> 12);
8814
8815         while((ch = *fptr++)) {
8816             if(reganch & 1) {
8817                 reflags[left++] = ch;
8818             }
8819             else {
8820                 reflags[right--] = ch;
8821             }
8822             reganch >>= 1;
8823         }
8824         if(left != 4) {
8825             reflags[left] = '-';
8826             left = 5;
8827         }
8828
8829         mg->mg_len = re->prelen + 4 + left;
8830         /*
8831          * If /x was used, we have to worry about a regex ending with a
8832          * comment later being embedded within another regex. If so, we don't
8833          * want this regex's "commentization" to leak out to the right part of
8834          * the enclosing regex, we must cap it with a newline.
8835          *
8836          * So, if /x was used, we scan backwards from the end of the regex. If
8837          * we find a '#' before we find a newline, we need to add a newline
8838          * ourself. If we find a '\n' first (or if we don't find '#' or '\n'),
8839          * we don't need to add anything.  -jfriedl
8840          */
8841         if (PMf_EXTENDED & re->extflags) {
8842             const char *endptr = re->precomp + re->prelen;
8843             while (endptr >= re->precomp) {
8844                 const char c = *(endptr--);
8845                 if (c == '\n')
8846                     break; /* don't need another */
8847                 if (c == '#') {
8848                     /* we end while in a comment, so we need a newline */
8849                     mg->mg_len++; /* save space for it */
8850                     need_newline = 1; /* note to add it */
8851                     break;
8852                 }
8853             }
8854         }
8855
8856         Newx(mg->mg_ptr, mg->mg_len + 1 + left, char);
8857         mg->mg_ptr[0] = '(';
8858         mg->mg_ptr[1] = '?';
8859         Copy(reflags, mg->mg_ptr+2, left, char);
8860         *(mg->mg_ptr+left+2) = ':';
8861         Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
8862         if (need_newline)
8863             mg->mg_ptr[mg->mg_len - 2] = '\n';
8864         mg->mg_ptr[mg->mg_len - 1] = ')';
8865         mg->mg_ptr[mg->mg_len] = 0;
8866     }
8867     if (haseval)
8868         *haseval = ri->program[0].next_off;
8869     if (flags)
8870         *flags = ((re->extflags & RXf_UTF8) ? 1 : 0);
8871
8872     if (lp)
8873         *lp = mg->mg_len;
8874     return mg->mg_ptr;
8875 }
8876
8877
8878 #ifndef PERL_IN_XSUB_RE
8879 /*
8880  - regnext - dig the "next" pointer out of a node
8881  */
8882 regnode *
8883 Perl_regnext(pTHX_ register regnode *p)
8884 {
8885     dVAR;
8886     register I32 offset;
8887
8888     if (!p)
8889         return(NULL);
8890
8891     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
8892     if (offset == 0)
8893         return(NULL);
8894
8895     return(p+offset);
8896 }
8897 #endif
8898
8899 STATIC void
8900 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
8901 {
8902     va_list args;
8903     STRLEN l1 = strlen(pat1);
8904     STRLEN l2 = strlen(pat2);
8905     char buf[512];
8906     SV *msv;
8907     const char *message;
8908
8909     if (l1 > 510)
8910         l1 = 510;
8911     if (l1 + l2 > 510)
8912         l2 = 510 - l1;
8913     Copy(pat1, buf, l1 , char);
8914     Copy(pat2, buf + l1, l2 , char);
8915     buf[l1 + l2] = '\n';
8916     buf[l1 + l2 + 1] = '\0';
8917 #ifdef I_STDARG
8918     /* ANSI variant takes additional second argument */
8919     va_start(args, pat2);
8920 #else
8921     va_start(args);
8922 #endif
8923     msv = vmess(buf, &args);
8924     va_end(args);
8925     message = SvPV_const(msv,l1);
8926     if (l1 > 512)
8927         l1 = 512;
8928     Copy(message, buf, l1 , char);
8929     buf[l1-1] = '\0';                   /* Overwrite \n */
8930     Perl_croak(aTHX_ "%s", buf);
8931 }
8932
8933 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
8934
8935 #ifndef PERL_IN_XSUB_RE
8936 void
8937 Perl_save_re_context(pTHX)
8938 {
8939     dVAR;
8940
8941     struct re_save_state *state;
8942
8943     SAVEVPTR(PL_curcop);
8944     SSGROW(SAVESTACK_ALLOC_FOR_RE_SAVE_STATE + 1);
8945
8946     state = (struct re_save_state *)(PL_savestack + PL_savestack_ix);
8947     PL_savestack_ix += SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
8948     SSPUSHINT(SAVEt_RE_STATE);
8949
8950     Copy(&PL_reg_state, state, 1, struct re_save_state);
8951
8952     PL_reg_start_tmp = 0;
8953     PL_reg_start_tmpl = 0;
8954     PL_reg_oldsaved = NULL;
8955     PL_reg_oldsavedlen = 0;
8956     PL_reg_maxiter = 0;
8957     PL_reg_leftiter = 0;
8958     PL_reg_poscache = NULL;
8959     PL_reg_poscache_size = 0;
8960 #ifdef PERL_OLD_COPY_ON_WRITE
8961     PL_nrs = NULL;
8962 #endif
8963
8964     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
8965     if (PL_curpm) {
8966         const REGEXP * const rx = PM_GETRE(PL_curpm);
8967         if (rx) {
8968             U32 i;
8969             for (i = 1; i <= rx->nparens; i++) {
8970                 char digits[TYPE_CHARS(long)];
8971                 const STRLEN len = my_snprintf(digits, sizeof(digits), "%lu", (long)i);
8972                 GV *const *const gvp
8973                     = (GV**)hv_fetch(PL_defstash, digits, len, 0);
8974
8975                 if (gvp) {
8976                     GV * const gv = *gvp;
8977                     if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
8978                         save_scalar(gv);
8979                 }
8980             }
8981         }
8982     }
8983 }
8984 #endif
8985
8986 static void
8987 clear_re(pTHX_ void *r)
8988 {
8989     dVAR;
8990     ReREFCNT_dec((regexp *)r);
8991 }
8992
8993 #ifdef DEBUGGING
8994
8995 STATIC void
8996 S_put_byte(pTHX_ SV *sv, int c)
8997 {
8998     if (isCNTRL(c) || c == 255 || !isPRINT(c))
8999         Perl_sv_catpvf(aTHX_ sv, "\\%o", c);
9000     else if (c == '-' || c == ']' || c == '\\' || c == '^')
9001         Perl_sv_catpvf(aTHX_ sv, "\\%c", c);
9002     else
9003         Perl_sv_catpvf(aTHX_ sv, "%c", c);
9004 }
9005
9006
9007 #define CLEAR_OPTSTART \
9008     if (optstart) STMT_START { \
9009             DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%d nodes)\n", node - optstart)); \
9010             optstart=NULL; \
9011     } STMT_END
9012
9013 #define DUMPUNTIL(b,e) CLEAR_OPTSTART; node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
9014
9015 STATIC const regnode *
9016 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
9017             const regnode *last, const regnode *plast,
9018             SV* sv, I32 indent, U32 depth)
9019 {
9020     dVAR;
9021     register U8 op = PSEUDO;    /* Arbitrary non-END op. */
9022     register const regnode *next;
9023     const regnode *optstart= NULL;
9024     RXi_GET_DECL(r,ri);
9025     GET_RE_DEBUG_FLAGS_DECL;
9026
9027 #ifdef DEBUG_DUMPUNTIL
9028     PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
9029         last ? last-start : 0,plast ? plast-start : 0);
9030 #endif
9031
9032     if (plast && plast < last)
9033         last= plast;
9034
9035     while (PL_regkind[op] != END && (!last || node < last)) {
9036         /* While that wasn't END last time... */
9037
9038         NODE_ALIGN(node);
9039         op = OP(node);
9040         if (op == CLOSE || op == WHILEM)
9041             indent--;
9042         next = regnext((regnode *)node);
9043
9044         /* Where, what. */
9045         if (OP(node) == OPTIMIZED) {
9046             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
9047                 optstart = node;
9048             else
9049                 goto after_print;
9050         } else
9051             CLEAR_OPTSTART;
9052
9053         regprop(r, sv, node);
9054         PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
9055                       (int)(2*indent + 1), "", SvPVX_const(sv));
9056
9057         if (OP(node) != OPTIMIZED) {
9058             if (next == NULL)           /* Next ptr. */
9059                 PerlIO_printf(Perl_debug_log, "(0)");
9060             else if (PL_regkind[(U8)op] == BRANCH && PL_regkind[OP(next)] != BRANCH )
9061                 PerlIO_printf(Perl_debug_log, "(FAIL)");
9062             else
9063                 PerlIO_printf(Perl_debug_log, "(%"IVdf")", (IV)(next - start));
9064
9065             /*if (PL_regkind[(U8)op]  != TRIE)*/
9066                 (void)PerlIO_putc(Perl_debug_log, '\n');
9067         }
9068
9069       after_print:
9070         if (PL_regkind[(U8)op] == BRANCHJ) {
9071             assert(next);
9072             {
9073                 register const regnode *nnode = (OP(next) == LONGJMP
9074                                              ? regnext((regnode *)next)
9075                                              : next);
9076                 if (last && nnode > last)
9077                     nnode = last;
9078                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
9079             }
9080         }
9081         else if (PL_regkind[(U8)op] == BRANCH) {
9082             assert(next);
9083             DUMPUNTIL(NEXTOPER(node), next);
9084         }
9085         else if ( PL_regkind[(U8)op]  == TRIE ) {
9086             const regnode *this_trie = node;
9087             const char op = OP(node);
9088             const I32 n = ARG(node);
9089             const reg_ac_data * const ac = op>=AHOCORASICK ?
9090                (reg_ac_data *)ri->data->data[n] :
9091                NULL;
9092             const reg_trie_data * const trie = op<AHOCORASICK ?
9093                 (reg_trie_data*)ri->data->data[n] :
9094                 ac->trie;
9095             const regnode *nextbranch= NULL;
9096             I32 word_idx;
9097             sv_setpvn(sv, "", 0);
9098             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
9099                 SV ** const elem_ptr = av_fetch(trie->words,word_idx,0);
9100
9101                 PerlIO_printf(Perl_debug_log, "%*s%s ",
9102                    (int)(2*(indent+3)), "",
9103                     elem_ptr ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60,
9104                             PL_colors[0], PL_colors[1],
9105                             (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) |
9106                             PERL_PV_PRETTY_ELIPSES    |
9107                             PERL_PV_PRETTY_LTGT
9108                             )
9109                             : "???"
9110                 );
9111                 if (trie->jump) {
9112                     U16 dist= trie->jump[word_idx+1];
9113                     PerlIO_printf(Perl_debug_log, "(%u)\n",
9114                         (dist ? this_trie + dist : next) - start);
9115                     if (dist) {
9116                         if (!nextbranch)
9117                             nextbranch= this_trie + trie->jump[0];
9118                         DUMPUNTIL(this_trie + dist, nextbranch);
9119                     }
9120                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
9121                         nextbranch= regnext((regnode *)nextbranch);
9122                 } else {
9123                     PerlIO_printf(Perl_debug_log, "\n");
9124                 }
9125             }
9126             if (last && next > last)
9127                 node= last;
9128             else
9129                 node= next;
9130         }
9131         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
9132             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
9133                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
9134         }
9135         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
9136             assert(next);
9137             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
9138         }
9139         else if ( op == PLUS || op == STAR) {
9140             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
9141         }
9142         else if (op == ANYOF) {
9143             /* arglen 1 + class block */
9144             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_LARGE)
9145                     ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
9146             node = NEXTOPER(node);
9147         }
9148         else if (PL_regkind[(U8)op] == EXACT) {
9149             /* Literal string, where present. */
9150             node += NODE_SZ_STR(node) - 1;
9151             node = NEXTOPER(node);
9152         }
9153         else {
9154             node = NEXTOPER(node);
9155             node += regarglen[(U8)op];
9156         }
9157         if (op == CURLYX || op == OPEN)
9158             indent++;
9159     }
9160     CLEAR_OPTSTART;
9161 #ifdef DEBUG_DUMPUNTIL
9162     PerlIO_printf(Perl_debug_log, "--- %d\n",indent);
9163 #endif
9164     return node;
9165 }
9166
9167 #endif  /* DEBUGGING */
9168
9169 /*
9170  * Local variables:
9171  * c-indentation-style: bsd
9172  * c-basic-offset: 4
9173  * indent-tabs-mode: t
9174  * End:
9175  *
9176  * ex: set ts=8 sts=4 sw=4 noet:
9177  */