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