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