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     if (r->prelen == 3 && strEQ("\\s+", r->precomp))
4586         r->extflags |= RXf_WHITE;
4587     else if (r->prelen == 1 && r->precomp[0] == '^')
4588         r->extflags |= RXf_START_ONLY;
4589
4590 #ifdef DEBUGGING
4591     if (RExC_paren_names) {
4592         ri->name_list_idx = add_data( pRExC_state, 1, "p" );
4593         ri->data->data[ri->name_list_idx] = (void*)SvREFCNT_inc(RExC_paren_name_list);
4594     } else
4595         ri->name_list_idx = 0;
4596 #endif
4597
4598     if (RExC_recurse_count) {
4599         for ( ; RExC_recurse_count ; RExC_recurse_count-- ) {
4600             const regnode *scan = RExC_recurse[RExC_recurse_count-1];
4601             ARG2L_SET( scan, RExC_open_parens[ARG(scan)-1] - scan );
4602         }
4603     }
4604     Newxz(r->startp, RExC_npar, I32);
4605     Newxz(r->endp, RExC_npar, I32);
4606     /* assume we don't need to swap parens around before we match */
4607
4608     DEBUG_DUMP_r({
4609         PerlIO_printf(Perl_debug_log,"Final program:\n");
4610         regdump(r);
4611     });
4612     DEBUG_OFFSETS_r(if (ri->offsets) {
4613         const U32 len = ri->offsets[0];
4614         U32 i;
4615         GET_RE_DEBUG_FLAGS_DECL;
4616         PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)ri->offsets[0]);
4617         for (i = 1; i <= len; i++) {
4618             if (ri->offsets[i*2-1] || ri->offsets[i*2])
4619                 PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
4620                 (UV)i, (UV)ri->offsets[i*2-1], (UV)ri->offsets[i*2]);
4621             }
4622         PerlIO_printf(Perl_debug_log, "\n");
4623     });
4624     return(r);
4625 }
4626
4627 #undef CORE_ONLY_BLOCK
4628 #undef RE_ENGINE_PTR
4629
4630 #ifndef PERL_IN_XSUB_RE
4631 SV*
4632 Perl_reg_named_buff_get(pTHX_ SV* namesv, const REGEXP * const from_re, U32 flags)
4633 {
4634     AV *retarray = NULL;
4635     SV *ret;
4636     if (flags & 1)
4637         retarray=newAV();
4638
4639     if (from_re || PL_curpm) {
4640         const REGEXP * const rx = from_re ? from_re : PM_GETRE(PL_curpm);
4641         if (rx && rx->paren_names) {
4642             HE *he_str = hv_fetch_ent( rx->paren_names, namesv, 0, 0 );
4643             if (he_str) {
4644                 IV i;
4645                 SV* sv_dat=HeVAL(he_str);
4646                 I32 *nums=(I32*)SvPVX(sv_dat);
4647                 for ( i=0; i<SvIVX(sv_dat); i++ ) {
4648                     if ((I32)(rx->lastparen) >= nums[i] &&
4649                         rx->endp[nums[i]] != -1)
4650                     {
4651                         ret = reg_numbered_buff_get(nums[i],rx,NULL,0);
4652                         if (!retarray)
4653                             return ret;
4654                     } else {
4655                         ret = newSVsv(&PL_sv_undef);
4656                     }
4657                     if (retarray) {
4658                         SvREFCNT_inc(ret);
4659                         av_push(retarray, ret);
4660                     }
4661                 }
4662                 if (retarray)
4663                     return (SV*)retarray;
4664             }
4665         }
4666     }
4667     return NULL;
4668 }
4669
4670 SV*
4671 Perl_reg_numbered_buff_get(pTHX_ I32 paren, const REGEXP * const rx, SV* usesv, U32 flags)
4672 {
4673     char *s = NULL;
4674     I32 i = 0;
4675     I32 s1, t1;
4676     SV *sv = usesv ? usesv : newSVpvs("");
4677     PERL_UNUSED_ARG(flags);
4678
4679     if (paren == -2 && (s = rx->subbeg) && rx->startp[0] != -1) {
4680         /* $` */
4681         i = rx->startp[0];
4682     }
4683     else
4684     if (paren == -1 && rx->subbeg && rx->endp[0] != -1) {
4685         /* $' */
4686         s = rx->subbeg + rx->endp[0];
4687         i = rx->sublen - rx->endp[0];
4688     }
4689     else
4690     if ( 0 <= paren && paren <= (I32)rx->nparens &&
4691         (s1 = rx->startp[paren]) != -1 &&
4692         (t1 = rx->endp[paren]) != -1)
4693     {
4694         /* $& $1 ... */
4695         i = t1 - s1;
4696         s = rx->subbeg + s1;
4697     }
4698
4699     if (s) {
4700         assert(rx->subbeg);
4701         assert(rx->sublen >= (s - rx->subbeg) + i );
4702
4703         if (i >= 0) {
4704             const int oldtainted = PL_tainted;
4705             TAINT_NOT;
4706             sv_setpvn(sv, s, i);
4707             PL_tainted = oldtainted;
4708             if ( (rx->extflags & RXf_CANY_SEEN)
4709                 ? (RX_MATCH_UTF8(rx)
4710                             && (!i || is_utf8_string((U8*)s, i)))
4711                 : (RX_MATCH_UTF8(rx)) )
4712             {
4713                 SvUTF8_on(sv);
4714             }
4715             else
4716                 SvUTF8_off(sv);
4717             if (PL_tainting) {
4718                 if (RX_MATCH_TAINTED(rx)) {
4719                     if (SvTYPE(sv) >= SVt_PVMG) {
4720                         MAGIC* const mg = SvMAGIC(sv);
4721                         MAGIC* mgt;
4722                         PL_tainted = 1;
4723                         SvMAGIC_set(sv, mg->mg_moremagic);
4724                         SvTAINT(sv);
4725                         if ((mgt = SvMAGIC(sv))) {
4726                             mg->mg_moremagic = mgt;
4727                             SvMAGIC_set(sv, mg);
4728                         }
4729                     } else {
4730                         PL_tainted = 1;
4731                         SvTAINT(sv);
4732                     }
4733                 } else
4734                     SvTAINTED_off(sv);
4735             }
4736         } else {
4737             sv_setsv(sv,&PL_sv_undef);
4738         }
4739     } else {
4740         sv_setsv(sv,&PL_sv_undef);
4741     }
4742     return sv;
4743 }
4744 #endif
4745
4746 /* Scans the name of a named buffer from the pattern.
4747  * If flags is REG_RSN_RETURN_NULL returns null.
4748  * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
4749  * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
4750  * to the parsed name as looked up in the RExC_paren_names hash.
4751  * If there is an error throws a vFAIL().. type exception.
4752  */
4753
4754 #define REG_RSN_RETURN_NULL    0
4755 #define REG_RSN_RETURN_NAME    1
4756 #define REG_RSN_RETURN_DATA    2
4757
4758 STATIC SV*
4759 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags) {
4760     char *name_start = RExC_parse;
4761
4762     if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
4763          /* skip IDFIRST by using do...while */
4764         if (UTF)
4765             do {
4766                 RExC_parse += UTF8SKIP(RExC_parse);
4767             } while (isALNUM_utf8((U8*)RExC_parse));
4768         else
4769             do {
4770                 RExC_parse++;
4771             } while (isALNUM(*RExC_parse));
4772     }
4773
4774     if ( flags ) {
4775         SV* sv_name = sv_2mortal(Perl_newSVpvn(aTHX_ name_start,
4776             (int)(RExC_parse - name_start)));
4777         if (UTF)
4778             SvUTF8_on(sv_name);
4779         if ( flags == REG_RSN_RETURN_NAME)
4780             return sv_name;
4781         else if (flags==REG_RSN_RETURN_DATA) {
4782             HE *he_str = NULL;
4783             SV *sv_dat = NULL;
4784             if ( ! sv_name )      /* should not happen*/
4785                 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
4786             if (RExC_paren_names)
4787                 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
4788             if ( he_str )
4789                 sv_dat = HeVAL(he_str);
4790             if ( ! sv_dat )
4791                 vFAIL("Reference to nonexistent named group");
4792             return sv_dat;
4793         }
4794         else {
4795             Perl_croak(aTHX_ "panic: bad flag in reg_scan_name");
4796         }
4797         /* NOT REACHED */
4798     }
4799     return NULL;
4800 }
4801
4802 #define DEBUG_PARSE_MSG(funcname)     DEBUG_PARSE_r({           \
4803     int rem=(int)(RExC_end - RExC_parse);                       \
4804     int cut;                                                    \
4805     int num;                                                    \
4806     int iscut=0;                                                \
4807     if (rem>10) {                                               \
4808         rem=10;                                                 \
4809         iscut=1;                                                \
4810     }                                                           \
4811     cut=10-rem;                                                 \
4812     if (RExC_lastparse!=RExC_parse)                             \
4813         PerlIO_printf(Perl_debug_log," >%.*s%-*s",              \
4814             rem, RExC_parse,                                    \
4815             cut + 4,                                            \
4816             iscut ? "..." : "<"                                 \
4817         );                                                      \
4818     else                                                        \
4819         PerlIO_printf(Perl_debug_log,"%16s","");                \
4820                                                                 \
4821     if (SIZE_ONLY)                                              \
4822        num=RExC_size;                                           \
4823     else                                                        \
4824        num=REG_NODE_NUM(RExC_emit);                             \
4825     if (RExC_lastnum!=num)                                      \
4826        PerlIO_printf(Perl_debug_log,"|%4d",num);                \
4827     else                                                        \
4828        PerlIO_printf(Perl_debug_log,"|%4s","");                 \
4829     PerlIO_printf(Perl_debug_log,"|%*s%-4s",                    \
4830         (int)((depth*2)), "",                                   \
4831         (funcname)                                              \
4832     );                                                          \
4833     RExC_lastnum=num;                                           \
4834     RExC_lastparse=RExC_parse;                                  \
4835 })
4836
4837
4838
4839 #define DEBUG_PARSE(funcname)     DEBUG_PARSE_r({           \
4840     DEBUG_PARSE_MSG((funcname));                            \
4841     PerlIO_printf(Perl_debug_log,"%4s","\n");               \
4842 })
4843 #define DEBUG_PARSE_FMT(funcname,fmt,args)     DEBUG_PARSE_r({           \
4844     DEBUG_PARSE_MSG((funcname));                            \
4845     PerlIO_printf(Perl_debug_log,fmt "\n",args);               \
4846 })
4847 /*
4848  - reg - regular expression, i.e. main body or parenthesized thing
4849  *
4850  * Caller must absorb opening parenthesis.
4851  *
4852  * Combining parenthesis handling with the base level of regular expression
4853  * is a trifle forced, but the need to tie the tails of the branches to what
4854  * follows makes it hard to avoid.
4855  */
4856 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
4857 #ifdef DEBUGGING
4858 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
4859 #else
4860 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
4861 #endif
4862
4863 /* this idea is borrowed from STR_WITH_LEN in handy.h */
4864 #define CHECK_WORD(s,v,l)  \
4865     (((sizeof(s)-1)==(l)) && (strnEQ(start_verb, (s ""), (sizeof(s)-1))))
4866
4867 STATIC regnode *
4868 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
4869     /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
4870 {
4871     dVAR;
4872     register regnode *ret;              /* Will be the head of the group. */
4873     register regnode *br;
4874     register regnode *lastbr;
4875     register regnode *ender = NULL;
4876     register I32 parno = 0;
4877     I32 flags;
4878     const I32 oregflags = RExC_flags;
4879     bool have_branch = 0;
4880     bool is_open = 0;
4881
4882     /* for (?g), (?gc), and (?o) warnings; warning
4883        about (?c) will warn about (?g) -- japhy    */
4884
4885 #define WASTED_O  0x01
4886 #define WASTED_G  0x02
4887 #define WASTED_C  0x04
4888 #define WASTED_GC (0x02|0x04)
4889     I32 wastedflags = 0x00;
4890
4891     char * parse_start = RExC_parse; /* MJD */
4892     char * const oregcomp_parse = RExC_parse;
4893
4894     GET_RE_DEBUG_FLAGS_DECL;
4895     DEBUG_PARSE("reg ");
4896
4897
4898     *flagp = 0;                         /* Tentatively. */
4899
4900
4901     /* Make an OPEN node, if parenthesized. */
4902     if (paren) {
4903         if ( *RExC_parse == '*') { /* (*VERB:ARG) */
4904             char *start_verb = RExC_parse;
4905             STRLEN verb_len = 0;
4906             char *start_arg = NULL;
4907             unsigned char op = 0;
4908             int argok = 1;
4909             int internal_argval = 0; /* internal_argval is only useful if !argok */
4910             while ( *RExC_parse && *RExC_parse != ')' ) {
4911                 if ( *RExC_parse == ':' ) {
4912                     start_arg = RExC_parse + 1;
4913                     break;
4914                 }
4915                 RExC_parse++;
4916             }
4917             ++start_verb;
4918             verb_len = RExC_parse - start_verb;
4919             if ( start_arg ) {
4920                 RExC_parse++;
4921                 while ( *RExC_parse && *RExC_parse != ')' )
4922                     RExC_parse++;
4923                 if ( *RExC_parse != ')' )
4924                     vFAIL("Unterminated verb pattern argument");
4925                 if ( RExC_parse == start_arg )
4926                     start_arg = NULL;
4927             } else {
4928                 if ( *RExC_parse != ')' )
4929                     vFAIL("Unterminated verb pattern");
4930             }
4931
4932             switch ( *start_verb ) {
4933             case 'A':  /* (*ACCEPT) */
4934                 if ( CHECK_WORD("ACCEPT",start_verb,verb_len) ) {
4935                     op = ACCEPT;
4936                     internal_argval = RExC_nestroot;
4937                 }
4938                 break;
4939             case 'C':  /* (*COMMIT) */
4940                 if ( CHECK_WORD("COMMIT",start_verb,verb_len) )
4941                     op = COMMIT;
4942                 break;
4943             case 'F':  /* (*FAIL) */
4944                 if ( verb_len==1 || CHECK_WORD("FAIL",start_verb,verb_len) ) {
4945                     op = OPFAIL;
4946                     argok = 0;
4947                 }
4948                 break;
4949             case ':':  /* (*:NAME) */
4950             case 'M':  /* (*MARK:NAME) */
4951                 if ( verb_len==0 || CHECK_WORD("MARK",start_verb,verb_len) ) {
4952                     op = MARKPOINT;
4953                     argok = -1;
4954                 }
4955                 break;
4956             case 'P':  /* (*PRUNE) */
4957                 if ( CHECK_WORD("PRUNE",start_verb,verb_len) )
4958                     op = PRUNE;
4959                 break;
4960             case 'S':   /* (*SKIP) */
4961                 if ( CHECK_WORD("SKIP",start_verb,verb_len) )
4962                     op = SKIP;
4963                 break;
4964             case 'T':  /* (*THEN) */
4965                 /* [19:06] <TimToady> :: is then */
4966                 if ( CHECK_WORD("THEN",start_verb,verb_len) ) {
4967                     op = CUTGROUP;
4968                     RExC_seen |= REG_SEEN_CUTGROUP;
4969                 }
4970                 break;
4971             }
4972             if ( ! op ) {
4973                 RExC_parse++;
4974                 vFAIL3("Unknown verb pattern '%.*s'",
4975                     verb_len, start_verb);
4976             }
4977             if ( argok ) {
4978                 if ( start_arg && internal_argval ) {
4979                     vFAIL3("Verb pattern '%.*s' may not have an argument",
4980                         verb_len, start_verb);
4981                 } else if ( argok < 0 && !start_arg ) {
4982                     vFAIL3("Verb pattern '%.*s' has a mandatory argument",
4983                         verb_len, start_verb);
4984                 } else {
4985                     ret = reganode(pRExC_state, op, internal_argval);
4986                     if ( ! internal_argval && ! SIZE_ONLY ) {
4987                         if (start_arg) {
4988                             SV *sv = newSVpvn( start_arg, RExC_parse - start_arg);
4989                             ARG(ret) = add_data( pRExC_state, 1, "S" );
4990                             RExC_rxi->data->data[ARG(ret)]=(void*)sv;
4991                             ret->flags = 0;
4992                         } else {
4993                             ret->flags = 1;
4994                         }
4995                     }
4996                 }
4997                 if (!internal_argval)
4998                     RExC_seen |= REG_SEEN_VERBARG;
4999             } else if ( start_arg ) {
5000                 vFAIL3("Verb pattern '%.*s' may not have an argument",
5001                         verb_len, start_verb);
5002             } else {
5003                 ret = reg_node(pRExC_state, op);
5004             }
5005             nextchar(pRExC_state);
5006             return ret;
5007         } else
5008         if (*RExC_parse == '?') { /* (?...) */
5009             U32 posflags = 0, negflags = 0;
5010             U32 *flagsp = &posflags;
5011             bool is_logical = 0;
5012             const char * const seqstart = RExC_parse;
5013
5014             RExC_parse++;
5015             paren = *RExC_parse++;
5016             ret = NULL;                 /* For look-ahead/behind. */
5017             switch (paren) {
5018
5019             case 'P':   /* (?P...) variants for those used to PCRE/Python */
5020                 paren = *RExC_parse++;
5021                 if ( paren == '<')         /* (?P<...>) named capture */
5022                     goto named_capture;
5023                 else if (paren == '>') {   /* (?P>name) named recursion */
5024                     goto named_recursion;
5025                 }
5026                 else if (paren == '=') {   /* (?P=...)  named backref */
5027                     /* this pretty much dupes the code for \k<NAME> in regatom(), if
5028                        you change this make sure you change that */
5029                     char* name_start = RExC_parse;
5030                     U32 num = 0;
5031                     SV *sv_dat = reg_scan_name(pRExC_state,
5032                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
5033                     if (RExC_parse == name_start || *RExC_parse != ')')
5034                         vFAIL2("Sequence %.3s... not terminated",parse_start);
5035
5036                     if (!SIZE_ONLY) {
5037                         num = add_data( pRExC_state, 1, "S" );
5038                         RExC_rxi->data->data[num]=(void*)sv_dat;
5039                         SvREFCNT_inc(sv_dat);
5040                     }
5041                     RExC_sawback = 1;
5042                     ret = reganode(pRExC_state,
5043                            (U8)(FOLD ? (LOC ? NREFFL : NREFF) : NREF),
5044                            num);
5045                     *flagp |= HASWIDTH;
5046
5047                     Set_Node_Offset(ret, parse_start+1);
5048                     Set_Node_Cur_Length(ret); /* MJD */
5049
5050                     nextchar(pRExC_state);
5051                     return ret;
5052                 }
5053                 goto unknown;
5054             case '<':           /* (?<...) */
5055                 if (*RExC_parse == '!')
5056                     paren = ',';
5057                 else if (*RExC_parse != '=')
5058               named_capture:
5059                 {               /* (?<...>) */
5060                     char *name_start;
5061                     SV *svname;
5062                     paren= '>';
5063             case '\'':          /* (?'...') */
5064                     name_start= RExC_parse;
5065                     svname = reg_scan_name(pRExC_state,
5066                         SIZE_ONLY ?  /* reverse test from the others */
5067                         REG_RSN_RETURN_NAME :
5068                         REG_RSN_RETURN_NULL);
5069                     if (RExC_parse == name_start)
5070                         goto unknown;
5071                     if (*RExC_parse != paren)
5072                         vFAIL2("Sequence (?%c... not terminated",
5073                             paren=='>' ? '<' : paren);
5074                     if (SIZE_ONLY) {
5075                         HE *he_str;
5076                         SV *sv_dat = NULL;
5077                         if (!svname) /* shouldnt happen */
5078                             Perl_croak(aTHX_
5079                                 "panic: reg_scan_name returned NULL");
5080                         if (!RExC_paren_names) {
5081                             RExC_paren_names= newHV();
5082                             sv_2mortal((SV*)RExC_paren_names);
5083 #ifdef DEBUGGING
5084                             RExC_paren_name_list= newAV();
5085                             sv_2mortal((SV*)RExC_paren_name_list);
5086 #endif
5087                         }
5088                         he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
5089                         if ( he_str )
5090                             sv_dat = HeVAL(he_str);
5091                         if ( ! sv_dat ) {
5092                             /* croak baby croak */
5093                             Perl_croak(aTHX_
5094                                 "panic: paren_name hash element allocation failed");
5095                         } else if ( SvPOK(sv_dat) ) {
5096                             IV count=SvIV(sv_dat);
5097                             I32 *pv=(I32*)SvGROW(sv_dat,SvCUR(sv_dat)+sizeof(I32)+1);
5098                             SvCUR_set(sv_dat,SvCUR(sv_dat)+sizeof(I32));
5099                             pv[count]=RExC_npar;
5100                             SvIVX(sv_dat)++;
5101                         } else {
5102                             (void)SvUPGRADE(sv_dat,SVt_PVNV);
5103                             sv_setpvn(sv_dat, (char *)&(RExC_npar), sizeof(I32));
5104                             SvIOK_on(sv_dat);
5105                             SvIVX(sv_dat)= 1;
5106                         }
5107 #ifdef DEBUGGING
5108                         if (!av_store(RExC_paren_name_list, RExC_npar, SvREFCNT_inc(svname)))
5109                             SvREFCNT_dec(svname);
5110 #endif
5111
5112                         /*sv_dump(sv_dat);*/
5113                     }
5114                     nextchar(pRExC_state);
5115                     paren = 1;
5116                     goto capturing_parens;
5117                 }
5118                 RExC_seen |= REG_SEEN_LOOKBEHIND;
5119                 RExC_parse++;
5120             case '=':           /* (?=...) */
5121             case '!':           /* (?!...) */
5122                 RExC_seen_zerolen++;
5123                 if (*RExC_parse == ')') {
5124                     ret=reg_node(pRExC_state, OPFAIL);
5125                     nextchar(pRExC_state);
5126                     return ret;
5127                 }
5128             case ':':           /* (?:...) */
5129             case '>':           /* (?>...) */
5130                 break;
5131             case '$':           /* (?$...) */
5132             case '@':           /* (?@...) */
5133                 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
5134                 break;
5135             case '#':           /* (?#...) */
5136                 while (*RExC_parse && *RExC_parse != ')')
5137                     RExC_parse++;
5138                 if (*RExC_parse != ')')
5139                     FAIL("Sequence (?#... not terminated");
5140                 nextchar(pRExC_state);
5141                 *flagp = TRYAGAIN;
5142                 return NULL;
5143             case '0' :           /* (?0) */
5144             case 'R' :           /* (?R) */
5145                 if (*RExC_parse != ')')
5146                     FAIL("Sequence (?R) not terminated");
5147                 ret = reg_node(pRExC_state, GOSTART);
5148                 nextchar(pRExC_state);
5149                 return ret;
5150                 /*notreached*/
5151             { /* named and numeric backreferences */
5152                 I32 num;
5153             case '&':            /* (?&NAME) */
5154                 parse_start = RExC_parse - 1;
5155               named_recursion:
5156                 {
5157                     SV *sv_dat = reg_scan_name(pRExC_state,
5158                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
5159                      num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
5160                 }
5161                 goto gen_recurse_regop;
5162                 /* NOT REACHED */
5163             case '+':
5164                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
5165                     RExC_parse++;
5166                     vFAIL("Illegal pattern");
5167                 }
5168                 goto parse_recursion;
5169                 /* NOT REACHED*/
5170             case '-': /* (?-1) */
5171                 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
5172                     RExC_parse--; /* rewind to let it be handled later */
5173                     goto parse_flags;
5174                 }
5175                 /*FALLTHROUGH */
5176             case '1': case '2': case '3': case '4': /* (?1) */
5177             case '5': case '6': case '7': case '8': case '9':
5178                 RExC_parse--;
5179               parse_recursion:
5180                 num = atoi(RExC_parse);
5181                 parse_start = RExC_parse - 1; /* MJD */
5182                 if (*RExC_parse == '-')
5183                     RExC_parse++;
5184                 while (isDIGIT(*RExC_parse))
5185                         RExC_parse++;
5186                 if (*RExC_parse!=')')
5187                     vFAIL("Expecting close bracket");
5188
5189               gen_recurse_regop:
5190                 if ( paren == '-' ) {
5191                     /*
5192                     Diagram of capture buffer numbering.
5193                     Top line is the normal capture buffer numbers
5194                     Botton line is the negative indexing as from
5195                     the X (the (?-2))
5196
5197                     +   1 2    3 4 5 X          6 7
5198                        /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
5199                     -   5 4    3 2 1 X          x x
5200
5201                     */
5202                     num = RExC_npar + num;
5203                     if (num < 1)  {
5204                         RExC_parse++;
5205                         vFAIL("Reference to nonexistent group");
5206                     }
5207                 } else if ( paren == '+' ) {
5208                     num = RExC_npar + num - 1;
5209                 }
5210
5211                 ret = reganode(pRExC_state, GOSUB, num);
5212                 if (!SIZE_ONLY) {
5213                     if (num > (I32)RExC_rx->nparens) {
5214                         RExC_parse++;
5215                         vFAIL("Reference to nonexistent group");
5216                     }
5217                     ARG2L_SET( ret, RExC_recurse_count++);
5218                     RExC_emit++;
5219                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
5220                         "Recurse #%"UVuf" to %"IVdf"\n", (UV)ARG(ret), (IV)ARG2L(ret)));
5221                 } else {
5222                     RExC_size++;
5223                 }
5224                 RExC_seen |= REG_SEEN_RECURSE;
5225                 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
5226                 Set_Node_Offset(ret, parse_start); /* MJD */
5227
5228                 nextchar(pRExC_state);
5229                 return ret;
5230             } /* named and numeric backreferences */
5231             /* NOT REACHED */
5232
5233             case 'p':           /* (?p...) */
5234                 if (SIZE_ONLY && ckWARN2(WARN_DEPRECATED, WARN_REGEXP))
5235                     vWARNdep(RExC_parse, "(?p{}) is deprecated - use (??{})");
5236                 /* FALL THROUGH*/
5237             case '?':           /* (??...) */
5238                 is_logical = 1;
5239                 if (*RExC_parse != '{')
5240                     goto unknown;
5241                 paren = *RExC_parse++;
5242                 /* FALL THROUGH */
5243             case '{':           /* (?{...}) */
5244             {
5245                 I32 count = 1;
5246                 U32 n = 0;
5247                 char c;
5248                 char *s = RExC_parse;
5249
5250                 RExC_seen_zerolen++;
5251                 RExC_seen |= REG_SEEN_EVAL;
5252                 while (count && (c = *RExC_parse)) {
5253                     if (c == '\\') {
5254                         if (RExC_parse[1])
5255                             RExC_parse++;
5256                     }
5257                     else if (c == '{')
5258                         count++;
5259                     else if (c == '}')
5260                         count--;
5261                     RExC_parse++;
5262                 }
5263                 if (*RExC_parse != ')') {
5264                     RExC_parse = s;
5265                     vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
5266                 }
5267                 if (!SIZE_ONLY) {
5268                     PAD *pad;
5269                     OP_4tree *sop, *rop;
5270                     SV * const sv = newSVpvn(s, RExC_parse - 1 - s);
5271
5272                     ENTER;
5273                     Perl_save_re_context(aTHX);
5274                     rop = sv_compile_2op(sv, &sop, "re", &pad);
5275                     sop->op_private |= OPpREFCOUNTED;
5276                     /* re_dup will OpREFCNT_inc */
5277                     OpREFCNT_set(sop, 1);
5278                     LEAVE;
5279
5280                     n = add_data(pRExC_state, 3, "nop");
5281                     RExC_rxi->data->data[n] = (void*)rop;
5282                     RExC_rxi->data->data[n+1] = (void*)sop;
5283                     RExC_rxi->data->data[n+2] = (void*)pad;
5284                     SvREFCNT_dec(sv);
5285                 }
5286                 else {                                          /* First pass */
5287                     if (PL_reginterp_cnt < ++RExC_seen_evals
5288                         && IN_PERL_RUNTIME)
5289                         /* No compiled RE interpolated, has runtime
5290                            components ===> unsafe.  */
5291                         FAIL("Eval-group not allowed at runtime, use re 'eval'");
5292                     if (PL_tainting && PL_tainted)
5293                         FAIL("Eval-group in insecure regular expression");
5294 #if PERL_VERSION > 8
5295                     if (IN_PERL_COMPILETIME)
5296                         PL_cv_has_eval = 1;
5297 #endif
5298                 }
5299
5300                 nextchar(pRExC_state);
5301                 if (is_logical) {
5302                     ret = reg_node(pRExC_state, LOGICAL);
5303                     if (!SIZE_ONLY)
5304                         ret->flags = 2;
5305                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, EVAL, n));
5306                     /* deal with the length of this later - MJD */
5307                     return ret;
5308                 }
5309                 ret = reganode(pRExC_state, EVAL, n);
5310                 Set_Node_Length(ret, RExC_parse - parse_start + 1);
5311                 Set_Node_Offset(ret, parse_start);
5312                 return ret;
5313             }
5314             case '(':           /* (?(?{...})...) and (?(?=...)...) */
5315             {
5316                 int is_define= 0;
5317                 if (RExC_parse[0] == '?') {        /* (?(?...)) */
5318                     if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
5319                         || RExC_parse[1] == '<'
5320                         || RExC_parse[1] == '{') { /* Lookahead or eval. */
5321                         I32 flag;
5322
5323                         ret = reg_node(pRExC_state, LOGICAL);
5324                         if (!SIZE_ONLY)
5325                             ret->flags = 1;
5326                         REGTAIL(pRExC_state, ret, reg(pRExC_state, 1, &flag,depth+1));
5327                         goto insert_if;
5328                     }
5329                 }
5330                 else if ( RExC_parse[0] == '<'     /* (?(<NAME>)...) */
5331                          || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
5332                 {
5333                     char ch = RExC_parse[0] == '<' ? '>' : '\'';
5334                     char *name_start= RExC_parse++;
5335                     U32 num = 0;
5336                     SV *sv_dat=reg_scan_name(pRExC_state,
5337                         SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
5338                     if (RExC_parse == name_start || *RExC_parse != ch)
5339                         vFAIL2("Sequence (?(%c... not terminated",
5340                             (ch == '>' ? '<' : ch));
5341                     RExC_parse++;
5342                     if (!SIZE_ONLY) {
5343                         num = add_data( pRExC_state, 1, "S" );
5344                         RExC_rxi->data->data[num]=(void*)sv_dat;
5345                         SvREFCNT_inc(sv_dat);
5346                     }
5347                     ret = reganode(pRExC_state,NGROUPP,num);
5348                     goto insert_if_check_paren;
5349                 }
5350                 else if (RExC_parse[0] == 'D' &&
5351                          RExC_parse[1] == 'E' &&
5352                          RExC_parse[2] == 'F' &&
5353                          RExC_parse[3] == 'I' &&
5354                          RExC_parse[4] == 'N' &&
5355                          RExC_parse[5] == 'E')
5356                 {
5357                     ret = reganode(pRExC_state,DEFINEP,0);
5358                     RExC_parse +=6 ;
5359                     is_define = 1;
5360                     goto insert_if_check_paren;
5361                 }
5362                 else if (RExC_parse[0] == 'R') {
5363                     RExC_parse++;
5364                     parno = 0;
5365                     if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
5366                         parno = atoi(RExC_parse++);
5367                         while (isDIGIT(*RExC_parse))
5368                             RExC_parse++;
5369                     } else if (RExC_parse[0] == '&') {
5370                         SV *sv_dat;
5371                         RExC_parse++;
5372                         sv_dat = reg_scan_name(pRExC_state,
5373                             SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
5374                         parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
5375                     }
5376                     ret = reganode(pRExC_state,INSUBP,parno);
5377                     goto insert_if_check_paren;
5378                 }
5379                 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
5380                     /* (?(1)...) */
5381                     char c;
5382                     parno = atoi(RExC_parse++);
5383
5384                     while (isDIGIT(*RExC_parse))
5385                         RExC_parse++;
5386                     ret = reganode(pRExC_state, GROUPP, parno);
5387
5388                  insert_if_check_paren:
5389                     if ((c = *nextchar(pRExC_state)) != ')')
5390                         vFAIL("Switch condition not recognized");
5391                   insert_if:
5392                     REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
5393                     br = regbranch(pRExC_state, &flags, 1,depth+1);
5394                     if (br == NULL)
5395                         br = reganode(pRExC_state, LONGJMP, 0);
5396                     else
5397                         REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
5398                     c = *nextchar(pRExC_state);
5399                     if (flags&HASWIDTH)
5400                         *flagp |= HASWIDTH;
5401                     if (c == '|') {
5402                         if (is_define)
5403                             vFAIL("(?(DEFINE)....) does not allow branches");
5404                         lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
5405                         regbranch(pRExC_state, &flags, 1,depth+1);
5406                         REGTAIL(pRExC_state, ret, lastbr);
5407                         if (flags&HASWIDTH)
5408                             *flagp |= HASWIDTH;
5409                         c = *nextchar(pRExC_state);
5410                     }
5411                     else
5412                         lastbr = NULL;
5413                     if (c != ')')
5414                         vFAIL("Switch (?(condition)... contains too many branches");
5415                     ender = reg_node(pRExC_state, TAIL);
5416                     REGTAIL(pRExC_state, br, ender);
5417                     if (lastbr) {
5418                         REGTAIL(pRExC_state, lastbr, ender);
5419                         REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
5420                     }
5421                     else
5422                         REGTAIL(pRExC_state, ret, ender);
5423                     return ret;
5424                 }
5425                 else {
5426                     vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
5427                 }
5428             }
5429             case 0:
5430                 RExC_parse--; /* for vFAIL to print correctly */
5431                 vFAIL("Sequence (? incomplete");
5432                 break;
5433             default:
5434                 --RExC_parse;
5435               parse_flags:      /* (?i) */
5436                 while (*RExC_parse && strchr("iogcmsx", *RExC_parse)) {
5437                     /* (?g), (?gc) and (?o) are useless here
5438                        and must be globally applied -- japhy */
5439
5440                     if (*RExC_parse == 'o' || *RExC_parse == 'g') {
5441                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
5442                             const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
5443                             if (! (wastedflags & wflagbit) ) {
5444                                 wastedflags |= wflagbit;
5445                                 vWARN5(
5446                                     RExC_parse + 1,
5447                                     "Useless (%s%c) - %suse /%c modifier",
5448                                     flagsp == &negflags ? "?-" : "?",
5449                                     *RExC_parse,
5450                                     flagsp == &negflags ? "don't " : "",
5451                                     *RExC_parse
5452                                 );
5453                             }
5454                         }
5455                     }
5456                     else if (*RExC_parse == 'c') {
5457                         if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
5458                             if (! (wastedflags & WASTED_C) ) {
5459                                 wastedflags |= WASTED_GC;
5460                                 vWARN3(
5461                                     RExC_parse + 1,
5462                                     "Useless (%sc) - %suse /gc modifier",
5463                                     flagsp == &negflags ? "?-" : "?",
5464                                     flagsp == &negflags ? "don't " : ""
5465                                 );
5466                             }
5467                         }
5468                     }
5469                     else { pmflag(flagsp, *RExC_parse); }
5470
5471                     ++RExC_parse;
5472                 }
5473                 if (*RExC_parse == '-') {
5474                     flagsp = &negflags;
5475                     wastedflags = 0;  /* reset so (?g-c) warns twice */
5476                     ++RExC_parse;
5477                     goto parse_flags;
5478                 }
5479                 RExC_flags |= posflags;
5480                 RExC_flags &= ~negflags;
5481                 if (*RExC_parse == ':') {
5482                     RExC_parse++;
5483                     paren = ':';
5484                     break;
5485                 }
5486               unknown:
5487                 if (*RExC_parse != ')') {
5488                     RExC_parse++;
5489                     vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
5490                 }
5491                 nextchar(pRExC_state);
5492                 *flagp = TRYAGAIN;
5493                 return NULL;
5494             }
5495         }
5496         else {                  /* (...) */
5497           capturing_parens:
5498             parno = RExC_npar;
5499             RExC_npar++;
5500
5501             ret = reganode(pRExC_state, OPEN, parno);
5502             if (!SIZE_ONLY ){
5503                 if (!RExC_nestroot)
5504                     RExC_nestroot = parno;
5505                 if (RExC_seen & REG_SEEN_RECURSE) {
5506                     DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
5507                         "Setting open paren #%"IVdf" to %d\n",
5508                         (IV)parno, REG_NODE_NUM(ret)));
5509                     RExC_open_parens[parno-1]= ret;
5510                 }
5511             }
5512             Set_Node_Length(ret, 1); /* MJD */
5513             Set_Node_Offset(ret, RExC_parse); /* MJD */
5514             is_open = 1;
5515         }
5516     }
5517     else                        /* ! paren */
5518         ret = NULL;
5519
5520     /* Pick up the branches, linking them together. */
5521     parse_start = RExC_parse;   /* MJD */
5522     br = regbranch(pRExC_state, &flags, 1,depth+1);
5523     /*     branch_len = (paren != 0); */
5524
5525     if (br == NULL)
5526         return(NULL);
5527     if (*RExC_parse == '|') {
5528         if (!SIZE_ONLY && RExC_extralen) {
5529             reginsert(pRExC_state, BRANCHJ, br, depth+1);
5530         }
5531         else {                  /* MJD */
5532             reginsert(pRExC_state, BRANCH, br, depth+1);
5533             Set_Node_Length(br, paren != 0);
5534             Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
5535         }
5536         have_branch = 1;
5537         if (SIZE_ONLY)
5538             RExC_extralen += 1;         /* For BRANCHJ-BRANCH. */
5539     }
5540     else if (paren == ':') {
5541         *flagp |= flags&SIMPLE;
5542     }
5543     if (is_open) {                              /* Starts with OPEN. */
5544         REGTAIL(pRExC_state, ret, br);          /* OPEN -> first. */
5545     }
5546     else if (paren != '?')              /* Not Conditional */
5547         ret = br;
5548     *flagp |= flags & (SPSTART | HASWIDTH);
5549     lastbr = br;
5550     while (*RExC_parse == '|') {
5551         if (!SIZE_ONLY && RExC_extralen) {
5552             ender = reganode(pRExC_state, LONGJMP,0);
5553             REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
5554         }
5555         if (SIZE_ONLY)
5556             RExC_extralen += 2;         /* Account for LONGJMP. */
5557         nextchar(pRExC_state);
5558         br = regbranch(pRExC_state, &flags, 0, depth+1);
5559
5560         if (br == NULL)
5561             return(NULL);
5562         REGTAIL(pRExC_state, lastbr, br);               /* BRANCH -> BRANCH. */
5563         lastbr = br;
5564         if (flags&HASWIDTH)
5565             *flagp |= HASWIDTH;
5566         *flagp |= flags&SPSTART;
5567     }
5568
5569     if (have_branch || paren != ':') {
5570         /* Make a closing node, and hook it on the end. */
5571         switch (paren) {
5572         case ':':
5573             ender = reg_node(pRExC_state, TAIL);
5574             break;
5575         case 1:
5576             ender = reganode(pRExC_state, CLOSE, parno);
5577             if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) {
5578                 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
5579                         "Setting close paren #%"IVdf" to %d\n",
5580                         (IV)parno, REG_NODE_NUM(ender)));
5581                 RExC_close_parens[parno-1]= ender;
5582                 if (RExC_nestroot == parno)
5583                     RExC_nestroot = 0;
5584             }
5585             Set_Node_Offset(ender,RExC_parse+1); /* MJD */
5586             Set_Node_Length(ender,1); /* MJD */
5587             break;
5588         case '<':
5589         case ',':
5590         case '=':
5591         case '!':
5592             *flagp &= ~HASWIDTH;
5593             /* FALL THROUGH */
5594         case '>':
5595             ender = reg_node(pRExC_state, SUCCEED);
5596             break;
5597         case 0:
5598             ender = reg_node(pRExC_state, END);
5599             if (!SIZE_ONLY) {
5600                 assert(!RExC_opend); /* there can only be one! */
5601                 RExC_opend = ender;
5602             }
5603             break;
5604         }
5605         REGTAIL(pRExC_state, lastbr, ender);
5606
5607         if (have_branch && !SIZE_ONLY) {
5608             if (depth==1)
5609                 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
5610
5611             /* Hook the tails of the branches to the closing node. */
5612             for (br = ret; br; br = regnext(br)) {
5613                 const U8 op = PL_regkind[OP(br)];
5614                 if (op == BRANCH) {
5615                     REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
5616                 }
5617                 else if (op == BRANCHJ) {
5618                     REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
5619                 }
5620             }
5621         }
5622     }
5623
5624     {
5625         const char *p;
5626         static const char parens[] = "=!<,>";
5627
5628         if (paren && (p = strchr(parens, paren))) {
5629             U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
5630             int flag = (p - parens) > 1;
5631
5632             if (paren == '>')
5633                 node = SUSPEND, flag = 0;
5634             reginsert(pRExC_state, node,ret, depth+1);
5635             Set_Node_Cur_Length(ret);
5636             Set_Node_Offset(ret, parse_start + 1);
5637             ret->flags = flag;
5638             REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
5639         }
5640     }
5641
5642     /* Check for proper termination. */
5643     if (paren) {
5644         RExC_flags = oregflags;
5645         if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
5646             RExC_parse = oregcomp_parse;
5647             vFAIL("Unmatched (");
5648         }
5649     }
5650     else if (!paren && RExC_parse < RExC_end) {
5651         if (*RExC_parse == ')') {
5652             RExC_parse++;
5653             vFAIL("Unmatched )");
5654         }
5655         else
5656             FAIL("Junk on end of regexp");      /* "Can't happen". */
5657         /* NOTREACHED */
5658     }
5659
5660     return(ret);
5661 }
5662
5663 /*
5664  - regbranch - one alternative of an | operator
5665  *
5666  * Implements the concatenation operator.
5667  */
5668 STATIC regnode *
5669 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
5670 {
5671     dVAR;
5672     register regnode *ret;
5673     register regnode *chain = NULL;
5674     register regnode *latest;
5675     I32 flags = 0, c = 0;
5676     GET_RE_DEBUG_FLAGS_DECL;
5677     DEBUG_PARSE("brnc");
5678     if (first)
5679         ret = NULL;
5680     else {
5681         if (!SIZE_ONLY && RExC_extralen)
5682             ret = reganode(pRExC_state, BRANCHJ,0);
5683         else {
5684             ret = reg_node(pRExC_state, BRANCH);
5685             Set_Node_Length(ret, 1);
5686         }
5687     }
5688
5689     if (!first && SIZE_ONLY)
5690         RExC_extralen += 1;                     /* BRANCHJ */
5691
5692     *flagp = WORST;                     /* Tentatively. */
5693
5694     RExC_parse--;
5695     nextchar(pRExC_state);
5696     while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
5697         flags &= ~TRYAGAIN;
5698         latest = regpiece(pRExC_state, &flags,depth+1);
5699         if (latest == NULL) {
5700             if (flags & TRYAGAIN)
5701                 continue;
5702             return(NULL);
5703         }
5704         else if (ret == NULL)
5705             ret = latest;
5706         *flagp |= flags&HASWIDTH;
5707         if (chain == NULL)      /* First piece. */
5708             *flagp |= flags&SPSTART;
5709         else {
5710             RExC_naughty++;
5711             REGTAIL(pRExC_state, chain, latest);
5712         }
5713         chain = latest;
5714         c++;
5715     }
5716     if (chain == NULL) {        /* Loop ran zero times. */
5717         chain = reg_node(pRExC_state, NOTHING);
5718         if (ret == NULL)
5719             ret = chain;
5720     }
5721     if (c == 1) {
5722         *flagp |= flags&SIMPLE;
5723     }
5724
5725     return ret;
5726 }
5727
5728 /*
5729  - regpiece - something followed by possible [*+?]
5730  *
5731  * Note that the branching code sequences used for ? and the general cases
5732  * of * and + are somewhat optimized:  they use the same NOTHING node as
5733  * both the endmarker for their branch list and the body of the last branch.
5734  * It might seem that this node could be dispensed with entirely, but the
5735  * endmarker role is not redundant.
5736  */
5737 STATIC regnode *
5738 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
5739 {
5740     dVAR;
5741     register regnode *ret;
5742     register char op;
5743     register char *next;
5744     I32 flags;
5745     const char * const origparse = RExC_parse;
5746     I32 min;
5747     I32 max = REG_INFTY;
5748     char *parse_start;
5749     const char *maxpos = NULL;
5750     GET_RE_DEBUG_FLAGS_DECL;
5751     DEBUG_PARSE("piec");
5752
5753     ret = regatom(pRExC_state, &flags,depth+1);
5754     if (ret == NULL) {
5755         if (flags & TRYAGAIN)
5756             *flagp |= TRYAGAIN;
5757         return(NULL);
5758     }
5759
5760     op = *RExC_parse;
5761
5762     if (op == '{' && regcurly(RExC_parse)) {
5763         maxpos = NULL;
5764         parse_start = RExC_parse; /* MJD */
5765         next = RExC_parse + 1;
5766         while (isDIGIT(*next) || *next == ',') {
5767             if (*next == ',') {
5768                 if (maxpos)
5769                     break;
5770                 else
5771                     maxpos = next;
5772             }
5773             next++;
5774         }
5775         if (*next == '}') {             /* got one */
5776             if (!maxpos)
5777                 maxpos = next;
5778             RExC_parse++;
5779             min = atoi(RExC_parse);
5780             if (*maxpos == ',')
5781                 maxpos++;
5782             else
5783                 maxpos = RExC_parse;
5784             max = atoi(maxpos);
5785             if (!max && *maxpos != '0')
5786                 max = REG_INFTY;                /* meaning "infinity" */
5787             else if (max >= REG_INFTY)
5788                 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
5789             RExC_parse = next;
5790             nextchar(pRExC_state);
5791
5792         do_curly:
5793             if ((flags&SIMPLE)) {
5794                 RExC_naughty += 2 + RExC_naughty / 2;
5795                 reginsert(pRExC_state, CURLY, ret, depth+1);
5796                 Set_Node_Offset(ret, parse_start+1); /* MJD */
5797                 Set_Node_Cur_Length(ret);
5798             }
5799             else {
5800                 regnode * const w = reg_node(pRExC_state, WHILEM);
5801
5802                 w->flags = 0;
5803                 REGTAIL(pRExC_state, ret, w);
5804                 if (!SIZE_ONLY && RExC_extralen) {
5805                     reginsert(pRExC_state, LONGJMP,ret, depth+1);
5806                     reginsert(pRExC_state, NOTHING,ret, depth+1);
5807                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
5808                 }
5809                 reginsert(pRExC_state, CURLYX,ret, depth+1);
5810                                 /* MJD hk */
5811                 Set_Node_Offset(ret, parse_start+1);
5812                 Set_Node_Length(ret,
5813                                 op == '{' ? (RExC_parse - parse_start) : 1);
5814
5815                 if (!SIZE_ONLY && RExC_extralen)
5816                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
5817                 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
5818                 if (SIZE_ONLY)
5819                     RExC_whilem_seen++, RExC_extralen += 3;
5820                 RExC_naughty += 4 + RExC_naughty;       /* compound interest */
5821             }
5822             ret->flags = 0;
5823
5824             if (min > 0)
5825                 *flagp = WORST;
5826             if (max > 0)
5827                 *flagp |= HASWIDTH;
5828             if (max && max < min)
5829                 vFAIL("Can't do {n,m} with n > m");
5830             if (!SIZE_ONLY) {
5831                 ARG1_SET(ret, (U16)min);
5832                 ARG2_SET(ret, (U16)max);
5833             }
5834
5835             goto nest_check;
5836         }
5837     }
5838
5839     if (!ISMULT1(op)) {
5840         *flagp = flags;
5841         return(ret);
5842     }
5843
5844 #if 0                           /* Now runtime fix should be reliable. */
5845
5846     /* if this is reinstated, don't forget to put this back into perldiag:
5847
5848             =item Regexp *+ operand could be empty at {#} in regex m/%s/
5849
5850            (F) The part of the regexp subject to either the * or + quantifier
5851            could match an empty string. The {#} shows in the regular
5852            expression about where the problem was discovered.
5853
5854     */
5855
5856     if (!(flags&HASWIDTH) && op != '?')
5857       vFAIL("Regexp *+ operand could be empty");
5858 #endif
5859
5860     parse_start = RExC_parse;
5861     nextchar(pRExC_state);
5862
5863     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
5864
5865     if (op == '*' && (flags&SIMPLE)) {
5866         reginsert(pRExC_state, STAR, ret, depth+1);
5867         ret->flags = 0;
5868         RExC_naughty += 4;
5869     }
5870     else if (op == '*') {
5871         min = 0;
5872         goto do_curly;
5873     }
5874     else if (op == '+' && (flags&SIMPLE)) {
5875         reginsert(pRExC_state, PLUS, ret, depth+1);
5876         ret->flags = 0;
5877         RExC_naughty += 3;
5878     }
5879     else if (op == '+') {
5880         min = 1;
5881         goto do_curly;
5882     }
5883     else if (op == '?') {
5884         min = 0; max = 1;
5885         goto do_curly;
5886     }
5887   nest_check:
5888     if (!SIZE_ONLY && !(flags&HASWIDTH) && max > REG_INFTY/3 && ckWARN(WARN_REGEXP)) {
5889         vWARN3(RExC_parse,
5890                "%.*s matches null string many times",
5891                (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0),
5892                origparse);
5893     }
5894
5895     if (RExC_parse < RExC_end && *RExC_parse == '?') {
5896         nextchar(pRExC_state);
5897         reginsert(pRExC_state, MINMOD, ret, depth+1);
5898         REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
5899     }
5900 #ifndef REG_ALLOW_MINMOD_SUSPEND
5901     else
5902 #endif
5903     if (RExC_parse < RExC_end && *RExC_parse == '+') {
5904         regnode *ender;
5905         nextchar(pRExC_state);
5906         ender = reg_node(pRExC_state, SUCCEED);
5907         REGTAIL(pRExC_state, ret, ender);
5908         reginsert(pRExC_state, SUSPEND, ret, depth+1);
5909         ret->flags = 0;
5910         ender = reg_node(pRExC_state, TAIL);
5911         REGTAIL(pRExC_state, ret, ender);
5912         /*ret= ender;*/
5913     }
5914
5915     if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) {
5916         RExC_parse++;
5917         vFAIL("Nested quantifiers");
5918     }
5919
5920     return(ret);
5921 }
5922
5923
5924 /* reg_namedseq(pRExC_state,UVp)
5925
5926    This is expected to be called by a parser routine that has
5927    recognized'\N' and needs to handle the rest. RExC_parse is
5928    expected to point at the first char following the N at the time
5929    of the call.
5930
5931    If valuep is non-null then it is assumed that we are parsing inside
5932    of a charclass definition and the first codepoint in the resolved
5933    string is returned via *valuep and the routine will return NULL.
5934    In this mode if a multichar string is returned from the charnames
5935    handler a warning will be issued, and only the first char in the
5936    sequence will be examined. If the string returned is zero length
5937    then the value of *valuep is undefined and NON-NULL will
5938    be returned to indicate failure. (This will NOT be a valid pointer
5939    to a regnode.)
5940
5941    If value is null then it is assumed that we are parsing normal text
5942    and inserts a new EXACT node into the program containing the resolved
5943    string and returns a pointer to the new node. If the string is
5944    zerolength a NOTHING node is emitted.
5945
5946    On success RExC_parse is set to the char following the endbrace.
5947    Parsing failures will generate a fatal errorvia vFAIL(...)
5948
5949    NOTE: We cache all results from the charnames handler locally in
5950    the RExC_charnames hash (created on first use) to prevent a charnames
5951    handler from playing silly-buggers and returning a short string and
5952    then a long string for a given pattern. Since the regexp program
5953    size is calculated during an initial parse this would result
5954    in a buffer overrun so we cache to prevent the charname result from
5955    changing during the course of the parse.
5956
5957  */
5958 STATIC regnode *
5959 S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep)
5960 {
5961     char * name;        /* start of the content of the name */
5962     char * endbrace;    /* endbrace following the name */
5963     SV *sv_str = NULL;
5964     SV *sv_name = NULL;
5965     STRLEN len; /* this has various purposes throughout the code */
5966     bool cached = 0; /* if this is true then we shouldn't refcount dev sv_str */
5967     regnode *ret = NULL;
5968
5969     if (*RExC_parse != '{') {
5970         vFAIL("Missing braces on \\N{}");
5971     }
5972     name = RExC_parse+1;
5973     endbrace = strchr(RExC_parse, '}');
5974     if ( ! endbrace ) {
5975         RExC_parse++;
5976         vFAIL("Missing right brace on \\N{}");
5977     }
5978     RExC_parse = endbrace + 1;
5979
5980
5981     /* RExC_parse points at the beginning brace,
5982        endbrace points at the last */
5983     if ( name[0]=='U' && name[1]=='+' ) {
5984         /* its a "unicode hex" notation {U+89AB} */
5985         I32 fl = PERL_SCAN_ALLOW_UNDERSCORES
5986             | PERL_SCAN_DISALLOW_PREFIX
5987             | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
5988         UV cp;
5989         len = (STRLEN)(endbrace - name - 2);
5990         cp = grok_hex(name + 2, &len, &fl, NULL);
5991         if ( len != (STRLEN)(endbrace - name - 2) ) {
5992             cp = 0xFFFD;
5993         }
5994         if (cp > 0xff)
5995             RExC_utf8 = 1;
5996         if ( valuep ) {
5997             *valuep = cp;
5998             return NULL;
5999         }
6000         sv_str= Perl_newSVpvf_nocontext("%c",(int)cp);
6001     } else {
6002         /* fetch the charnames handler for this scope */
6003         HV * const table = GvHV(PL_hintgv);
6004         SV **cvp= table ?
6005             hv_fetchs(table, "charnames", FALSE) :
6006             NULL;
6007         SV *cv= cvp ? *cvp : NULL;
6008         HE *he_str;
6009         int count;
6010         /* create an SV with the name as argument */
6011         sv_name = newSVpvn(name, endbrace - name);
6012
6013         if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
6014             vFAIL2("Constant(\\N{%s}) unknown: "
6015                   "(possibly a missing \"use charnames ...\")",
6016                   SvPVX(sv_name));
6017         }
6018         if (!cvp || !SvOK(*cvp)) { /* when $^H{charnames} = undef; */
6019             vFAIL2("Constant(\\N{%s}): "
6020                   "$^H{charnames} is not defined",SvPVX(sv_name));
6021         }
6022
6023
6024
6025         if (!RExC_charnames) {
6026             /* make sure our cache is allocated */
6027             RExC_charnames = newHV();
6028             sv_2mortal((SV*)RExC_charnames);
6029         }
6030             /* see if we have looked this one up before */
6031         he_str = hv_fetch_ent( RExC_charnames, sv_name, 0, 0 );
6032         if ( he_str ) {
6033             sv_str = HeVAL(he_str);
6034             cached = 1;
6035         } else {
6036             dSP ;
6037
6038             ENTER ;
6039             SAVETMPS ;
6040             PUSHMARK(SP) ;
6041
6042             XPUSHs(sv_name);
6043
6044             PUTBACK ;
6045
6046             count= call_sv(cv, G_SCALAR);
6047
6048             if (count == 1) { /* XXXX is this right? dmq */
6049                 sv_str = POPs;
6050                 SvREFCNT_inc_simple_void(sv_str);
6051             }
6052
6053             SPAGAIN ;
6054             PUTBACK ;
6055             FREETMPS ;
6056             LEAVE ;
6057
6058             if ( !sv_str || !SvOK(sv_str) ) {
6059                 vFAIL2("Constant(\\N{%s}): Call to &{$^H{charnames}} "
6060                       "did not return a defined value",SvPVX(sv_name));
6061             }
6062             if (hv_store_ent( RExC_charnames, sv_name, sv_str, 0))
6063                 cached = 1;
6064         }
6065     }
6066     if (valuep) {
6067         char *p = SvPV(sv_str, len);
6068         if (len) {
6069             STRLEN numlen = 1;
6070             if ( SvUTF8(sv_str) ) {
6071                 *valuep = utf8_to_uvchr((U8*)p, &numlen);
6072                 if (*valuep > 0x7F)
6073                     RExC_utf8 = 1;
6074                 /* XXXX
6075                   We have to turn on utf8 for high bit chars otherwise
6076                   we get failures with
6077
6078                    "ss" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i
6079                    "SS" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i
6080
6081                   This is different from what \x{} would do with the same
6082                   codepoint, where the condition is > 0xFF.
6083                   - dmq
6084                 */
6085
6086
6087             } else {
6088                 *valuep = (UV)*p;
6089                 /* warn if we havent used the whole string? */
6090             }
6091             if (numlen<len && SIZE_ONLY && ckWARN(WARN_REGEXP)) {
6092                 vWARN2(RExC_parse,
6093                     "Ignoring excess chars from \\N{%s} in character class",
6094                     SvPVX(sv_name)
6095                 );
6096             }
6097         } else if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
6098             vWARN2(RExC_parse,
6099                     "Ignoring zero length \\N{%s} in character class",
6100                     SvPVX(sv_name)
6101                 );
6102         }
6103         if (sv_name)
6104             SvREFCNT_dec(sv_name);
6105         if (!cached)
6106             SvREFCNT_dec(sv_str);
6107         return len ? NULL : (regnode *)&len;
6108     } else if(SvCUR(sv_str)) {
6109
6110         char *s;
6111         char *p, *pend;
6112         STRLEN charlen = 1;
6113         char * parse_start = name-3; /* needed for the offsets */
6114         GET_RE_DEBUG_FLAGS_DECL;     /* needed for the offsets */
6115
6116         ret = reg_node(pRExC_state,
6117             (U8)(FOLD ? (LOC ? EXACTFL : EXACTF) : EXACT));
6118         s= STRING(ret);
6119
6120         if ( RExC_utf8 && !SvUTF8(sv_str) ) {
6121             sv_utf8_upgrade(sv_str);
6122         } else if ( !RExC_utf8 && SvUTF8(sv_str) ) {
6123             RExC_utf8= 1;
6124         }
6125
6126         p = SvPV(sv_str, len);
6127         pend = p + len;
6128         /* len is the length written, charlen is the size the char read */
6129         for ( len = 0; p < pend; p += charlen ) {
6130             if (UTF) {
6131                 UV uvc = utf8_to_uvchr((U8*)p, &charlen);
6132                 if (FOLD) {
6133                     STRLEN foldlen,numlen;
6134                     U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
6135                     uvc = toFOLD_uni(uvc, tmpbuf, &foldlen);
6136                     /* Emit all the Unicode characters. */
6137
6138                     for (foldbuf = tmpbuf;
6139                         foldlen;
6140                         foldlen -= numlen)
6141                     {
6142                         uvc = utf8_to_uvchr(foldbuf, &numlen);
6143                         if (numlen > 0) {
6144                             const STRLEN unilen = reguni(pRExC_state, uvc, s);
6145                             s       += unilen;
6146                             len     += unilen;
6147                             /* In EBCDIC the numlen
6148                             * and unilen can differ. */
6149                             foldbuf += numlen;
6150                             if (numlen >= foldlen)
6151                                 break;
6152                         }
6153                         else
6154                             break; /* "Can't happen." */
6155                     }
6156                 } else {
6157                     const STRLEN unilen = reguni(pRExC_state, uvc, s);
6158                     if (unilen > 0) {
6159                        s   += unilen;
6160                        len += unilen;
6161                     }
6162                 }
6163             } else {
6164                 len++;
6165                 REGC(*p, s++);
6166             }
6167         }
6168         if (SIZE_ONLY) {
6169             RExC_size += STR_SZ(len);
6170         } else {
6171             STR_LEN(ret) = len;
6172             RExC_emit += STR_SZ(len);
6173         }
6174         Set_Node_Cur_Length(ret); /* MJD */
6175         RExC_parse--;
6176         nextchar(pRExC_state);
6177     } else {
6178         ret = reg_node(pRExC_state,NOTHING);
6179     }
6180     if (!cached) {
6181         SvREFCNT_dec(sv_str);
6182     }
6183     if (sv_name) {
6184         SvREFCNT_dec(sv_name);
6185     }
6186     return ret;
6187
6188 }
6189
6190
6191 /*
6192  * reg_recode
6193  *
6194  * It returns the code point in utf8 for the value in *encp.
6195  *    value: a code value in the source encoding
6196  *    encp:  a pointer to an Encode object
6197  *
6198  * If the result from Encode is not a single character,
6199  * it returns U+FFFD (Replacement character) and sets *encp to NULL.
6200  */
6201 STATIC UV
6202 S_reg_recode(pTHX_ const char value, SV **encp)
6203 {
6204     STRLEN numlen = 1;
6205     SV * const sv = sv_2mortal(newSVpvn(&value, numlen));
6206     const char * const s = encp && *encp ? sv_recode_to_utf8(sv, *encp)
6207                                          : SvPVX(sv);
6208     const STRLEN newlen = SvCUR(sv);
6209     UV uv = UNICODE_REPLACEMENT;
6210
6211     if (newlen)
6212         uv = SvUTF8(sv)
6213              ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
6214              : *(U8*)s;
6215
6216     if (!newlen || numlen != newlen) {
6217         uv = UNICODE_REPLACEMENT;
6218         if (encp)
6219             *encp = NULL;
6220     }
6221     return uv;
6222 }
6223
6224
6225 /*
6226  - regatom - the lowest level
6227
6228    Try to identify anything special at the start of the pattern. If there
6229    is, then handle it as required. This may involve generating a single regop,
6230    such as for an assertion; or it may involve recursing, such as to
6231    handle a () structure.
6232
6233    If the string doesn't start with something special then we gobble up
6234    as much literal text as we can.
6235
6236    Once we have been able to handle whatever type of thing started the
6237    sequence, we return.
6238
6239    Note: we have to be careful with escapes, as they can be both literal
6240    and special, and in the case of \10 and friends can either, depending
6241    on context. Specifically there are two seperate switches for handling
6242    escape sequences, with the one for handling literal escapes requiring
6243    a dummy entry for all of the special escapes that are actually handled
6244    by the other.
6245 */
6246
6247 STATIC regnode *
6248 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
6249 {
6250     dVAR;
6251     register regnode *ret = NULL;
6252     I32 flags;
6253     char *parse_start = RExC_parse;
6254     GET_RE_DEBUG_FLAGS_DECL;
6255     DEBUG_PARSE("atom");
6256     *flagp = WORST;             /* Tentatively. */
6257
6258
6259 tryagain:
6260     switch (*RExC_parse) {
6261     case '^':
6262         RExC_seen_zerolen++;
6263         nextchar(pRExC_state);
6264         if (RExC_flags & RXf_PMf_MULTILINE)
6265             ret = reg_node(pRExC_state, MBOL);
6266         else if (RExC_flags & RXf_PMf_SINGLELINE)
6267             ret = reg_node(pRExC_state, SBOL);
6268         else
6269             ret = reg_node(pRExC_state, BOL);
6270         Set_Node_Length(ret, 1); /* MJD */
6271         break;
6272     case '$':
6273         nextchar(pRExC_state);
6274         if (*RExC_parse)
6275             RExC_seen_zerolen++;
6276         if (RExC_flags & RXf_PMf_MULTILINE)
6277             ret = reg_node(pRExC_state, MEOL);
6278         else if (RExC_flags & RXf_PMf_SINGLELINE)
6279             ret = reg_node(pRExC_state, SEOL);
6280         else
6281             ret = reg_node(pRExC_state, EOL);
6282         Set_Node_Length(ret, 1); /* MJD */
6283         break;
6284     case '.':
6285         nextchar(pRExC_state);
6286         if (RExC_flags & RXf_PMf_SINGLELINE)
6287             ret = reg_node(pRExC_state, SANY);
6288         else
6289             ret = reg_node(pRExC_state, REG_ANY);
6290         *flagp |= HASWIDTH|SIMPLE;
6291         RExC_naughty++;
6292         Set_Node_Length(ret, 1); /* MJD */
6293         break;
6294     case '[':
6295     {
6296         char * const oregcomp_parse = ++RExC_parse;
6297         ret = regclass(pRExC_state,depth+1);
6298         if (*RExC_parse != ']') {
6299             RExC_parse = oregcomp_parse;
6300             vFAIL("Unmatched [");
6301         }
6302         nextchar(pRExC_state);
6303         *flagp |= HASWIDTH|SIMPLE;
6304         Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
6305         break;
6306     }
6307     case '(':
6308         nextchar(pRExC_state);
6309         ret = reg(pRExC_state, 1, &flags,depth+1);
6310         if (ret == NULL) {
6311                 if (flags & TRYAGAIN) {
6312                     if (RExC_parse == RExC_end) {
6313                          /* Make parent create an empty node if needed. */
6314                         *flagp |= TRYAGAIN;
6315                         return(NULL);
6316                     }
6317                     goto tryagain;
6318                 }
6319                 return(NULL);
6320         }
6321         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE);
6322         break;
6323     case '|':
6324     case ')':
6325         if (flags & TRYAGAIN) {
6326             *flagp |= TRYAGAIN;
6327             return NULL;
6328         }
6329         vFAIL("Internal urp");
6330                                 /* Supposed to be caught earlier. */
6331         break;
6332     case '{':
6333         if (!regcurly(RExC_parse)) {
6334             RExC_parse++;
6335             goto defchar;
6336         }
6337         /* FALL THROUGH */
6338     case '?':
6339     case '+':
6340     case '*':
6341         RExC_parse++;
6342         vFAIL("Quantifier follows nothing");
6343         break;
6344     case '\\':
6345         /* Special Escapes
6346
6347            This switch handles escape sequences that resolve to some kind
6348            of special regop and not to literal text. Escape sequnces that
6349            resolve to literal text are handled below in the switch marked
6350            "Literal Escapes".
6351
6352            Every entry in this switch *must* have a corresponding entry
6353            in the literal escape switch. However, the opposite is not
6354            required, as the default for this switch is to jump to the
6355            literal text handling code.
6356         */
6357         switch (*++RExC_parse) {
6358         /* Special Escapes */
6359         case 'A':
6360             RExC_seen_zerolen++;
6361             ret = reg_node(pRExC_state, SBOL);
6362             *flagp |= SIMPLE;
6363             goto finish_meta_pat;
6364         case 'G':
6365             ret = reg_node(pRExC_state, GPOS);
6366             RExC_seen |= REG_SEEN_GPOS;
6367             *flagp |= SIMPLE;
6368             goto finish_meta_pat;
6369         case 'K':
6370             RExC_seen_zerolen++;
6371             ret = reg_node(pRExC_state, KEEPS);
6372             *flagp |= SIMPLE;
6373             goto finish_meta_pat;
6374         case 'Z':
6375             ret = reg_node(pRExC_state, SEOL);
6376             *flagp |= SIMPLE;
6377             RExC_seen_zerolen++;                /* Do not optimize RE away */
6378             goto finish_meta_pat;
6379         case 'z':
6380             ret = reg_node(pRExC_state, EOS);
6381             *flagp |= SIMPLE;
6382             RExC_seen_zerolen++;                /* Do not optimize RE away */
6383             goto finish_meta_pat;
6384         case 'C':
6385             ret = reg_node(pRExC_state, CANY);
6386             RExC_seen |= REG_SEEN_CANY;
6387             *flagp |= HASWIDTH|SIMPLE;
6388             goto finish_meta_pat;
6389         case 'X':
6390             ret = reg_node(pRExC_state, CLUMP);
6391             *flagp |= HASWIDTH;
6392             goto finish_meta_pat;
6393         case 'w':
6394             ret = reg_node(pRExC_state, (U8)(LOC ? ALNUML     : ALNUM));
6395             *flagp |= HASWIDTH|SIMPLE;
6396             goto finish_meta_pat;
6397         case 'W':
6398             ret = reg_node(pRExC_state, (U8)(LOC ? NALNUML    : NALNUM));
6399             *flagp |= HASWIDTH|SIMPLE;
6400             goto finish_meta_pat;
6401         case 'b':
6402             RExC_seen_zerolen++;
6403             RExC_seen |= REG_SEEN_LOOKBEHIND;
6404             ret = reg_node(pRExC_state, (U8)(LOC ? BOUNDL     : BOUND));
6405             *flagp |= SIMPLE;
6406             goto finish_meta_pat;
6407         case 'B':
6408             RExC_seen_zerolen++;
6409             RExC_seen |= REG_SEEN_LOOKBEHIND;
6410             ret = reg_node(pRExC_state, (U8)(LOC ? NBOUNDL    : NBOUND));
6411             *flagp |= SIMPLE;
6412             goto finish_meta_pat;
6413         case 's':
6414             ret = reg_node(pRExC_state, (U8)(LOC ? SPACEL     : SPACE));
6415             *flagp |= HASWIDTH|SIMPLE;
6416             goto finish_meta_pat;
6417         case 'S':
6418             ret = reg_node(pRExC_state, (U8)(LOC ? NSPACEL    : NSPACE));
6419             *flagp |= HASWIDTH|SIMPLE;
6420             goto finish_meta_pat;
6421         case 'd':
6422             ret = reg_node(pRExC_state, DIGIT);
6423             *flagp |= HASWIDTH|SIMPLE;
6424             goto finish_meta_pat;
6425         case 'D':
6426             ret = reg_node(pRExC_state, NDIGIT);
6427             *flagp |= HASWIDTH|SIMPLE;
6428             goto finish_meta_pat;
6429         case 'v':
6430             ret = reganode(pRExC_state, PRUNE, 0);
6431             ret->flags = 1;
6432             *flagp |= SIMPLE;
6433             goto finish_meta_pat;
6434         case 'V':
6435             ret = reganode(pRExC_state, SKIP, 0);
6436             ret->flags = 1;
6437             *flagp |= SIMPLE;
6438          finish_meta_pat:
6439             nextchar(pRExC_state);
6440             Set_Node_Length(ret, 2); /* MJD */
6441             break;
6442         case 'p':
6443         case 'P':
6444             {
6445                 char* const oldregxend = RExC_end;
6446                 char* parse_start = RExC_parse - 2;
6447
6448                 if (RExC_parse[1] == '{') {
6449                   /* a lovely hack--pretend we saw [\pX] instead */
6450                     RExC_end = strchr(RExC_parse, '}');
6451                     if (!RExC_end) {
6452                         const U8 c = (U8)*RExC_parse;
6453                         RExC_parse += 2;
6454                         RExC_end = oldregxend;
6455                         vFAIL2("Missing right brace on \\%c{}", c);
6456                     }
6457                     RExC_end++;
6458                 }
6459                 else {
6460                     RExC_end = RExC_parse + 2;
6461                     if (RExC_end > oldregxend)
6462                         RExC_end = oldregxend;
6463                 }
6464                 RExC_parse--;
6465
6466                 ret = regclass(pRExC_state,depth+1);
6467
6468                 RExC_end = oldregxend;
6469                 RExC_parse--;
6470
6471                 Set_Node_Offset(ret, parse_start + 2);
6472                 Set_Node_Cur_Length(ret);
6473                 nextchar(pRExC_state);
6474                 *flagp |= HASWIDTH|SIMPLE;
6475             }
6476             break;
6477         case 'N':
6478             /* Handle \N{NAME} here and not below because it can be
6479             multicharacter. join_exact() will join them up later on.
6480             Also this makes sure that things like /\N{BLAH}+/ and
6481             \N{BLAH} being multi char Just Happen. dmq*/
6482             ++RExC_parse;
6483             ret= reg_namedseq(pRExC_state, NULL);
6484             break;
6485         case 'k':    /* Handle \k<NAME> and \k'NAME' */
6486         parse_named_seq:
6487         {
6488             char ch= RExC_parse[1];
6489             if (ch != '<' && ch != '\'' && ch != '{') {
6490                 RExC_parse++;
6491                 vFAIL2("Sequence %.2s... not terminated",parse_start);
6492             } else {
6493                 /* this pretty much dupes the code for (?P=...) in reg(), if
6494                    you change this make sure you change that */
6495                 char* name_start = (RExC_parse += 2);
6496                 U32 num = 0;
6497                 SV *sv_dat = reg_scan_name(pRExC_state,
6498                     SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
6499                 ch= (ch == '<') ? '>' : (ch == '{') ? '}' : '\'';
6500                 if (RExC_parse == name_start || *RExC_parse != ch)
6501                     vFAIL2("Sequence %.3s... not terminated",parse_start);
6502
6503                 if (!SIZE_ONLY) {
6504                     num = add_data( pRExC_state, 1, "S" );
6505                     RExC_rxi->data->data[num]=(void*)sv_dat;
6506                     SvREFCNT_inc(sv_dat);
6507                 }
6508
6509                 RExC_sawback = 1;
6510                 ret = reganode(pRExC_state,
6511                            (U8)(FOLD ? (LOC ? NREFFL : NREFF) : NREF),
6512                            num);
6513                 *flagp |= HASWIDTH;
6514
6515                 /* override incorrect value set in reganode MJD */
6516                 Set_Node_Offset(ret, parse_start+1);
6517                 Set_Node_Cur_Length(ret); /* MJD */
6518                 nextchar(pRExC_state);
6519
6520             }
6521             break;
6522         }
6523         case 'g':
6524         case '1': case '2': case '3': case '4':
6525         case '5': case '6': case '7': case '8': case '9':
6526             {
6527                 I32 num;
6528                 bool isg = *RExC_parse == 'g';
6529                 bool isrel = 0;
6530                 bool hasbrace = 0;
6531                 if (isg) {
6532                     RExC_parse++;
6533                     if (*RExC_parse == '{') {
6534                         RExC_parse++;
6535                         hasbrace = 1;
6536                     }
6537                     if (*RExC_parse == '-') {
6538                         RExC_parse++;
6539                         isrel = 1;
6540                     }
6541                     if (hasbrace && !isDIGIT(*RExC_parse)) {
6542                         if (isrel) RExC_parse--;
6543                         RExC_parse -= 2;
6544                         goto parse_named_seq;
6545                 }   }
6546                 num = atoi(RExC_parse);
6547                 if (isrel) {
6548                     num = RExC_npar - num;
6549                     if (num < 1)
6550                         vFAIL("Reference to nonexistent or unclosed group");
6551                 }
6552                 if (!isg && num > 9 && num >= RExC_npar)
6553                     goto defchar;
6554                 else {
6555                     char * const parse_start = RExC_parse - 1; /* MJD */
6556                     while (isDIGIT(*RExC_parse))
6557                         RExC_parse++;
6558                     if (parse_start == RExC_parse - 1)
6559                         vFAIL("Unterminated \\g... pattern");
6560                     if (hasbrace) {
6561                         if (*RExC_parse != '}')
6562                             vFAIL("Unterminated \\g{...} pattern");
6563                         RExC_parse++;
6564                     }
6565                     if (!SIZE_ONLY) {
6566                         if (num > (I32)RExC_rx->nparens)
6567                             vFAIL("Reference to nonexistent group");
6568                     }
6569                     RExC_sawback = 1;
6570                     ret = reganode(pRExC_state,
6571                                    (U8)(FOLD ? (LOC ? REFFL : REFF) : REF),
6572                                    num);
6573                     *flagp |= HASWIDTH;
6574
6575                     /* override incorrect value set in reganode MJD */
6576                     Set_Node_Offset(ret, parse_start+1);
6577                     Set_Node_Cur_Length(ret); /* MJD */
6578                     RExC_parse--;
6579                     nextchar(pRExC_state);
6580                 }
6581             }
6582             break;
6583         case '\0':
6584             if (RExC_parse >= RExC_end)
6585                 FAIL("Trailing \\");
6586             /* FALL THROUGH */
6587         default:
6588             /* Do not generate "unrecognized" warnings here, we fall
6589                back into the quick-grab loop below */
6590             parse_start--;
6591             goto defchar;
6592         }
6593         break;
6594
6595     case '#':
6596         if (RExC_flags & RXf_PMf_EXTENDED) {
6597             while (RExC_parse < RExC_end && *RExC_parse != '\n')
6598                 RExC_parse++;
6599             if (RExC_parse < RExC_end)
6600                 goto tryagain;
6601         }
6602         /* FALL THROUGH */
6603
6604     default: {
6605             register STRLEN len;
6606             register UV ender;
6607             register char *p;
6608             char *s;
6609             STRLEN foldlen;
6610             U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
6611
6612             parse_start = RExC_parse - 1;
6613
6614             RExC_parse++;
6615
6616         defchar:
6617             ender = 0;
6618             ret = reg_node(pRExC_state,
6619                            (U8)(FOLD ? (LOC ? EXACTFL : EXACTF) : EXACT));
6620             s = STRING(ret);
6621             for (len = 0, p = RExC_parse - 1;
6622               len < 127 && p < RExC_end;
6623               len++)
6624             {
6625                 char * const oldp = p;
6626
6627                 if (RExC_flags & RXf_PMf_EXTENDED)
6628                     p = regwhite(p, RExC_end);
6629                 switch (*p) {
6630                 case '^':
6631                 case '$':
6632                 case '.':
6633                 case '[':
6634                 case '(':
6635                 case ')':
6636                 case '|':
6637                     goto loopdone;
6638                 case '\\':
6639                     /* Literal Escapes Switch
6640
6641                        This switch is meant to handle escape sequences that
6642                        resolve to a literal character.
6643
6644                        Every escape sequence that represents something
6645                        else, like an assertion or a char class, is handled
6646                        in the switch marked 'Special Escapes' above in this
6647                        routine, but also has an entry here as anything that
6648                        isn't explicitly mentioned here will be treated as
6649                        an unescaped equivalent literal.
6650                     */
6651
6652                     switch (*++p) {
6653                     /* These are all the special escapes. */
6654                     case 'A':             /* Start assertion */
6655                     case 'b': case 'B':   /* Word-boundary assertion*/
6656                     case 'C':             /* Single char !DANGEROUS! */
6657                     case 'd': case 'D':   /* digit class */
6658                     case 'g': case 'G':   /* generic-backref, pos assertion */
6659                     case 'k': case 'K':   /* named backref, keep marker */
6660                     case 'N':             /* named char sequence */
6661                     case 'p': case 'P':   /* unicode property */
6662                     case 's': case 'S':   /* space class */
6663                     case 'v': case 'V':   /* (*PRUNE) and (*SKIP) */
6664                     case 'w': case 'W':   /* word class */
6665                     case 'X':             /* eXtended Unicode "combining character sequence" */
6666                     case 'z': case 'Z':   /* End of line/string assertion */
6667                         --p;
6668                         goto loopdone;
6669
6670                     /* Anything after here is an escape that resolves to a
6671                        literal. (Except digits, which may or may not)
6672                      */
6673                     case 'n':
6674                         ender = '\n';
6675                         p++;
6676                         break;
6677                     case 'r':
6678                         ender = '\r';
6679                         p++;
6680                         break;
6681                     case 't':
6682                         ender = '\t';
6683                         p++;
6684                         break;
6685                     case 'f':
6686                         ender = '\f';
6687                         p++;
6688                         break;
6689                     case 'e':
6690                           ender = ASCII_TO_NATIVE('\033');
6691                         p++;
6692                         break;
6693                     case 'a':
6694                           ender = ASCII_TO_NATIVE('\007');
6695                         p++;
6696                         break;
6697                     case 'x':
6698                         if (*++p == '{') {
6699                             char* const e = strchr(p, '}');
6700
6701                             if (!e) {
6702                                 RExC_parse = p + 1;
6703                                 vFAIL("Missing right brace on \\x{}");
6704                             }
6705                             else {
6706                                 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
6707                                     | PERL_SCAN_DISALLOW_PREFIX;
6708                                 STRLEN numlen = e - p - 1;
6709                                 ender = grok_hex(p + 1, &numlen, &flags, NULL);
6710                                 if (ender > 0xff)
6711                                     RExC_utf8 = 1;
6712                                 p = e + 1;
6713                             }
6714                         }
6715                         else {
6716                             I32 flags = PERL_SCAN_DISALLOW_PREFIX;
6717                             STRLEN numlen = 2;
6718                             ender = grok_hex(p, &numlen, &flags, NULL);
6719                             p += numlen;
6720                         }
6721                         if (PL_encoding && ender < 0x100)
6722                             goto recode_encoding;
6723                         break;
6724                     case 'c':
6725                         p++;
6726                         ender = UCHARAT(p++);
6727                         ender = toCTRL(ender);
6728                         break;
6729                     case '0': case '1': case '2': case '3':case '4':
6730                     case '5': case '6': case '7': case '8':case '9':
6731                         if (*p == '0' ||
6732                           (isDIGIT(p[1]) && atoi(p) >= RExC_npar) ) {
6733                             I32 flags = 0;
6734                             STRLEN numlen = 3;
6735                             ender = grok_oct(p, &numlen, &flags, NULL);
6736                             p += numlen;
6737                         }
6738                         else {
6739                             --p;
6740                             goto loopdone;
6741                         }
6742                         if (PL_encoding && ender < 0x100)
6743                             goto recode_encoding;
6744                         break;
6745                     recode_encoding:
6746                         {
6747                             SV* enc = PL_encoding;
6748                             ender = reg_recode((const char)(U8)ender, &enc);
6749                             if (!enc && SIZE_ONLY && ckWARN(WARN_REGEXP))
6750                                 vWARN(p, "Invalid escape in the specified encoding");
6751                             RExC_utf8 = 1;
6752                         }
6753                         break;
6754                     case '\0':
6755                         if (p >= RExC_end)
6756                             FAIL("Trailing \\");
6757                         /* FALL THROUGH */
6758                     default:
6759                         if (!SIZE_ONLY&& isALPHA(*p) && ckWARN(WARN_REGEXP))
6760                             vWARN2(p + 1, "Unrecognized escape \\%c passed through", UCHARAT(p));
6761                         goto normal_default;
6762                     }
6763                     break;
6764                 default:
6765                   normal_default:
6766                     if (UTF8_IS_START(*p) && UTF) {
6767                         STRLEN numlen;
6768                         ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
6769                                                &numlen, UTF8_ALLOW_DEFAULT);
6770                         p += numlen;
6771                     }
6772                     else
6773                         ender = *p++;
6774                     break;
6775                 }
6776                 if (RExC_flags & RXf_PMf_EXTENDED)
6777                     p = regwhite(p, RExC_end);
6778                 if (UTF && FOLD) {
6779                     /* Prime the casefolded buffer. */
6780                     ender = toFOLD_uni(ender, tmpbuf, &foldlen);
6781                 }
6782                 if (ISMULT2(p)) { /* Back off on ?+*. */
6783                     if (len)
6784                         p = oldp;
6785                     else if (UTF) {
6786                          if (FOLD) {
6787                               /* Emit all the Unicode characters. */
6788                               STRLEN numlen;
6789                               for (foldbuf = tmpbuf;
6790                                    foldlen;
6791                                    foldlen -= numlen) {
6792                                    ender = utf8_to_uvchr(foldbuf, &numlen);
6793                                    if (numlen > 0) {
6794                                         const STRLEN unilen = reguni(pRExC_state, ender, s);
6795                                         s       += unilen;
6796                                         len     += unilen;
6797                                         /* In EBCDIC the numlen
6798                                          * and unilen can differ. */
6799                                         foldbuf += numlen;
6800                                         if (numlen >= foldlen)
6801                                              break;
6802                                    }
6803                                    else
6804                                         break; /* "Can't happen." */
6805                               }
6806                          }
6807                          else {
6808                               const STRLEN unilen = reguni(pRExC_state, ender, s);
6809                               if (unilen > 0) {
6810                                    s   += unilen;
6811                                    len += unilen;
6812                               }
6813                          }
6814                     }
6815                     else {
6816                         len++;
6817                         REGC((char)ender, s++);
6818                     }
6819                     break;
6820                 }
6821                 if (UTF) {
6822                      if (FOLD) {
6823                           /* Emit all the Unicode characters. */
6824                           STRLEN numlen;
6825                           for (foldbuf = tmpbuf;
6826                                foldlen;
6827                                foldlen -= numlen) {
6828                                ender = utf8_to_uvchr(foldbuf, &numlen);
6829                                if (numlen > 0) {
6830                                     const STRLEN unilen = reguni(pRExC_state, ender, s);
6831                                     len     += unilen;
6832                                     s       += unilen;
6833                                     /* In EBCDIC the numlen
6834                                      * and unilen can differ. */
6835                                     foldbuf += numlen;
6836                                     if (numlen >= foldlen)
6837                                          break;
6838                                }
6839                                else
6840                                     break;
6841                           }
6842                      }
6843                      else {
6844                           const STRLEN unilen = reguni(pRExC_state, ender, s);
6845                           if (unilen > 0) {
6846                                s   += unilen;
6847                                len += unilen;
6848                           }
6849                      }
6850                      len--;
6851                 }
6852                 else
6853                     REGC((char)ender, s++);
6854             }
6855         loopdone:
6856             RExC_parse = p - 1;
6857             Set_Node_Cur_Length(ret); /* MJD */
6858             nextchar(pRExC_state);
6859             {
6860                 /* len is STRLEN which is unsigned, need to copy to signed */
6861                 IV iv = len;
6862                 if (iv < 0)
6863                     vFAIL("Internal disaster");
6864             }
6865             if (len > 0)
6866                 *flagp |= HASWIDTH;
6867             if (len == 1 && UNI_IS_INVARIANT(ender))
6868                 *flagp |= SIMPLE;
6869
6870             if (SIZE_ONLY)
6871                 RExC_size += STR_SZ(len);
6872             else {
6873                 STR_LEN(ret) = len;
6874                 RExC_emit += STR_SZ(len);
6875             }
6876         }
6877         break;
6878     }
6879
6880     return(ret);
6881 }
6882
6883 STATIC char *
6884 S_regwhite(char *p, const char *e)
6885 {
6886     while (p < e) {
6887         if (isSPACE(*p))
6888             ++p;
6889         else if (*p == '#') {
6890             do {
6891                 p++;
6892             } while (p < e && *p != '\n');
6893         }
6894         else
6895             break;
6896     }
6897     return p;
6898 }
6899
6900 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
6901    Character classes ([:foo:]) can also be negated ([:^foo:]).
6902    Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
6903    Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
6904    but trigger failures because they are currently unimplemented. */
6905
6906 #define POSIXCC_DONE(c)   ((c) == ':')
6907 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
6908 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
6909
6910 STATIC I32
6911 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
6912 {
6913     dVAR;
6914     I32 namedclass = OOB_NAMEDCLASS;
6915
6916     if (value == '[' && RExC_parse + 1 < RExC_end &&
6917         /* I smell either [: or [= or [. -- POSIX has been here, right? */
6918         POSIXCC(UCHARAT(RExC_parse))) {
6919         const char c = UCHARAT(RExC_parse);
6920         char* const s = RExC_parse++;
6921
6922         while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
6923             RExC_parse++;
6924         if (RExC_parse == RExC_end)
6925             /* Grandfather lone [:, [=, [. */
6926             RExC_parse = s;
6927         else {
6928             const char* const t = RExC_parse++; /* skip over the c */
6929             assert(*t == c);
6930
6931             if (UCHARAT(RExC_parse) == ']') {
6932                 const char *posixcc = s + 1;
6933                 RExC_parse++; /* skip over the ending ] */
6934
6935                 if (*s == ':') {
6936                     const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
6937                     const I32 skip = t - posixcc;
6938
6939                     /* Initially switch on the length of the name.  */
6940                     switch (skip) {
6941                     case 4:
6942                         if (memEQ(posixcc, "word", 4)) /* this is not POSIX, this is the Perl \w */
6943                             namedclass = complement ? ANYOF_NALNUM : ANYOF_ALNUM;
6944                         break;
6945                     case 5:
6946                         /* Names all of length 5.  */
6947                         /* alnum alpha ascii blank cntrl digit graph lower
6948                            print punct space upper  */
6949                         /* Offset 4 gives the best switch position.  */
6950                         switch (posixcc[4]) {
6951                         case 'a':
6952                             if (memEQ(posixcc, "alph", 4)) /* alpha */
6953                                 namedclass = complement ? ANYOF_NALPHA : ANYOF_ALPHA;
6954                             break;
6955                         case 'e':
6956                             if (memEQ(posixcc, "spac", 4)) /* space */
6957                                 namedclass = complement ? ANYOF_NPSXSPC : ANYOF_PSXSPC;
6958                             break;
6959                         case 'h':
6960                             if (memEQ(posixcc, "grap", 4)) /* graph */
6961                                 namedclass = complement ? ANYOF_NGRAPH : ANYOF_GRAPH;
6962                             break;
6963                         case 'i':
6964                             if (memEQ(posixcc, "asci", 4)) /* ascii */
6965                                 namedclass = complement ? ANYOF_NASCII : ANYOF_ASCII;
6966                             break;
6967                         case 'k':
6968                             if (memEQ(posixcc, "blan", 4)) /* blank */
6969                                 namedclass = complement ? ANYOF_NBLANK : ANYOF_BLANK;
6970                             break;
6971                         case 'l':
6972                             if (memEQ(posixcc, "cntr", 4)) /* cntrl */
6973                                 namedclass = complement ? ANYOF_NCNTRL : ANYOF_CNTRL;
6974                             break;
6975                         case 'm':
6976                             if (memEQ(posixcc, "alnu", 4)) /* alnum */
6977                                 namedclass = complement ? ANYOF_NALNUMC : ANYOF_ALNUMC;
6978                             break;
6979                         case 'r':
6980                             if (memEQ(posixcc, "lowe", 4)) /* lower */
6981                                 namedclass = complement ? ANYOF_NLOWER : ANYOF_LOWER;
6982                             else if (memEQ(posixcc, "uppe", 4)) /* upper */
6983                                 namedclass = complement ? ANYOF_NUPPER : ANYOF_UPPER;
6984                             break;
6985                         case 't':
6986                             if (memEQ(posixcc, "digi", 4)) /* digit */
6987                                 namedclass = complement ? ANYOF_NDIGIT : ANYOF_DIGIT;
6988                             else if (memEQ(posixcc, "prin", 4)) /* print */
6989                                 namedclass = complement ? ANYOF_NPRINT : ANYOF_PRINT;
6990                             else if (memEQ(posixcc, "punc", 4)) /* punct */
6991                                 namedclass = complement ? ANYOF_NPUNCT : ANYOF_PUNCT;
6992                             break;
6993                         }
6994                         break;
6995                     case 6:
6996                         if (memEQ(posixcc, "xdigit", 6))
6997                             namedclass = complement ? ANYOF_NXDIGIT : ANYOF_XDIGIT;
6998                         break;
6999                     }
7000
7001                     if (namedclass == OOB_NAMEDCLASS)
7002                         Simple_vFAIL3("POSIX class [:%.*s:] unknown",
7003                                       t - s - 1, s + 1);
7004                     assert (posixcc[skip] == ':');
7005                     assert (posixcc[skip+1] == ']');
7006                 } else if (!SIZE_ONLY) {
7007                     /* [[=foo=]] and [[.foo.]] are still future. */
7008
7009                     /* adjust RExC_parse so the warning shows after
7010                        the class closes */
7011                     while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
7012                         RExC_parse++;
7013                     Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
7014                 }
7015             } else {
7016                 /* Maternal grandfather:
7017                  * "[:" ending in ":" but not in ":]" */
7018                 RExC_parse = s;
7019             }
7020         }
7021     }
7022
7023     return namedclass;
7024 }
7025
7026 STATIC void
7027 S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
7028 {
7029     dVAR;
7030     if (POSIXCC(UCHARAT(RExC_parse))) {
7031         const char *s = RExC_parse;
7032         const char  c = *s++;
7033
7034         while (isALNUM(*s))
7035             s++;
7036         if (*s && c == *s && s[1] == ']') {
7037             if (ckWARN(WARN_REGEXP))
7038                 vWARN3(s+2,
7039                         "POSIX syntax [%c %c] belongs inside character classes",
7040                         c, c);
7041
7042             /* [[=foo=]] and [[.foo.]] are still future. */
7043             if (POSIXCC_NOTYET(c)) {
7044                 /* adjust RExC_parse so the error shows after
7045                    the class closes */
7046                 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
7047                     NOOP;
7048                 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
7049             }
7050         }
7051     }
7052 }
7053
7054
7055 #define _C_C_T_(NAME,TEST,WORD)                         \
7056 ANYOF_##NAME:                                           \
7057     if (LOC)                                            \
7058         ANYOF_CLASS_SET(ret, ANYOF_##NAME);             \
7059     else {                                              \
7060         for (value = 0; value < 256; value++)           \
7061             if (TEST)                                   \
7062                 ANYOF_BITMAP_SET(ret, value);           \
7063     }                                                   \
7064     yesno = '+';                                        \
7065     what = WORD;                                        \
7066     break;                                              \
7067 case ANYOF_N##NAME:                                     \
7068     if (LOC)                                            \
7069         ANYOF_CLASS_SET(ret, ANYOF_N##NAME);            \
7070     else {                                              \
7071         for (value = 0; value < 256; value++)           \
7072             if (!TEST)                                  \
7073                 ANYOF_BITMAP_SET(ret, value);           \
7074     }                                                   \
7075     yesno = '!';                                        \
7076     what = WORD;                                        \
7077     break
7078
7079
7080 /*
7081    parse a class specification and produce either an ANYOF node that
7082    matches the pattern or if the pattern matches a single char only and
7083    that char is < 256 and we are case insensitive then we produce an
7084    EXACT node instead.
7085 */
7086
7087 STATIC regnode *
7088 S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth)
7089 {
7090     dVAR;
7091     register UV value = 0;
7092     register UV nextvalue;
7093     register IV prevvalue = OOB_UNICODE;
7094     register IV range = 0;
7095     register regnode *ret;
7096     STRLEN numlen;
7097     IV namedclass;
7098     char *rangebegin = NULL;
7099     bool need_class = 0;
7100     SV *listsv = NULL;
7101     UV n;
7102     bool optimize_invert   = TRUE;
7103     AV* unicode_alternate  = NULL;
7104 #ifdef EBCDIC
7105     UV literal_endpoint = 0;
7106 #endif
7107     UV stored = 0;  /* number of chars stored in the class */
7108
7109     regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
7110         case we need to change the emitted regop to an EXACT. */
7111     const char * orig_parse = RExC_parse;
7112     GET_RE_DEBUG_FLAGS_DECL;
7113 #ifndef DEBUGGING
7114     PERL_UNUSED_ARG(depth);
7115 #endif
7116
7117     DEBUG_PARSE("clas");
7118
7119     /* Assume we are going to generate an ANYOF node. */
7120     ret = reganode(pRExC_state, ANYOF, 0);
7121
7122     if (!SIZE_ONLY)
7123         ANYOF_FLAGS(ret) = 0;
7124
7125     if (UCHARAT(RExC_parse) == '^') {   /* Complement of range. */
7126         RExC_naughty++;
7127         RExC_parse++;
7128         if (!SIZE_ONLY)
7129             ANYOF_FLAGS(ret) |= ANYOF_INVERT;
7130     }
7131
7132     if (SIZE_ONLY) {
7133         RExC_size += ANYOF_SKIP;
7134         listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
7135     }
7136     else {
7137         RExC_emit += ANYOF_SKIP;
7138         if (FOLD)
7139             ANYOF_FLAGS(ret) |= ANYOF_FOLD;
7140         if (LOC)
7141             ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
7142         ANYOF_BITMAP_ZERO(ret);
7143         listsv = newSVpvs("# comment\n");
7144     }
7145
7146     nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
7147
7148     if (!SIZE_ONLY && POSIXCC(nextvalue))
7149         checkposixcc(pRExC_state);
7150
7151     /* allow 1st char to be ] (allowing it to be - is dealt with later) */
7152     if (UCHARAT(RExC_parse) == ']')
7153         goto charclassloop;
7154
7155 parseit:
7156     while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
7157
7158     charclassloop:
7159
7160         namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
7161
7162         if (!range)
7163             rangebegin = RExC_parse;
7164         if (UTF) {
7165             value = utf8n_to_uvchr((U8*)RExC_parse,
7166                                    RExC_end - RExC_parse,
7167                                    &numlen, UTF8_ALLOW_DEFAULT);
7168             RExC_parse += numlen;
7169         }
7170         else
7171             value = UCHARAT(RExC_parse++);
7172
7173         nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
7174         if (value == '[' && POSIXCC(nextvalue))
7175             namedclass = regpposixcc(pRExC_state, value);
7176         else if (value == '\\') {
7177             if (UTF) {
7178                 value = utf8n_to_uvchr((U8*)RExC_parse,
7179                                    RExC_end - RExC_parse,
7180                                    &numlen, UTF8_ALLOW_DEFAULT);
7181                 RExC_parse += numlen;
7182             }
7183             else
7184                 value = UCHARAT(RExC_parse++);
7185             /* Some compilers cannot handle switching on 64-bit integer
7186              * values, therefore value cannot be an UV.  Yes, this will
7187              * be a problem later if we want switch on Unicode.
7188              * A similar issue a little bit later when switching on
7189              * namedclass. --jhi */
7190             switch ((I32)value) {
7191             case 'w':   namedclass = ANYOF_ALNUM;       break;
7192             case 'W':   namedclass = ANYOF_NALNUM;      break;
7193             case 's':   namedclass = ANYOF_SPACE;       break;
7194             case 'S':   namedclass = ANYOF_NSPACE;      break;
7195             case 'd':   namedclass = ANYOF_DIGIT;       break;
7196             case 'D':   namedclass = ANYOF_NDIGIT;      break;
7197             case 'N':  /* Handle \N{NAME} in class */
7198                 {
7199                     /* We only pay attention to the first char of
7200                     multichar strings being returned. I kinda wonder
7201                     if this makes sense as it does change the behaviour
7202                     from earlier versions, OTOH that behaviour was broken
7203                     as well. */
7204                     UV v; /* value is register so we cant & it /grrr */
7205                     if (reg_namedseq(pRExC_state, &v)) {
7206                         goto parseit;
7207                     }
7208                     value= v;
7209                 }
7210                 break;
7211             case 'p':
7212             case 'P':
7213                 {
7214                 char *e;
7215                 if (RExC_parse >= RExC_end)
7216                     vFAIL2("Empty \\%c{}", (U8)value);
7217                 if (*RExC_parse == '{') {
7218                     const U8 c = (U8)value;
7219                     e = strchr(RExC_parse++, '}');
7220                     if (!e)
7221                         vFAIL2("Missing right brace on \\%c{}", c);
7222                     while (isSPACE(UCHARAT(RExC_parse)))
7223                         RExC_parse++;
7224                     if (e == RExC_parse)
7225                         vFAIL2("Empty \\%c{}", c);
7226                     n = e - RExC_parse;
7227                     while (isSPACE(UCHARAT(RExC_parse + n - 1)))
7228                         n--;
7229                 }
7230                 else {
7231                     e = RExC_parse;
7232                     n = 1;
7233                 }
7234                 if (!SIZE_ONLY) {
7235                     if (UCHARAT(RExC_parse) == '^') {
7236                          RExC_parse++;
7237                          n--;
7238                          value = value == 'p' ? 'P' : 'p'; /* toggle */
7239                          while (isSPACE(UCHARAT(RExC_parse))) {
7240                               RExC_parse++;
7241                               n--;
7242                          }
7243                     }
7244                     Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%.*s\n",
7245                         (value=='p' ? '+' : '!'), (int)n, RExC_parse);
7246                 }
7247                 RExC_parse = e + 1;
7248                 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
7249                 namedclass = ANYOF_MAX;  /* no official name, but it's named */
7250                 }
7251                 break;
7252             case 'n':   value = '\n';                   break;
7253             case 'r':   value = '\r';                   break;
7254             case 't':   value = '\t';                   break;
7255             case 'f':   value = '\f';                   break;
7256             case 'b':   value = '\b';                   break;
7257             case 'e':   value = ASCII_TO_NATIVE('\033');break;
7258             case 'a':   value = ASCII_TO_NATIVE('\007');break;
7259             case 'x':
7260                 if (*RExC_parse == '{') {
7261                     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
7262                         | PERL_SCAN_DISALLOW_PREFIX;
7263                     char * const e = strchr(RExC_parse++, '}');
7264                     if (!e)
7265                         vFAIL("Missing right brace on \\x{}");
7266
7267                     numlen = e - RExC_parse;
7268                     value = grok_hex(RExC_parse, &numlen, &flags, NULL);
7269                     RExC_parse = e + 1;
7270                 }
7271                 else {
7272                     I32 flags = PERL_SCAN_DISALLOW_PREFIX;
7273                     numlen = 2;
7274                     value = grok_hex(RExC_parse, &numlen, &flags, NULL);
7275                     RExC_parse += numlen;
7276                 }
7277                 if (PL_encoding && value < 0x100)
7278                     goto recode_encoding;
7279                 break;
7280             case 'c':
7281                 value = UCHARAT(RExC_parse++);
7282                 value = toCTRL(value);
7283                 break;
7284             case '0': case '1': case '2': case '3': case '4':
7285             case '5': case '6': case '7': case '8': case '9':
7286                 {
7287                     I32 flags = 0;
7288                     numlen = 3;
7289                     value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
7290                     RExC_parse += numlen;
7291                     if (PL_encoding && value < 0x100)
7292                         goto recode_encoding;
7293                     break;
7294                 }
7295             recode_encoding:
7296                 {
7297                     SV* enc = PL_encoding;
7298                     value = reg_recode((const char)(U8)value, &enc);
7299                     if (!enc && SIZE_ONLY && ckWARN(WARN_REGEXP))
7300                         vWARN(RExC_parse,
7301                               "Invalid escape in the specified encoding");
7302                     break;
7303                 }
7304             default:
7305                 if (!SIZE_ONLY && isALPHA(value) && ckWARN(WARN_REGEXP))
7306                     vWARN2(RExC_parse,
7307                            "Unrecognized escape \\%c in character class passed through",
7308                            (int)value);
7309                 break;
7310             }
7311         } /* end of \blah */
7312 #ifdef EBCDIC
7313         else
7314             literal_endpoint++;
7315 #endif
7316
7317         if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
7318
7319             if (!SIZE_ONLY && !need_class)
7320                 ANYOF_CLASS_ZERO(ret);
7321
7322             need_class = 1;
7323
7324             /* a bad range like a-\d, a-[:digit:] ? */
7325             if (range) {
7326                 if (!SIZE_ONLY) {
7327                     if (ckWARN(WARN_REGEXP)) {
7328                         const int w =
7329                             RExC_parse >= rangebegin ?
7330                             RExC_parse - rangebegin : 0;
7331                         vWARN4(RExC_parse,
7332                                "False [] range \"%*.*s\"",
7333                                w, w, rangebegin);
7334                     }
7335                     if (prevvalue < 256) {
7336                         ANYOF_BITMAP_SET(ret, prevvalue);
7337                         ANYOF_BITMAP_SET(ret, '-');
7338                     }
7339                     else {
7340                         ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
7341                         Perl_sv_catpvf(aTHX_ listsv,
7342                                        "%04"UVxf"\n%04"UVxf"\n", (UV)prevvalue, (UV) '-');
7343                     }
7344                 }
7345
7346                 range = 0; /* this was not a true range */
7347             }
7348
7349
7350
7351             if (!SIZE_ONLY) {
7352                 const char *what = NULL;
7353                 char yesno = 0;
7354
7355                 if (namedclass > OOB_NAMEDCLASS)
7356                     optimize_invert = FALSE;
7357                 /* Possible truncation here but in some 64-bit environments
7358                  * the compiler gets heartburn about switch on 64-bit values.
7359                  * A similar issue a little earlier when switching on value.
7360                  * --jhi */
7361                 switch ((I32)namedclass) {
7362                 case _C_C_T_(ALNUM, isALNUM(value), "Word");
7363                 case _C_C_T_(ALNUMC, isALNUMC(value), "Alnum");
7364                 case _C_C_T_(ALPHA, isALPHA(value), "Alpha");
7365                 case _C_C_T_(BLANK, isBLANK(value), "Blank");
7366                 case _C_C_T_(CNTRL, isCNTRL(value), "Cntrl");
7367                 case _C_C_T_(GRAPH, isGRAPH(value), "Graph");
7368                 case _C_C_T_(LOWER, isLOWER(value), "Lower");
7369                 case _C_C_T_(PRINT, isPRINT(value), "Print");
7370                 case _C_C_T_(PSXSPC, isPSXSPC(value), "Space");
7371                 case _C_C_T_(PUNCT, isPUNCT(value), "Punct");
7372                 case _C_C_T_(SPACE, isSPACE(value), "SpacePerl");
7373                 case _C_C_T_(UPPER, isUPPER(value), "Upper");
7374                 case _C_C_T_(XDIGIT, isXDIGIT(value), "XDigit");
7375                 case ANYOF_ASCII:
7376                     if (LOC)
7377                         ANYOF_CLASS_SET(ret, ANYOF_ASCII);
7378                     else {
7379 #ifndef EBCDIC
7380                         for (value = 0; value < 128; value++)
7381                             ANYOF_BITMAP_SET(ret, value);
7382 #else  /* EBCDIC */
7383                         for (value = 0; value < 256; value++) {
7384                             if (isASCII(value))
7385                                 ANYOF_BITMAP_SET(ret, value);
7386                         }
7387 #endif /* EBCDIC */
7388                     }
7389                     yesno = '+';
7390                     what = "ASCII";
7391                     break;
7392                 case ANYOF_NASCII:
7393                     if (LOC)
7394                         ANYOF_CLASS_SET(ret, ANYOF_NASCII);
7395                     else {
7396 #ifndef EBCDIC
7397                         for (value = 128; value < 256; value++)
7398                             ANYOF_BITMAP_SET(ret, value);
7399 #else  /* EBCDIC */
7400                         for (value = 0; value < 256; value++) {
7401                             if (!isASCII(value))
7402                                 ANYOF_BITMAP_SET(ret, value);
7403                         }
7404 #endif /* EBCDIC */
7405                     }
7406                     yesno = '!';
7407                     what = "ASCII";
7408                     break;
7409                 case ANYOF_DIGIT:
7410                     if (LOC)
7411                         ANYOF_CLASS_SET(ret, ANYOF_DIGIT);
7412                     else {
7413                         /* consecutive digits assumed */
7414                         for (value = '0'; value <= '9'; value++)
7415                             ANYOF_BITMAP_SET(ret, value);
7416                     }
7417                     yesno = '+';
7418                     what = "Digit";
7419                     break;
7420                 case ANYOF_NDIGIT:
7421                     if (LOC)
7422                         ANYOF_CLASS_SET(ret, ANYOF_NDIGIT);
7423                     else {
7424                         /* consecutive digits assumed */
7425                         for (value = 0; value < '0'; value++)
7426                             ANYOF_BITMAP_SET(ret, value);
7427                         for (value = '9' + 1; value < 256; value++)
7428                             ANYOF_BITMAP_SET(ret, value);
7429                     }
7430                     yesno = '!';
7431                     what = "Digit";
7432                     break;
7433                 case ANYOF_MAX:
7434                     /* this is to handle \p and \P */
7435                     break;
7436                 default:
7437                     vFAIL("Invalid [::] class");
7438                     break;
7439                 }
7440                 if (what) {
7441                     /* Strings such as "+utf8::isWord\n" */
7442                     Perl_sv_catpvf(aTHX_ listsv, "%cutf8::Is%s\n", yesno, what);
7443                 }
7444                 if (LOC)
7445                     ANYOF_FLAGS(ret) |= ANYOF_CLASS;
7446                 continue;
7447             }
7448         } /* end of namedclass \blah */
7449
7450         if (range) {
7451             if (prevvalue > (IV)value) /* b-a */ {
7452                 const int w = RExC_parse - rangebegin;
7453                 Simple_vFAIL4("Invalid [] range \"%*.*s\"", w, w, rangebegin);
7454                 range = 0; /* not a valid range */
7455             }
7456         }
7457         else {
7458             prevvalue = value; /* save the beginning of the range */
7459             if (*RExC_parse == '-' && RExC_parse+1 < RExC_end &&
7460                 RExC_parse[1] != ']') {
7461                 RExC_parse++;
7462
7463                 /* a bad range like \w-, [:word:]- ? */
7464                 if (namedclass > OOB_NAMEDCLASS) {
7465                     if (ckWARN(WARN_REGEXP)) {
7466                         const int w =
7467                             RExC_parse >= rangebegin ?
7468                             RExC_parse - rangebegin : 0;
7469                         vWARN4(RExC_parse,
7470                                "False [] range \"%*.*s\"",
7471                                w, w, rangebegin);
7472                     }
7473                     if (!SIZE_ONLY)
7474                         ANYOF_BITMAP_SET(ret, '-');
7475                 } else
7476                     range = 1;  /* yeah, it's a range! */
7477                 continue;       /* but do it the next time */
7478             }
7479         }
7480
7481         /* now is the next time */
7482         /*stored += (value - prevvalue + 1);*/
7483         if (!SIZE_ONLY) {
7484             if (prevvalue < 256) {
7485                 const IV ceilvalue = value < 256 ? value : 255;
7486                 IV i;
7487 #ifdef EBCDIC
7488                 /* In EBCDIC [\x89-\x91] should include
7489                  * the \x8e but [i-j] should not. */
7490                 if (literal_endpoint == 2 &&
7491                     ((isLOWER(prevvalue) && isLOWER(ceilvalue)) ||
7492                      (isUPPER(prevvalue) && isUPPER(ceilvalue))))
7493                 {
7494                     if (isLOWER(prevvalue)) {
7495                         for (i = prevvalue; i <= ceilvalue; i++)
7496                             if (isLOWER(i))
7497                                 ANYOF_BITMAP_SET(ret, i);
7498                     } else {
7499                         for (i = prevvalue; i <= ceilvalue; i++)
7500                             if (isUPPER(i))
7501                                 ANYOF_BITMAP_SET(ret, i);
7502                     }
7503                 }
7504                 else
7505 #endif
7506                       for (i = prevvalue; i <= ceilvalue; i++) {
7507                         if (!ANYOF_BITMAP_TEST(ret,i)) {
7508                             stored++;
7509                             ANYOF_BITMAP_SET(ret, i);
7510                         }
7511                       }
7512           }
7513           if (value > 255 || UTF) {
7514                 const UV prevnatvalue  = NATIVE_TO_UNI(prevvalue);
7515                 const UV natvalue      = NATIVE_TO_UNI(value);
7516                 stored+=2; /* can't optimize this class */
7517                 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
7518                 if (prevnatvalue < natvalue) { /* what about > ? */
7519                     Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
7520                                    prevnatvalue, natvalue);
7521                 }
7522                 else if (prevnatvalue == natvalue) {
7523                     Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", natvalue);
7524                     if (FOLD) {
7525                          U8 foldbuf[UTF8_MAXBYTES_CASE+1];
7526                          STRLEN foldlen;
7527                          const UV f = to_uni_fold(natvalue, foldbuf, &foldlen);
7528
7529 #ifdef EBCDIC /* RD t/uni/fold ff and 6b */
7530                          if (RExC_precomp[0] == ':' &&
7531                              RExC_precomp[1] == '[' &&
7532                              (f == 0xDF || f == 0x92)) {
7533                              f = NATIVE_TO_UNI(f);
7534                         }
7535 #endif
7536                          /* If folding and foldable and a single
7537                           * character, insert also the folded version
7538                           * to the charclass. */
7539                          if (f != value) {
7540 #ifdef EBCDIC /* RD tunifold ligatures s,t fb05, fb06 */
7541                              if ((RExC_precomp[0] == ':' &&
7542                                   RExC_precomp[1] == '[' &&
7543                                   (f == 0xA2 &&
7544                                    (value == 0xFB05 || value == 0xFB06))) ?
7545                                  foldlen == ((STRLEN)UNISKIP(f) - 1) :
7546                                  foldlen == (STRLEN)UNISKIP(f) )
7547 #else
7548                               if (foldlen == (STRLEN)UNISKIP(f))
7549 #endif
7550                                   Perl_sv_catpvf(aTHX_ listsv,
7551                                                  "%04"UVxf"\n", f);
7552                               else {
7553                                   /* Any multicharacter foldings
7554                                    * require the following transform:
7555                                    * [ABCDEF] -> (?:[ABCabcDEFd]|pq|rst)
7556                                    * where E folds into "pq" and F folds
7557                                    * into "rst", all other characters
7558                                    * fold to single characters.  We save
7559                                    * away these multicharacter foldings,
7560                                    * to be later saved as part of the
7561                                    * additional "s" data. */
7562                                   SV *sv;
7563
7564                                   if (!unicode_alternate)
7565                                       unicode_alternate = newAV();
7566                                   sv = newSVpvn((char*)foldbuf, foldlen);
7567                                   SvUTF8_on(sv);
7568                                   av_push(unicode_alternate, sv);
7569                               }
7570                          }
7571
7572                          /* If folding and the value is one of the Greek
7573                           * sigmas insert a few more sigmas to make the
7574                           * folding rules of the sigmas to work right.
7575                           * Note that not all the possible combinations
7576                           * are handled here: some of them are handled
7577                           * by the standard folding rules, and some of
7578                           * them (literal or EXACTF cases) are handled
7579                           * during runtime in regexec.c:S_find_byclass(). */
7580                          if (value == UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA) {
7581                               Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
7582                                              (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA);
7583                               Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
7584                                              (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
7585                          }
7586                          else if (value == UNICODE_GREEK_CAPITAL_LETTER_SIGMA)
7587                               Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
7588                                              (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
7589                     }
7590                 }
7591             }
7592 #ifdef EBCDIC
7593             literal_endpoint = 0;
7594 #endif
7595         }
7596
7597         range = 0; /* this range (if it was one) is done now */
7598     }
7599
7600     if (need_class) {
7601         ANYOF_FLAGS(ret) |= ANYOF_LARGE;
7602         if (SIZE_ONLY)
7603             RExC_size += ANYOF_CLASS_ADD_SKIP;
7604         else
7605             RExC_emit += ANYOF_CLASS_ADD_SKIP;
7606     }
7607
7608
7609     if (SIZE_ONLY)
7610         return ret;
7611     /****** !SIZE_ONLY AFTER HERE *********/
7612
7613     if( stored == 1 && value < 256
7614         && !( ANYOF_FLAGS(ret) & ( ANYOF_FLAGS_ALL ^ ANYOF_FOLD ) )
7615     ) {
7616         /* optimize single char class to an EXACT node
7617            but *only* when its not a UTF/high char  */
7618         const char * cur_parse= RExC_parse;
7619         RExC_emit = (regnode *)orig_emit;
7620         RExC_parse = (char *)orig_parse;
7621         ret = reg_node(pRExC_state,
7622                        (U8)((ANYOF_FLAGS(ret) & ANYOF_FOLD) ? EXACTF : EXACT));
7623         RExC_parse = (char *)cur_parse;
7624         *STRING(ret)= (char)value;
7625         STR_LEN(ret)= 1;
7626         RExC_emit += STR_SZ(1);
7627         return ret;
7628     }
7629     /* optimize case-insensitive simple patterns (e.g. /[a-z]/i) */
7630     if ( /* If the only flag is folding (plus possibly inversion). */
7631         ((ANYOF_FLAGS(ret) & (ANYOF_FLAGS_ALL ^ ANYOF_INVERT)) == ANYOF_FOLD)
7632        ) {
7633         for (value = 0; value < 256; ++value) {
7634             if (ANYOF_BITMAP_TEST(ret, value)) {
7635                 UV fold = PL_fold[value];
7636
7637                 if (fold != value)
7638                     ANYOF_BITMAP_SET(ret, fold);
7639             }
7640         }
7641         ANYOF_FLAGS(ret) &= ~ANYOF_FOLD;
7642     }
7643
7644     /* optimize inverted simple patterns (e.g. [^a-z]) */
7645     if (optimize_invert &&
7646         /* If the only flag is inversion. */
7647         (ANYOF_FLAGS(ret) & ANYOF_FLAGS_ALL) == ANYOF_INVERT) {
7648         for (value = 0; value < ANYOF_BITMAP_SIZE; ++value)
7649             ANYOF_BITMAP(ret)[value] ^= ANYOF_FLAGS_ALL;
7650         ANYOF_FLAGS(ret) = ANYOF_UNICODE_ALL;
7651     }
7652     {
7653         AV * const av = newAV();
7654         SV *rv;
7655         /* The 0th element stores the character class description
7656          * in its textual form: used later (regexec.c:Perl_regclass_swash())
7657          * to initialize the appropriate swash (which gets stored in
7658          * the 1st element), and also useful for dumping the regnode.
7659          * The 2nd element stores the multicharacter foldings,
7660          * used later (regexec.c:S_reginclass()). */
7661         av_store(av, 0, listsv);
7662         av_store(av, 1, NULL);
7663         av_store(av, 2, (SV*)unicode_alternate);
7664         rv = newRV_noinc((SV*)av);
7665         n = add_data(pRExC_state, 1, "s");
7666         RExC_rxi->data->data[n] = (void*)rv;
7667         ARG_SET(ret, n);
7668     }
7669     return ret;
7670 }
7671 #undef _C_C_T_
7672
7673
7674 STATIC char*
7675 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
7676 {
7677     char* const retval = RExC_parse++;
7678
7679     for (;;) {
7680         if (*RExC_parse == '(' && RExC_parse[1] == '?' &&
7681                 RExC_parse[2] == '#') {
7682             while (*RExC_parse != ')') {
7683                 if (RExC_parse == RExC_end)
7684                     FAIL("Sequence (?#... not terminated");
7685                 RExC_parse++;
7686             }
7687             RExC_parse++;
7688             continue;
7689         }
7690         if (RExC_flags & RXf_PMf_EXTENDED) {
7691             if (isSPACE(*RExC_parse)) {
7692                 RExC_parse++;
7693                 continue;
7694             }
7695             else if (*RExC_parse == '#') {
7696                 while (RExC_parse < RExC_end)
7697                     if (*RExC_parse++ == '\n') break;
7698                 continue;
7699             }
7700         }
7701         return retval;
7702     }
7703 }
7704
7705 /*
7706 - reg_node - emit a node
7707 */
7708 STATIC regnode *                        /* Location. */
7709 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
7710 {
7711     dVAR;
7712     register regnode *ptr;
7713     regnode * const ret = RExC_emit;
7714     GET_RE_DEBUG_FLAGS_DECL;
7715
7716     if (SIZE_ONLY) {
7717         SIZE_ALIGN(RExC_size);
7718         RExC_size += 1;
7719         return(ret);
7720     }
7721 #ifdef DEBUGGING
7722     if (OP(RExC_emit) == 255)
7723         Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %s: %d ",
7724             reg_name[op], OP(RExC_emit));
7725 #endif
7726     NODE_ALIGN_FILL(ret);
7727     ptr = ret;
7728     FILL_ADVANCE_NODE(ptr, op);
7729     if (RExC_offsets) {         /* MJD */
7730         MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n",
7731               "reg_node", __LINE__,
7732               reg_name[op],
7733               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0]
7734                 ? "Overwriting end of array!\n" : "OK",
7735               (UV)(RExC_emit - RExC_emit_start),
7736               (UV)(RExC_parse - RExC_start),
7737               (UV)RExC_offsets[0]));
7738         Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
7739     }
7740
7741     RExC_emit = ptr;
7742     return(ret);
7743 }
7744
7745 /*
7746 - reganode - emit a node with an argument
7747 */
7748 STATIC regnode *                        /* Location. */
7749 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
7750 {
7751     dVAR;
7752     register regnode *ptr;
7753     regnode * const ret = RExC_emit;
7754     GET_RE_DEBUG_FLAGS_DECL;
7755
7756     if (SIZE_ONLY) {
7757         SIZE_ALIGN(RExC_size);
7758         RExC_size += 2;
7759         /*
7760            We can't do this:
7761
7762            assert(2==regarglen[op]+1);
7763
7764            Anything larger than this has to allocate the extra amount.
7765            If we changed this to be:
7766
7767            RExC_size += (1 + regarglen[op]);
7768
7769            then it wouldn't matter. Its not clear what side effect
7770            might come from that so its not done so far.
7771            -- dmq
7772         */
7773         return(ret);
7774     }
7775 #ifdef DEBUGGING
7776     if (OP(RExC_emit) == 255)
7777         Perl_croak(aTHX_ "panic: reganode overwriting end of allocated program space");
7778 #endif
7779     NODE_ALIGN_FILL(ret);
7780     ptr = ret;
7781     FILL_ADVANCE_NODE_ARG(ptr, op, arg);
7782     if (RExC_offsets) {         /* MJD */
7783         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n",
7784               "reganode",
7785               __LINE__,
7786               reg_name[op],
7787               (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ?
7788               "Overwriting end of array!\n" : "OK",
7789               (UV)(RExC_emit - RExC_emit_start),
7790               (UV)(RExC_parse - RExC_start),
7791               (UV)RExC_offsets[0]));
7792         Set_Cur_Node_Offset;
7793     }
7794
7795     RExC_emit = ptr;
7796     return(ret);
7797 }
7798
7799 /*
7800 - reguni - emit (if appropriate) a Unicode character
7801 */
7802 STATIC STRLEN
7803 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
7804 {
7805     dVAR;
7806     return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
7807 }
7808
7809 /*
7810 - reginsert - insert an operator in front of already-emitted operand
7811 *
7812 * Means relocating the operand.
7813 */
7814 STATIC void
7815 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
7816 {
7817     dVAR;
7818     register regnode *src;
7819     register regnode *dst;
7820     register regnode *place;
7821     const int offset = regarglen[(U8)op];
7822     const int size = NODE_STEP_REGNODE + offset;
7823     GET_RE_DEBUG_FLAGS_DECL;
7824 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
7825     DEBUG_PARSE_FMT("inst"," - %s",reg_name[op]);
7826     if (SIZE_ONLY) {
7827         RExC_size += size;
7828         return;
7829     }
7830
7831     src = RExC_emit;
7832     RExC_emit += size;
7833     dst = RExC_emit;
7834     if (RExC_open_parens) {
7835         int paren;
7836         DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);
7837         for ( paren=0 ; paren < RExC_npar ; paren++ ) {
7838             if ( RExC_open_parens[paren] >= opnd ) {
7839                 DEBUG_PARSE_FMT("open"," - %d",size);
7840                 RExC_open_parens[paren] += size;
7841             } else {
7842                 DEBUG_PARSE_FMT("open"," - %s","ok");
7843             }
7844             if ( RExC_close_parens[paren] >= opnd ) {
7845                 DEBUG_PARSE_FMT("close"," - %d",size);
7846                 RExC_close_parens[paren] += size;
7847             } else {
7848                 DEBUG_PARSE_FMT("close"," - %s","ok");
7849             }
7850         }
7851     }
7852
7853     while (src > opnd) {
7854         StructCopy(--src, --dst, regnode);
7855         if (RExC_offsets) {     /* MJD 20010112 */
7856             MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
7857                   "reg_insert",
7858                   __LINE__,
7859                   reg_name[op],
7860                   (UV)(dst - RExC_emit_start) > RExC_offsets[0]
7861                     ? "Overwriting end of array!\n" : "OK",
7862                   (UV)(src - RExC_emit_start),
7863                   (UV)(dst - RExC_emit_start),
7864                   (UV)RExC_offsets[0]));
7865             Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
7866             Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
7867         }
7868     }
7869
7870
7871     place = opnd;               /* Op node, where operand used to be. */
7872     if (RExC_offsets) {         /* MJD */
7873         MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n",
7874               "reginsert",
7875               __LINE__,
7876               reg_name[op],
7877               (UV)(place - RExC_emit_start) > RExC_offsets[0]
7878               ? "Overwriting end of array!\n" : "OK",
7879               (UV)(place - RExC_emit_start),
7880               (UV)(RExC_parse - RExC_start),
7881               (UV)RExC_offsets[0]));
7882         Set_Node_Offset(place, RExC_parse);
7883         Set_Node_Length(place, 1);
7884     }
7885     src = NEXTOPER(place);
7886     FILL_ADVANCE_NODE(place, op);
7887     Zero(src, offset, regnode);
7888 }
7889
7890 /*
7891 - regtail - set the next-pointer at the end of a node chain of p to val.
7892 - SEE ALSO: regtail_study
7893 */
7894 /* TODO: All three parms should be const */
7895 STATIC void
7896 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
7897 {
7898     dVAR;
7899     register regnode *scan;
7900     GET_RE_DEBUG_FLAGS_DECL;
7901 #ifndef DEBUGGING
7902     PERL_UNUSED_ARG(depth);
7903 #endif
7904
7905     if (SIZE_ONLY)
7906         return;
7907
7908     /* Find last node. */
7909     scan = p;
7910     for (;;) {
7911         regnode * const temp = regnext(scan);
7912         DEBUG_PARSE_r({
7913             SV * const mysv=sv_newmortal();
7914             DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
7915             regprop(RExC_rx, mysv, scan);
7916             PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
7917                 SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
7918                     (temp == NULL ? "->" : ""),
7919                     (temp == NULL ? reg_name[OP(val)] : "")
7920             );
7921         });
7922         if (temp == NULL)
7923             break;
7924         scan = temp;
7925     }
7926
7927     if (reg_off_by_arg[OP(scan)]) {
7928         ARG_SET(scan, val - scan);
7929     }
7930     else {
7931         NEXT_OFF(scan) = val - scan;
7932     }
7933 }
7934
7935 #ifdef DEBUGGING
7936 /*
7937 - regtail_study - set the next-pointer at the end of a node chain of p to val.
7938 - Look for optimizable sequences at the same time.
7939 - currently only looks for EXACT chains.
7940
7941 This is expermental code. The idea is to use this routine to perform
7942 in place optimizations on branches and groups as they are constructed,
7943 with the long term intention of removing optimization from study_chunk so
7944 that it is purely analytical.
7945
7946 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
7947 to control which is which.
7948
7949 */
7950 /* TODO: All four parms should be const */
7951
7952 STATIC U8
7953 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
7954 {
7955     dVAR;
7956     register regnode *scan;
7957     U8 exact = PSEUDO;
7958 #ifdef EXPERIMENTAL_INPLACESCAN
7959     I32 min = 0;
7960 #endif
7961
7962     GET_RE_DEBUG_FLAGS_DECL;
7963
7964
7965     if (SIZE_ONLY)
7966         return exact;
7967
7968     /* Find last node. */
7969
7970     scan = p;
7971     for (;;) {
7972         regnode * const temp = regnext(scan);
7973 #ifdef EXPERIMENTAL_INPLACESCAN
7974         if (PL_regkind[OP(scan)] == EXACT)
7975             if (join_exact(pRExC_state,scan,&min,1,val,depth+1))
7976                 return EXACT;
7977 #endif
7978         if ( exact ) {
7979             switch (OP(scan)) {
7980                 case EXACT:
7981                 case EXACTF:
7982                 case EXACTFL:
7983                         if( exact == PSEUDO )
7984                             exact= OP(scan);
7985                         else if ( exact != OP(scan) )
7986                             exact= 0;
7987                 case NOTHING:
7988                     break;
7989                 default:
7990                     exact= 0;
7991             }
7992         }
7993         DEBUG_PARSE_r({
7994             SV * const mysv=sv_newmortal();
7995             DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
7996             regprop(RExC_rx, mysv, scan);
7997             PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
7998                 SvPV_nolen_const(mysv),
7999                 REG_NODE_NUM(scan),
8000                 reg_name[exact]);
8001         });
8002         if (temp == NULL)
8003             break;
8004         scan = temp;
8005     }
8006     DEBUG_PARSE_r({
8007         SV * const mysv_val=sv_newmortal();
8008         DEBUG_PARSE_MSG("");
8009         regprop(RExC_rx, mysv_val, val);
8010         PerlIO_printf(Perl_debug_log, "~ attach to %s (%"IVdf") offset to %"IVdf"\n",
8011                       SvPV_nolen_const(mysv_val),
8012                       (IV)REG_NODE_NUM(val),
8013                       (IV)(val - scan)
8014         );
8015     });
8016     if (reg_off_by_arg[OP(scan)]) {
8017         ARG_SET(scan, val - scan);
8018     }
8019     else {
8020         NEXT_OFF(scan) = val - scan;
8021     }
8022
8023     return exact;
8024 }
8025 #endif
8026
8027 /*
8028  - regcurly - a little FSA that accepts {\d+,?\d*}
8029  */
8030 STATIC I32
8031 S_regcurly(register const char *s)
8032 {
8033     if (*s++ != '{')
8034         return FALSE;
8035     if (!isDIGIT(*s))
8036         return FALSE;
8037     while (isDIGIT(*s))
8038         s++;
8039     if (*s == ',')
8040         s++;
8041     while (isDIGIT(*s))
8042         s++;
8043     if (*s != '}')
8044         return FALSE;
8045     return TRUE;
8046 }
8047
8048
8049 /*
8050  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
8051  */
8052 void
8053 Perl_regdump(pTHX_ const regexp *r)
8054 {
8055 #ifdef DEBUGGING
8056     dVAR;
8057     SV * const sv = sv_newmortal();
8058     SV *dsv= sv_newmortal();
8059     RXi_GET_DECL(r,ri);
8060
8061     (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
8062
8063     /* Header fields of interest. */
8064     if (r->anchored_substr) {
8065         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr),
8066             RE_SV_DUMPLEN(r->anchored_substr), 30);
8067         PerlIO_printf(Perl_debug_log,
8068                       "anchored %s%s at %"IVdf" ",
8069                       s, RE_SV_TAIL(r->anchored_substr),
8070                       (IV)r->anchored_offset);
8071     } else if (r->anchored_utf8) {
8072         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8),
8073             RE_SV_DUMPLEN(r->anchored_utf8), 30);
8074         PerlIO_printf(Perl_debug_log,
8075                       "anchored utf8 %s%s at %"IVdf" ",
8076                       s, RE_SV_TAIL(r->anchored_utf8),
8077                       (IV)r->anchored_offset);
8078     }
8079     if (r->float_substr) {
8080         RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr),
8081             RE_SV_DUMPLEN(r->float_substr), 30);
8082         PerlIO_printf(Perl_debug_log,
8083                       "floating %s%s at %"IVdf"..%"UVuf" ",
8084                       s, RE_SV_TAIL(r->float_substr),
8085                       (IV)r->float_min_offset, (UV)r->float_max_offset);
8086     } else if (r->float_utf8) {
8087         RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8),
8088             RE_SV_DUMPLEN(r->float_utf8), 30);
8089         PerlIO_printf(Perl_debug_log,
8090                       "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
8091                       s, RE_SV_TAIL(r->float_utf8),
8092                       (IV)r->float_min_offset, (UV)r->float_max_offset);
8093     }
8094     if (r->check_substr || r->check_utf8)
8095         PerlIO_printf(Perl_debug_log,
8096                       (const char *)
8097                       (r->check_substr == r->float_substr
8098                        && r->check_utf8 == r->float_utf8
8099                        ? "(checking floating" : "(checking anchored"));
8100     if (r->extflags & RXf_NOSCAN)
8101         PerlIO_printf(Perl_debug_log, " noscan");
8102     if (r->extflags & RXf_CHECK_ALL)
8103         PerlIO_printf(Perl_debug_log, " isall");
8104     if (r->check_substr || r->check_utf8)
8105         PerlIO_printf(Perl_debug_log, ") ");
8106
8107     if (ri->regstclass) {
8108         regprop(r, sv, ri->regstclass);
8109         PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
8110     }
8111     if (r->extflags & RXf_ANCH) {
8112         PerlIO_printf(Perl_debug_log, "anchored");
8113         if (r->extflags & RXf_ANCH_BOL)
8114             PerlIO_printf(Perl_debug_log, "(BOL)");
8115         if (r->extflags & RXf_ANCH_MBOL)
8116             PerlIO_printf(Perl_debug_log, "(MBOL)");
8117         if (r->extflags & RXf_ANCH_SBOL)
8118             PerlIO_printf(Perl_debug_log, "(SBOL)");
8119         if (r->extflags & RXf_ANCH_GPOS)
8120             PerlIO_printf(Perl_debug_log, "(GPOS)");
8121         PerlIO_putc(Perl_debug_log, ' ');
8122     }
8123     if (r->extflags & RXf_GPOS_SEEN)
8124         PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs);
8125     if (r->intflags & PREGf_SKIP)
8126         PerlIO_printf(Perl_debug_log, "plus ");
8127     if (r->intflags & PREGf_IMPLICIT)
8128         PerlIO_printf(Perl_debug_log, "implicit ");
8129     PerlIO_printf(Perl_debug_log, "minlen %"IVdf" ", (IV)r->minlen);
8130     if (r->extflags & RXf_EVAL_SEEN)
8131         PerlIO_printf(Perl_debug_log, "with eval ");
8132     PerlIO_printf(Perl_debug_log, "\n");
8133 #else
8134     PERL_UNUSED_CONTEXT;
8135     PERL_UNUSED_ARG(r);
8136 #endif  /* DEBUGGING */
8137 }
8138
8139 /*
8140 - regprop - printable representation of opcode
8141 */
8142 void
8143 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
8144 {
8145 #ifdef DEBUGGING
8146     dVAR;
8147     register int k;
8148     RXi_GET_DECL(prog,progi);
8149     GET_RE_DEBUG_FLAGS_DECL;
8150
8151
8152     sv_setpvn(sv, "", 0);
8153
8154     if (OP(o) > REGNODE_MAX)            /* regnode.type is unsigned */
8155         /* It would be nice to FAIL() here, but this may be called from
8156            regexec.c, and it would be hard to supply pRExC_state. */
8157         Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX);
8158     sv_catpv(sv, reg_name[OP(o)]); /* Take off const! */
8159
8160     k = PL_regkind[OP(o)];
8161
8162     if (k == EXACT) {
8163         SV * const dsv = sv_2mortal(newSVpvs(""));
8164         /* Using is_utf8_string() (via PERL_PV_UNI_DETECT)
8165          * is a crude hack but it may be the best for now since
8166          * we have no flag "this EXACTish node was UTF-8"
8167          * --jhi */
8168         const char * const s =
8169             pv_pretty(dsv, STRING(o), STR_LEN(o), 60,
8170                 PL_colors[0], PL_colors[1],
8171                 PERL_PV_ESCAPE_UNI_DETECT |
8172                 PERL_PV_PRETTY_ELIPSES    |
8173                 PERL_PV_PRETTY_LTGT
8174             );
8175         Perl_sv_catpvf(aTHX_ sv, " %s", s );
8176     } else if (k == TRIE) {
8177         /* print the details of the trie in dumpuntil instead, as
8178          * progi->data isn't available here */
8179         const char op = OP(o);
8180         const U32 n = ARG(o);
8181         const reg_ac_data * const ac = IS_TRIE_AC(op) ?
8182                (reg_ac_data *)progi->data->data[n] :
8183                NULL;
8184         const reg_trie_data * const trie
8185             = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
8186
8187         Perl_sv_catpvf(aTHX_ sv, "-%s",reg_name[o->flags]);
8188         DEBUG_TRIE_COMPILE_r(
8189             Perl_sv_catpvf(aTHX_ sv,
8190                 "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
8191                 (UV)trie->startstate,
8192                 (IV)trie->statecount-1, /* -1 because of the unused 0 element */
8193                 (UV)trie->wordcount,
8194                 (UV)trie->minlen,
8195                 (UV)trie->maxlen,
8196                 (UV)TRIE_CHARCOUNT(trie),
8197                 (UV)trie->uniquecharcount
8198             )
8199         );
8200         if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
8201             int i;
8202             int rangestart = -1;
8203             U8* bitmap = IS_ANYOF_TRIE(op) ? (U8*)ANYOF_BITMAP(o) : (U8*)TRIE_BITMAP(trie);
8204             Perl_sv_catpvf(aTHX_ sv, "[");
8205             for (i = 0; i <= 256; i++) {
8206                 if (i < 256 && BITMAP_TEST(bitmap,i)) {
8207                     if (rangestart == -1)
8208                         rangestart = i;
8209                 } else if (rangestart != -1) {
8210                     if (i <= rangestart + 3)
8211                         for (; rangestart < i; rangestart++)
8212                             put_byte(sv, rangestart);
8213                     else {
8214                         put_byte(sv, rangestart);
8215                         sv_catpvs(sv, "-");
8216                         put_byte(sv, i - 1);
8217                     }
8218                     rangestart = -1;
8219                 }
8220             }
8221             Perl_sv_catpvf(aTHX_ sv, "]");
8222         }
8223
8224     } else if (k == CURLY) {
8225         if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
8226             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
8227         Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
8228     }
8229     else if (k == WHILEM && o->flags)                   /* Ordinal/of */
8230         Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
8231     else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) {
8232         Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o));    /* Parenth number */
8233         if ( prog->paren_names ) {
8234             if ( k != REF || OP(o) < NREF) {
8235                 AV *list= (AV *)progi->data->data[progi->name_list_idx];
8236                 SV **name= av_fetch(list, ARG(o), 0 );
8237                 if (name)
8238                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
8239             }
8240             else {
8241                 AV *list= (AV *)progi->data->data[ progi->name_list_idx ];
8242                 SV *sv_dat=(SV*)progi->data->data[ ARG( o ) ];
8243                 I32 *nums=(I32*)SvPVX(sv_dat);
8244                 SV **name= av_fetch(list, nums[0], 0 );
8245                 I32 n;
8246                 if (name) {
8247                     for ( n=0; n<SvIVX(sv_dat); n++ ) {
8248                         Perl_sv_catpvf(aTHX_ sv, "%s%"IVdf,
8249                                     (n ? "," : ""), (IV)nums[n]);
8250                     }
8251                     Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
8252                 }
8253             }
8254         }
8255     } else if (k == GOSUB)
8256         Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */
8257     else if (k == VERB) {
8258         if (!o->flags)
8259             Perl_sv_catpvf(aTHX_ sv, ":%"SVf,
8260                 SVfARG((SV*)progi->data->data[ ARG( o ) ]));
8261     } else if (k == LOGICAL)
8262         Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags);     /* 2: embedded, otherwise 1 */
8263     else if (k == ANYOF) {
8264         int i, rangestart = -1;
8265         const U8 flags = ANYOF_FLAGS(o);
8266
8267         /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
8268         static const char * const anyofs[] = {
8269             "\\w",
8270             "\\W",
8271             "\\s",
8272             "\\S",
8273             "\\d",
8274             "\\D",
8275             "[:alnum:]",
8276             "[:^alnum:]",
8277             "[:alpha:]",
8278             "[:^alpha:]",
8279             "[:ascii:]",
8280             "[:^ascii:]",
8281             "[:ctrl:]",
8282             "[:^ctrl:]",
8283             "[:graph:]",
8284             "[:^graph:]",
8285             "[:lower:]",
8286             "[:^lower:]",
8287             "[:print:]",
8288             "[:^print:]",
8289             "[:punct:]",
8290             "[:^punct:]",
8291             "[:upper:]",
8292             "[:^upper:]",
8293             "[:xdigit:]",
8294             "[:^xdigit:]",
8295             "[:space:]",
8296             "[:^space:]",
8297             "[:blank:]",
8298             "[:^blank:]"
8299         };
8300
8301         if (flags & ANYOF_LOCALE)
8302             sv_catpvs(sv, "{loc}");
8303         if (flags & ANYOF_FOLD)
8304             sv_catpvs(sv, "{i}");
8305         Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
8306         if (flags & ANYOF_INVERT)
8307             sv_catpvs(sv, "^");
8308         for (i = 0; i <= 256; i++) {
8309             if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
8310                 if (rangestart == -1)
8311                     rangestart = i;
8312             } else if (rangestart != -1) {
8313                 if (i <= rangestart + 3)
8314                     for (; rangestart < i; rangestart++)
8315                         put_byte(sv, rangestart);
8316                 else {
8317                     put_byte(sv, rangestart);
8318                     sv_catpvs(sv, "-");
8319                     put_byte(sv, i - 1);
8320                 }
8321                 rangestart = -1;
8322             }
8323         }
8324
8325         if (o->flags & ANYOF_CLASS)
8326             for (i = 0; i < (int)(sizeof(anyofs)/sizeof(char*)); i++)
8327                 if (ANYOF_CLASS_TEST(o,i))
8328                     sv_catpv(sv, anyofs[i]);
8329
8330         if (flags & ANYOF_UNICODE)
8331             sv_catpvs(sv, "{unicode}");
8332         else if (flags & ANYOF_UNICODE_ALL)
8333             sv_catpvs(sv, "{unicode_all}");
8334
8335         {
8336             SV *lv;
8337             SV * const sw = regclass_swash(prog, o, FALSE, &lv, 0);
8338
8339             if (lv) {
8340                 if (sw) {
8341                     U8 s[UTF8_MAXBYTES_CASE+1];
8342
8343                     for (i = 0; i <= 256; i++) { /* just the first 256 */
8344                         uvchr_to_utf8(s, i);
8345
8346                         if (i < 256 && swash_fetch(sw, s, TRUE)) {
8347                             if (rangestart == -1)
8348                                 rangestart = i;
8349                         } else if (rangestart != -1) {
8350                             if (i <= rangestart + 3)
8351                                 for (; rangestart < i; rangestart++) {
8352                                     const U8 * const e = uvchr_to_utf8(s,rangestart);
8353                                     U8 *p;
8354                                     for(p = s; p < e; p++)
8355                                         put_byte(sv, *p);
8356                                 }
8357                             else {
8358                                 const U8 *e = uvchr_to_utf8(s,rangestart);
8359                                 U8 *p;
8360                                 for (p = s; p < e; p++)
8361                                     put_byte(sv, *p);
8362                                 sv_catpvs(sv, "-");
8363                                 e = uvchr_to_utf8(s, i-1);
8364                                 for (p = s; p < e; p++)
8365                                     put_byte(sv, *p);
8366                                 }
8367                                 rangestart = -1;
8368                             }
8369                         }
8370
8371                     sv_catpvs(sv, "..."); /* et cetera */
8372                 }
8373
8374                 {
8375                     char *s = savesvpv(lv);
8376                     char * const origs = s;
8377
8378                     while (*s && *s != '\n')
8379                         s++;
8380
8381                     if (*s == '\n') {
8382                         const char * const t = ++s;
8383
8384                         while (*s) {
8385                             if (*s == '\n')
8386                                 *s = ' ';
8387                             s++;
8388                         }
8389                         if (s[-1] == ' ')
8390                             s[-1] = 0;
8391
8392                         sv_catpv(sv, t);
8393                     }
8394
8395                     Safefree(origs);
8396                 }
8397             }
8398         }
8399
8400         Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
8401     }
8402     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
8403         Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
8404 #else
8405     PERL_UNUSED_CONTEXT;
8406     PERL_UNUSED_ARG(sv);
8407     PERL_UNUSED_ARG(o);
8408     PERL_UNUSED_ARG(prog);
8409 #endif  /* DEBUGGING */
8410 }
8411
8412 SV *
8413 Perl_re_intuit_string(pTHX_ regexp *prog)
8414 {                               /* Assume that RE_INTUIT is set */
8415     dVAR;
8416     GET_RE_DEBUG_FLAGS_DECL;
8417     PERL_UNUSED_CONTEXT;
8418
8419     DEBUG_COMPILE_r(
8420         {
8421             const char * const s = SvPV_nolen_const(prog->check_substr
8422                       ? prog->check_substr : prog->check_utf8);
8423
8424             if (!PL_colorset) reginitcolors();
8425             PerlIO_printf(Perl_debug_log,
8426                       "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
8427                       PL_colors[4],
8428                       prog->check_substr ? "" : "utf8 ",
8429                       PL_colors[5],PL_colors[0],
8430                       s,
8431                       PL_colors[1],
8432                       (strlen(s) > 60 ? "..." : ""));
8433         } );
8434
8435     return prog->check_substr ? prog->check_substr : prog->check_utf8;
8436 }
8437
8438 /*
8439    pregfree()
8440
8441    handles refcounting and freeing the perl core regexp structure. When
8442    it is necessary to actually free the structure the first thing it
8443    does is call the 'free' method of the regexp_engine associated to to
8444    the regexp, allowing the handling of the void *pprivate; member
8445    first. (This routine is not overridable by extensions, which is why
8446    the extensions free is called first.)
8447
8448    See regdupe and regdupe_internal if you change anything here.
8449 */
8450 #ifndef PERL_IN_XSUB_RE
8451 void
8452 Perl_pregfree(pTHX_ struct regexp *r)
8453 {
8454     dVAR;
8455     GET_RE_DEBUG_FLAGS_DECL;
8456
8457     if (!r || (--r->refcnt > 0))
8458         return;
8459
8460     CALLREGFREE_PVT(r); /* free the private data */
8461
8462     /* gcov results gave these as non-null 100% of the time, so there's no
8463        optimisation in checking them before calling Safefree  */
8464     Safefree(r->precomp);
8465     RX_MATCH_COPY_FREE(r);
8466 #ifdef PERL_OLD_COPY_ON_WRITE
8467     if (r->saved_copy)
8468         SvREFCNT_dec(r->saved_copy);
8469 #endif
8470     if (r->substrs) {
8471         if (r->anchored_substr)
8472             SvREFCNT_dec(r->anchored_substr);
8473         if (r->anchored_utf8)
8474             SvREFCNT_dec(r->anchored_utf8);
8475         if (r->float_substr)
8476             SvREFCNT_dec(r->float_substr);
8477         if (r->float_utf8)
8478             SvREFCNT_dec(r->float_utf8);
8479         Safefree(r->substrs);
8480     }
8481     if (r->paren_names)
8482             SvREFCNT_dec(r->paren_names);
8483
8484     Safefree(r->startp);
8485     Safefree(r->endp);
8486     Safefree(r);
8487 }
8488 #endif
8489
8490 /* regfree_internal()
8491
8492    Free the private data in a regexp. This is overloadable by
8493    extensions. Perl takes care of the regexp structure in pregfree(),
8494    this covers the *pprivate pointer which technically perldoesnt
8495    know about, however of course we have to handle the
8496    regexp_internal structure when no extension is in use.
8497
8498    Note this is called before freeing anything in the regexp
8499    structure.
8500  */
8501
8502 void
8503 Perl_regfree_internal(pTHX_ struct regexp *r)
8504 {
8505     dVAR;
8506     RXi_GET_DECL(r,ri);
8507     GET_RE_DEBUG_FLAGS_DECL;
8508
8509     DEBUG_COMPILE_r({
8510         if (!PL_colorset)
8511             reginitcolors();
8512         {
8513             SV *dsv= sv_newmortal();
8514             RE_PV_QUOTED_DECL(s, (r->extflags & RXf_UTF8),
8515                 dsv, r->precomp, r->prelen, 60);
8516             PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n",
8517                 PL_colors[4],PL_colors[5],s);
8518         }
8519     });
8520
8521     Safefree(ri->offsets);             /* 20010421 MJD */
8522     if (ri->data) {
8523         int n = ri->data->count;
8524         PAD* new_comppad = NULL;
8525         PAD* old_comppad;
8526         PADOFFSET refcnt;
8527
8528         while (--n >= 0) {
8529           /* If you add a ->what type here, update the comment in regcomp.h */
8530             switch (ri->data->what[n]) {
8531             case 's':
8532             case 'S':
8533             case 'u':
8534                 SvREFCNT_dec((SV*)ri->data->data[n]);
8535                 break;
8536             case 'f':
8537                 Safefree(ri->data->data[n]);
8538                 break;
8539             case 'p':
8540                 new_comppad = (AV*)ri->data->data[n];
8541                 break;
8542             case 'o':
8543                 if (new_comppad == NULL)
8544                     Perl_croak(aTHX_ "panic: pregfree comppad");
8545                 PAD_SAVE_LOCAL(old_comppad,
8546                     /* Watch out for global destruction's random ordering. */
8547                     (SvTYPE(new_comppad) == SVt_PVAV) ? new_comppad : NULL
8548                 );
8549                 OP_REFCNT_LOCK;
8550                 refcnt = OpREFCNT_dec((OP_4tree*)ri->data->data[n]);
8551                 OP_REFCNT_UNLOCK;
8552                 if (!refcnt)
8553                     op_free((OP_4tree*)ri->data->data[n]);
8554
8555                 PAD_RESTORE_LOCAL(old_comppad);
8556                 SvREFCNT_dec((SV*)new_comppad);
8557                 new_comppad = NULL;
8558                 break;
8559             case 'n':
8560                 break;
8561             case 'T':
8562                 { /* Aho Corasick add-on structure for a trie node.
8563                      Used in stclass optimization only */
8564                     U32 refcount;
8565                     reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
8566                     OP_REFCNT_LOCK;
8567                     refcount = --aho->refcount;
8568                     OP_REFCNT_UNLOCK;
8569                     if ( !refcount ) {
8570                         PerlMemShared_free(aho->states);
8571                         PerlMemShared_free(aho->fail);
8572                          /* do this last!!!! */
8573                         PerlMemShared_free(ri->data->data[n]);
8574                         PerlMemShared_free(ri->regstclass);
8575                     }
8576                 }
8577                 break;
8578             case 't':
8579                 {
8580                     /* trie structure. */
8581                     U32 refcount;
8582                     reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
8583                     OP_REFCNT_LOCK;
8584                     refcount = --trie->refcount;
8585                     OP_REFCNT_UNLOCK;
8586                     if ( !refcount ) {
8587                         PerlMemShared_free(trie->charmap);
8588                         PerlMemShared_free(trie->states);
8589                         PerlMemShared_free(trie->trans);
8590                         if (trie->bitmap)
8591                             PerlMemShared_free(trie->bitmap);
8592                         if (trie->wordlen)
8593                             PerlMemShared_free(trie->wordlen);
8594                         if (trie->jump)
8595                             PerlMemShared_free(trie->jump);
8596                         if (trie->nextword)
8597                             PerlMemShared_free(trie->nextword);
8598                         /* do this last!!!! */
8599                         PerlMemShared_free(ri->data->data[n]);
8600                     }
8601                 }
8602                 break;
8603             default:
8604                 Perl_croak(aTHX_ "panic: regfree data code '%c'", ri->data->what[n]);
8605             }
8606         }
8607         Safefree(ri->data->what);
8608         Safefree(ri->data);
8609     }
8610     if (ri->swap) {
8611         Safefree(ri->swap->startp);
8612         Safefree(ri->swap->endp);
8613         Safefree(ri->swap);
8614     }
8615     Safefree(ri);
8616 }
8617
8618 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
8619 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8620 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8621 #define SAVEPVN(p,n)    ((p) ? savepvn(p,n) : NULL)
8622
8623 /*
8624    regdupe - duplicate a regexp.
8625
8626    This routine is called by sv.c's re_dup and is expected to clone a
8627    given regexp structure. It is a no-op when not under USE_ITHREADS.
8628    (Originally this *was* re_dup() for change history see sv.c)
8629
8630    After all of the core data stored in struct regexp is duplicated
8631    the regexp_engine.dupe method is used to copy any private data
8632    stored in the *pprivate pointer. This allows extensions to handle
8633    any duplication it needs to do.
8634
8635    See pregfree() and regfree_internal() if you change anything here.
8636 */
8637 #if defined(USE_ITHREADS)
8638 #ifndef PERL_IN_XSUB_RE
8639 regexp *
8640 Perl_re_dup(pTHX_ const regexp *r, CLONE_PARAMS *param)
8641 {
8642     dVAR;
8643     regexp *ret;
8644     int i, npar;
8645     struct reg_substr_datum *s;
8646
8647     if (!r)
8648         return (REGEXP *)NULL;
8649
8650     if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
8651         return ret;
8652
8653
8654     npar = r->nparens+1;
8655     Newxz(ret, 1, regexp);
8656     Newx(ret->startp, npar, I32);
8657     Copy(r->startp, ret->startp, npar, I32);
8658     Newx(ret->endp, npar, I32);
8659     Copy(r->endp, ret->endp, npar, I32);
8660
8661     if (r->substrs) {
8662         Newx(ret->substrs, 1, struct reg_substr_data);
8663         for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
8664             s->min_offset = r->substrs->data[i].min_offset;
8665             s->max_offset = r->substrs->data[i].max_offset;
8666             s->end_shift  = r->substrs->data[i].end_shift;
8667             s->substr     = sv_dup_inc(r->substrs->data[i].substr, param);
8668             s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
8669         }
8670     } else
8671         ret->substrs = NULL;
8672
8673     ret->precomp        = SAVEPVN(r->precomp, r->prelen);
8674     ret->refcnt         = r->refcnt;
8675     ret->minlen         = r->minlen;
8676     ret->minlenret      = r->minlenret;
8677     ret->prelen         = r->prelen;
8678     ret->nparens        = r->nparens;
8679     ret->lastparen      = r->lastparen;
8680     ret->lastcloseparen = r->lastcloseparen;
8681     ret->intflags       = r->intflags;
8682     ret->extflags       = r->extflags;
8683
8684     ret->sublen         = r->sublen;
8685
8686     ret->engine         = r->engine;
8687
8688     ret->paren_names    = hv_dup_inc(r->paren_names, param);
8689
8690     if (RX_MATCH_COPIED(ret))
8691         ret->subbeg  = SAVEPVN(r->subbeg, r->sublen);
8692     else
8693         ret->subbeg = NULL;
8694 #ifdef PERL_OLD_COPY_ON_WRITE
8695     ret->saved_copy = NULL;
8696 #endif
8697
8698     ret->pprivate = r->pprivate;
8699     if (ret->pprivate)
8700         RXi_SET(ret,CALLREGDUPE_PVT(ret,param));
8701
8702     ptr_table_store(PL_ptr_table, r, ret);
8703     return ret;
8704 }
8705 #endif /* PERL_IN_XSUB_RE */
8706
8707 /*
8708    regdupe_internal()
8709
8710    This is the internal complement to regdupe() which is used to copy
8711    the structure pointed to by the *pprivate pointer in the regexp.
8712    This is the core version of the extension overridable cloning hook.
8713    The regexp structure being duplicated will be copied by perl prior
8714    to this and will be provided as the regexp *r argument, however
8715    with the /old/ structures pprivate pointer value. Thus this routine
8716    may override any copying normally done by perl.
8717
8718    It returns a pointer to the new regexp_internal structure.
8719 */
8720
8721 void *
8722 Perl_regdupe_internal(pTHX_ const regexp *r, CLONE_PARAMS *param)
8723 {
8724     dVAR;
8725     regexp_internal *reti;
8726     int len, npar;
8727     RXi_GET_DECL(r,ri);
8728
8729     npar = r->nparens+1;
8730     len = ri->offsets[0];
8731
8732     Newxc(reti, sizeof(regexp_internal) + (len+1)*sizeof(regnode), char, regexp_internal);
8733     Copy(ri->program, reti->program, len+1, regnode);
8734
8735     if(ri->swap) {
8736         Newx(reti->swap, 1, regexp_paren_ofs);
8737         /* no need to copy these */
8738         Newx(reti->swap->startp, npar, I32);
8739         Newx(reti->swap->endp, npar, I32);
8740     } else {
8741         reti->swap = NULL;
8742     }
8743
8744
8745     reti->regstclass = NULL;
8746     if (ri->data) {
8747         struct reg_data *d;
8748         const int count = ri->data->count;
8749         int i;
8750
8751         Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
8752                 char, struct reg_data);
8753         Newx(d->what, count, U8);
8754
8755         d->count = count;
8756         for (i = 0; i < count; i++) {
8757             d->what[i] = ri->data->what[i];
8758             switch (d->what[i]) {
8759                 /* legal options are one of: sSfpontTu
8760                    see also regcomp.h and pregfree() */
8761             case 's':
8762             case 'S':
8763             case 'p': /* actually an AV, but the dup function is identical.  */
8764             case 'u': /* actually an HV, but the dup function is identical.  */
8765                 d->data[i] = sv_dup_inc((SV *)ri->data->data[i], param);
8766                 break;
8767             case 'f':
8768                 /* This is cheating. */
8769                 Newx(d->data[i], 1, struct regnode_charclass_class);
8770                 StructCopy(ri->data->data[i], d->data[i],
8771                             struct regnode_charclass_class);
8772                 reti->regstclass = (regnode*)d->data[i];
8773                 break;
8774             case 'o':
8775                 /* Compiled op trees are readonly and in shared memory,
8776                    and can thus be shared without duplication. */
8777                 OP_REFCNT_LOCK;
8778                 d->data[i] = (void*)OpREFCNT_inc((OP*)ri->data->data[i]);
8779                 OP_REFCNT_UNLOCK;
8780                 break;
8781             case 'T':
8782                 /* Trie stclasses are readonly and can thus be shared
8783                  * without duplication. We free the stclass in pregfree
8784                  * when the corresponding reg_ac_data struct is freed.
8785                  */
8786                 reti->regstclass= ri->regstclass;
8787                 /* Fall through */
8788             case 't':
8789                 OP_REFCNT_LOCK;
8790                 ((reg_trie_data*)ri->data->data[i])->refcount++;
8791                 OP_REFCNT_UNLOCK;
8792                 /* Fall through */
8793             case 'n':
8794                 d->data[i] = ri->data->data[i];
8795                 break;
8796             default:
8797                 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", ri->data->what[i]);
8798             }
8799         }
8800
8801         reti->data = d;
8802     }
8803     else
8804         reti->data = NULL;
8805
8806     Newx(reti->offsets, 2*len+1, U32);
8807     Copy(ri->offsets, reti->offsets, 2*len+1, U32);
8808
8809     return (void*)reti;
8810 }
8811
8812 #endif    /* USE_ITHREADS */
8813
8814 /*
8815    reg_stringify()
8816
8817    converts a regexp embedded in a MAGIC struct to its stringified form,
8818    caching the converted form in the struct and returns the cached
8819    string.
8820
8821    If lp is nonnull then it is used to return the length of the
8822    resulting string
8823
8824    If flags is nonnull and the returned string contains UTF8 then
8825    (*flags & 1) will be true.
8826
8827    If haseval is nonnull then it is used to return whether the pattern
8828    contains evals.
8829
8830    Normally called via macro:
8831
8832         CALLREG_STRINGIFY(mg,&len,&utf8);
8833
8834    And internally with
8835
8836         CALLREG_AS_STR(mg,&lp,&flags,&haseval)
8837
8838    See sv_2pv_flags() in sv.c for an example of internal usage.
8839
8840  */
8841 #ifndef PERL_IN_XSUB_RE
8842 char *
8843 Perl_reg_stringify(pTHX_ MAGIC *mg, STRLEN *lp, U32 *flags, I32 *haseval ) {
8844     dVAR;
8845     const regexp * const re = (regexp *)mg->mg_obj;
8846
8847     if (!mg->mg_ptr) {
8848         const char *fptr = "msix";
8849         char reflags[6];
8850         char ch;
8851         int left = 0;
8852         int right = 4;
8853         bool need_newline = 0;
8854         U16 reganch = (U16)((re->extflags & RXf_PMf_COMPILETIME) >> 12);
8855
8856         while((ch = *fptr++)) {
8857             if(reganch & 1) {
8858                 reflags[left++] = ch;
8859             }
8860             else {
8861                 reflags[right--] = ch;
8862             }
8863             reganch >>= 1;
8864         }
8865         if(left != 4) {
8866             reflags[left] = '-';
8867             left = 5;
8868         }
8869
8870         mg->mg_len = re->prelen + 4 + left;
8871         /*
8872          * If /x was used, we have to worry about a regex ending with a
8873          * comment later being embedded within another regex. If so, we don't
8874          * want this regex's "commentization" to leak out to the right part of
8875          * the enclosing regex, we must cap it with a newline.
8876          *
8877          * So, if /x was used, we scan backwards from the end of the regex. If
8878          * we find a '#' before we find a newline, we need to add a newline
8879          * ourself. If we find a '\n' first (or if we don't find '#' or '\n'),
8880          * we don't need to add anything.  -jfriedl
8881          */
8882         if (PMf_EXTENDED & re->extflags) {
8883             const char *endptr = re->precomp + re->prelen;
8884             while (endptr >= re->precomp) {
8885                 const char c = *(endptr--);
8886                 if (c == '\n')
8887                     break; /* don't need another */
8888                 if (c == '#') {
8889                     /* we end while in a comment, so we need a newline */
8890                     mg->mg_len++; /* save space for it */
8891                     need_newline = 1; /* note to add it */
8892                     break;
8893                 }
8894             }
8895         }
8896
8897         Newx(mg->mg_ptr, mg->mg_len + 1 + left, char);
8898         mg->mg_ptr[0] = '(';
8899         mg->mg_ptr[1] = '?';
8900         Copy(reflags, mg->mg_ptr+2, left, char);
8901         *(mg->mg_ptr+left+2) = ':';
8902         Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
8903         if (need_newline)
8904             mg->mg_ptr[mg->mg_len - 2] = '\n';
8905         mg->mg_ptr[mg->mg_len - 1] = ')';
8906         mg->mg_ptr[mg->mg_len] = 0;
8907     }
8908     if (haseval)
8909         *haseval = re->seen_evals;
8910     if (flags)
8911         *flags = ((re->extflags & RXf_UTF8) ? 1 : 0);
8912
8913     if (lp)
8914         *lp = mg->mg_len;
8915     return mg->mg_ptr;
8916 }
8917
8918 /*
8919  - regnext - dig the "next" pointer out of a node
8920  */
8921 regnode *
8922 Perl_regnext(pTHX_ register regnode *p)
8923 {
8924     dVAR;
8925     register I32 offset;
8926
8927     if (!p)
8928         return(NULL);
8929
8930     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
8931     if (offset == 0)
8932         return(NULL);
8933
8934     return(p+offset);
8935 }
8936 #endif
8937
8938 STATIC void
8939 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
8940 {
8941     va_list args;
8942     STRLEN l1 = strlen(pat1);
8943     STRLEN l2 = strlen(pat2);
8944     char buf[512];
8945     SV *msv;
8946     const char *message;
8947
8948     if (l1 > 510)
8949         l1 = 510;
8950     if (l1 + l2 > 510)
8951         l2 = 510 - l1;
8952     Copy(pat1, buf, l1 , char);
8953     Copy(pat2, buf + l1, l2 , char);
8954     buf[l1 + l2] = '\n';
8955     buf[l1 + l2 + 1] = '\0';
8956 #ifdef I_STDARG
8957     /* ANSI variant takes additional second argument */
8958     va_start(args, pat2);
8959 #else
8960     va_start(args);
8961 #endif
8962     msv = vmess(buf, &args);
8963     va_end(args);
8964     message = SvPV_const(msv,l1);
8965     if (l1 > 512)
8966         l1 = 512;
8967     Copy(message, buf, l1 , char);
8968     buf[l1-1] = '\0';                   /* Overwrite \n */
8969     Perl_croak(aTHX_ "%s", buf);
8970 }
8971
8972 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
8973
8974 #ifndef PERL_IN_XSUB_RE
8975 void
8976 Perl_save_re_context(pTHX)
8977 {
8978     dVAR;
8979
8980     struct re_save_state *state;
8981
8982     SAVEVPTR(PL_curcop);
8983     SSGROW(SAVESTACK_ALLOC_FOR_RE_SAVE_STATE + 1);
8984
8985     state = (struct re_save_state *)(PL_savestack + PL_savestack_ix);
8986     PL_savestack_ix += SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
8987     SSPUSHINT(SAVEt_RE_STATE);
8988
8989     Copy(&PL_reg_state, state, 1, struct re_save_state);
8990
8991     PL_reg_start_tmp = 0;
8992     PL_reg_start_tmpl = 0;
8993     PL_reg_oldsaved = NULL;
8994     PL_reg_oldsavedlen = 0;
8995     PL_reg_maxiter = 0;
8996     PL_reg_leftiter = 0;
8997     PL_reg_poscache = NULL;
8998     PL_reg_poscache_size = 0;
8999 #ifdef PERL_OLD_COPY_ON_WRITE
9000     PL_nrs = NULL;
9001 #endif
9002
9003     /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
9004     if (PL_curpm) {
9005         const REGEXP * const rx = PM_GETRE(PL_curpm);
9006         if (rx) {
9007             U32 i;
9008             for (i = 1; i <= rx->nparens; i++) {
9009                 char digits[TYPE_CHARS(long)];
9010                 const STRLEN len = my_snprintf(digits, sizeof(digits), "%lu", (long)i);
9011                 GV *const *const gvp
9012                     = (GV**)hv_fetch(PL_defstash, digits, len, 0);
9013
9014                 if (gvp) {
9015                     GV * const gv = *gvp;
9016                     if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
9017                         save_scalar(gv);
9018                 }
9019             }
9020         }
9021     }
9022 }
9023 #endif
9024
9025 static void
9026 clear_re(pTHX_ void *r)
9027 {
9028     dVAR;
9029     ReREFCNT_dec((regexp *)r);
9030 }
9031
9032 #ifdef DEBUGGING
9033
9034 STATIC void
9035 S_put_byte(pTHX_ SV *sv, int c)
9036 {
9037     if (isCNTRL(c) || c == 255 || !isPRINT(c))
9038         Perl_sv_catpvf(aTHX_ sv, "\\%o", c);
9039     else if (c == '-' || c == ']' || c == '\\' || c == '^')
9040         Perl_sv_catpvf(aTHX_ sv, "\\%c", c);
9041     else
9042         Perl_sv_catpvf(aTHX_ sv, "%c", c);
9043 }
9044
9045
9046 #define CLEAR_OPTSTART \
9047     if (optstart) STMT_START { \
9048             DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%"IVdf" nodes)\n", (IV)(node - optstart))); \
9049             optstart=NULL; \
9050     } STMT_END
9051
9052 #define DUMPUNTIL(b,e) CLEAR_OPTSTART; node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
9053
9054 STATIC const regnode *
9055 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
9056             const regnode *last, const regnode *plast,
9057             SV* sv, I32 indent, U32 depth)
9058 {
9059     dVAR;
9060     register U8 op = PSEUDO;    /* Arbitrary non-END op. */
9061     register const regnode *next;
9062     const regnode *optstart= NULL;
9063
9064     RXi_GET_DECL(r,ri);
9065     GET_RE_DEBUG_FLAGS_DECL;
9066
9067 #ifdef DEBUG_DUMPUNTIL
9068     PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
9069         last ? last-start : 0,plast ? plast-start : 0);
9070 #endif
9071
9072     if (plast && plast < last)
9073         last= plast;
9074
9075     while (PL_regkind[op] != END && (!last || node < last)) {
9076         /* While that wasn't END last time... */
9077         NODE_ALIGN(node);
9078         op = OP(node);
9079         if (op == CLOSE || op == WHILEM)
9080             indent--;
9081         next = regnext((regnode *)node);
9082
9083         /* Where, what. */
9084         if (OP(node) == OPTIMIZED) {
9085             if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
9086                 optstart = node;
9087             else
9088                 goto after_print;
9089         } else
9090             CLEAR_OPTSTART;
9091
9092         regprop(r, sv, node);
9093         PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
9094                       (int)(2*indent + 1), "", SvPVX_const(sv));
9095
9096         if (OP(node) != OPTIMIZED) {
9097             if (next == NULL)           /* Next ptr. */
9098                 PerlIO_printf(Perl_debug_log, " (0)");
9099             else if (PL_regkind[(U8)op] == BRANCH && PL_regkind[OP(next)] != BRANCH )
9100                 PerlIO_printf(Perl_debug_log, " (FAIL)");
9101             else
9102                 PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start));
9103             (void)PerlIO_putc(Perl_debug_log, '\n');
9104         }
9105
9106       after_print:
9107         if (PL_regkind[(U8)op] == BRANCHJ) {
9108             assert(next);
9109             {
9110                 register const regnode *nnode = (OP(next) == LONGJMP
9111                                              ? regnext((regnode *)next)
9112                                              : next);
9113                 if (last && nnode > last)
9114                     nnode = last;
9115                 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
9116             }
9117         }
9118         else if (PL_regkind[(U8)op] == BRANCH) {
9119             assert(next);
9120             DUMPUNTIL(NEXTOPER(node), next);
9121         }
9122         else if ( PL_regkind[(U8)op]  == TRIE ) {
9123             const regnode *this_trie = node;
9124             const char op = OP(node);
9125             const U32 n = ARG(node);
9126             const reg_ac_data * const ac = op>=AHOCORASICK ?
9127                (reg_ac_data *)ri->data->data[n] :
9128                NULL;
9129             const reg_trie_data * const trie =
9130                 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
9131 #ifdef DEBUGGING
9132             AV *const trie_words = (AV *) ri->data->data[n + TRIE_WORDS_OFFSET];
9133 #endif
9134             const regnode *nextbranch= NULL;
9135             I32 word_idx;
9136             sv_setpvn(sv, "", 0);
9137             for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
9138                 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
9139
9140                 PerlIO_printf(Perl_debug_log, "%*s%s ",
9141                    (int)(2*(indent+3)), "",
9142                     elem_ptr ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60,
9143                             PL_colors[0], PL_colors[1],
9144                             (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) |
9145                             PERL_PV_PRETTY_ELIPSES    |
9146                             PERL_PV_PRETTY_LTGT
9147                             )
9148                             : "???"
9149                 );
9150                 if (trie->jump) {
9151                     U16 dist= trie->jump[word_idx+1];
9152                     PerlIO_printf(Perl_debug_log, "(%"UVuf")\n",
9153                                   (UV)((dist ? this_trie + dist : next) - start));
9154                     if (dist) {
9155                         if (!nextbranch)
9156                             nextbranch= this_trie + trie->jump[0];
9157                         DUMPUNTIL(this_trie + dist, nextbranch);
9158                     }
9159                     if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
9160                         nextbranch= regnext((regnode *)nextbranch);
9161                 } else {
9162                     PerlIO_printf(Perl_debug_log, "\n");
9163                 }
9164             }
9165             if (last && next > last)
9166                 node= last;
9167             else
9168                 node= next;
9169         }
9170         else if ( op == CURLY ) {   /* "next" might be very big: optimizer */
9171             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
9172                     NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
9173         }
9174         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
9175             assert(next);
9176             DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
9177         }
9178         else if ( op == PLUS || op == STAR) {
9179             DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
9180         }
9181         else if (op == ANYOF) {
9182             /* arglen 1 + class block */
9183             node += 1 + ((ANYOF_FLAGS(node) & ANYOF_LARGE)
9184                     ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
9185             node = NEXTOPER(node);
9186         }
9187         else if (PL_regkind[(U8)op] == EXACT) {
9188             /* Literal string, where present. */
9189             node += NODE_SZ_STR(node) - 1;
9190             node = NEXTOPER(node);
9191         }
9192         else {
9193             node = NEXTOPER(node);
9194             node += regarglen[(U8)op];
9195         }
9196         if (op == CURLYX || op == OPEN)
9197             indent++;
9198     }
9199     CLEAR_OPTSTART;
9200 #ifdef DEBUG_DUMPUNTIL
9201     PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent);
9202 #endif
9203     return node;
9204 }
9205
9206 #endif  /* DEBUGGING */
9207
9208 /*
9209  * Local variables:
9210  * c-indentation-style: bsd
9211  * c-basic-offset: 4
9212  * indent-tabs-mode: t
9213  * End:
9214  *
9215  * ex: set ts=8 sts=4 sw=4 noet:
9216  */