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