regcomp.c

   1 /*    regcomp.c
   2  */
   3
   4 /*
   5  * "A fair jaw-cracker dwarf-language must be."  --Samwise Gamgee
   6  */
   7
   8 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
   9  * confused with the original package (see point 3 below).  Thanks, Henry!
  10  */
  11
  12 /* Additional note: this code is very heavily munged from Henry's version
  13  * in places.  In some spots I've traded clarity for efficiency, so don't
  14  * blame Henry for some of the lack of readability.
  15  */
  16
  17 /* The names of the functions have been changed from regcomp and
  18  * regexec to  pregcomp and pregexec in order to avoid conflicts
  19  * with the POSIX routines of the same names.
  20 */
  21
  22 #ifdef PERL_EXT_RE_BUILD
  23 /* need to replace pregcomp et al, so enable that */
  24 #  ifndef PERL_IN_XSUB_RE
  25 #    define PERL_IN_XSUB_RE
  26 #  endif
  27 /* need access to debugger hooks */
  28 #  if defined(PERL_EXT_RE_DEBUG) && !defined(DEBUGGING)
  29 #    define DEBUGGING
  30 #  endif
  31 #endif
  32
  33 #ifdef PERL_IN_XSUB_RE
  34 /* We *really* need to overwrite these symbols: */
  35 #  define Perl_pregcomp my_regcomp
  36 #  define Perl_regdump my_regdump
  37 #  define Perl_regprop my_regprop
  38 #  define Perl_pregfree my_regfree
  39 #  define Perl_re_intuit_string my_re_intuit_string
  40 /* *These* symbols are masked to allow static link. */
  41 #  define Perl_regnext my_regnext
  42 #  define Perl_save_re_context my_save_re_context
  43 #  define Perl_reginitcolors my_reginitcolors
  44 #endif
  45
  46 /*SUPPRESS 112*/
  47 /*
  48  * pregcomp and pregexec -- regsub and regerror are not used in perl
  49  *
  50  *      Copyright (c) 1986 by University of Toronto.
  51  *      Written by Henry Spencer.  Not derived from licensed software.
  52  *
  53  *      Permission is granted to anyone to use this software for any
  54  *      purpose on any computer system, and to redistribute it freely,
  55  *      subject to the following restrictions:
  56  *
  57  *      1. The author is not responsible for the consequences of use of
  58  *              this software, no matter how awful, even if they arise
  59  *              from defects in it.
  60  *
  61  *      2. The origin of this software must not be misrepresented, either
  62  *              by explicit claim or by omission.
  63  *
  64  *      3. Altered versions must be plainly marked as such, and must not
  65  *              be misrepresented as being the original software.
  66  *
  67  *
  68  ****    Alterations to Henry's code are...
  69  ****
  70  ****    Copyright (c) 1991-1999, Larry Wall
  71  ****
  72  ****    You may distribute under the terms of either the GNU General Public
  73  ****    License or the Artistic License, as specified in the README file.
  74
  75  *
  76  * Beware that some of this code is subtly aware of the way operator
  77  * precedence is structured in regular expressions.  Serious changes in
  78  * regular-expression syntax might require a total rethink.
  79  */
  80 #include "EXTERN.h"
  81 #define PERL_IN_REGCOMP_C
  82 #include "perl.h"
  83
  84 #ifndef PERL_IN_XSUB_RE
  85 #  include "INTERN.h"
  86 #endif
  87
  88 #define REG_COMP_C
  89 #include "regcomp.h"
  90
  91 #ifdef op
  92 #undef op
  93 #endif /* op */
  94
  95 #ifdef MSDOS
  96 # if defined(BUGGY_MSC6)
  97  /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
  98  # pragma optimize("a",off)
  99  /* But MSC 6.00A is happy with 'w', for aliases only across function calls*/
 100  # pragma optimize("w",on )
 101 # endif /* BUGGY_MSC6 */
 102 #endif /* MSDOS */
 103
 104 #ifndef STATIC
 105 #define STATIC  static
 106 #endif
 107
 108 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
 109 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
 110         ((*s) == '{' && regcurly(s)))
 111 #ifdef atarist
 112 #define PERL_META       "^$.[()|?+*\\"
 113 #else
 114 #define META    "^$.[()|?+*\\"
 115 #endif
 116
 117 #ifdef SPSTART
 118 #undef SPSTART          /* dratted cpp namespace... */
 119 #endif
 120 /*
 121  * Flags to be passed up and down.
 122  */
 123 #define WORST           0       /* Worst case. */
 124 #define HASWIDTH        0x1     /* Known to match non-null strings. */
 125 #define SIMPLE          0x2     /* Simple enough to be STAR/PLUS operand. */
 126 #define SPSTART         0x4     /* Starts with * or +. */
 127 #define TRYAGAIN        0x8     /* Weeded out a declaration. */
 128
 129 /*
 130  * Forward declarations for pregcomp()'s friends.
 131  */
 132
 133 static scan_data_t zero_scan_data = { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
 134                                       0, 0, 0 };
 135
 136 #define SF_BEFORE_EOL           (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
 137 #define SF_BEFORE_SEOL          0x1
 138 #define SF_BEFORE_MEOL          0x2
 139 #define SF_FIX_BEFORE_EOL       (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
 140 #define SF_FL_BEFORE_EOL        (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
 141
 142 #ifdef NO_UNARY_PLUS
 143 #  define SF_FIX_SHIFT_EOL      (0+2)
 144 #  define SF_FL_SHIFT_EOL               (0+4)
 145 #else
 146 #  define SF_FIX_SHIFT_EOL      (+2)
 147 #  define SF_FL_SHIFT_EOL               (+4)
 148 #endif
 149
 150 #define SF_FIX_BEFORE_SEOL      (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
 151 #define SF_FIX_BEFORE_MEOL      (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
 152
 153 #define SF_FL_BEFORE_SEOL       (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
 154 #define SF_FL_BEFORE_MEOL       (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
 155 #define SF_IS_INF               0x40
 156 #define SF_HAS_PAR              0x80
 157 #define SF_IN_PAR               0x100
 158 #define SF_HAS_EVAL             0x200
 159 #define SCF_DO_SUBSTR           0x400
 160
 161 #define RF_utf8         8
 162 #define UTF (PL_reg_flags & RF_utf8)
 163 #define LOC (PL_regflags & PMf_LOCALE)
 164 #define FOLD (PL_regflags & PMf_FOLD)
 165
 166 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
 167 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
 168
 169 STATIC void
 170 S_clear_re(pTHX_ void *r)
 171 {
 172     ReREFCNT_dec((regexp *)r);
 173 }
 174
 175 STATIC void
 176 S_scan_commit(pTHX_ scan_data_t *data)
 177 {
 178     dTHR;
 179     STRLEN l = CHR_SVLEN(data->last_found);
 180     STRLEN old_l = CHR_SVLEN(*data->longest);
 181
 182     if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
 183         sv_setsv(*data->longest, data->last_found);
 184         if (*data->longest == data->longest_fixed) {
 185             data->offset_fixed = l ? data->last_start_min : data->pos_min;
 186             if (data->flags & SF_BEFORE_EOL)
 187                 data->flags
 188                     |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
 189             else
 190                 data->flags &= ~SF_FIX_BEFORE_EOL;
 191         }
 192         else {
 193             data->offset_float_min = l ? data->last_start_min : data->pos_min;
 194             data->offset_float_max = (l
 195                                       ? data->last_start_max
 196                                       : data->pos_min + data->pos_delta);
 197             if (data->flags & SF_BEFORE_EOL)
 198                 data->flags
 199                     |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
 200             else
 201                 data->flags &= ~SF_FL_BEFORE_EOL;
 202         }
 203     }
 204     SvCUR_set(data->last_found, 0);
 205     data->last_end = -1;
 206     data->flags &= ~SF_BEFORE_EOL;
 207 }
 208
 209 /* Stops at toplevel WHILEM as well as at `last'. At end *scanp is set
 210    to the position after last scanned or to NULL. */
 211
 212 STATIC I32
 213 S_study_chunk(pTHX_ regnode **scanp, I32 *deltap, regnode *last, scan_data_t *data, U32 flags)
 214                         /* scanp: Start here (read-write). */
 215                         /* deltap: Write maxlen-minlen here. */
 216                         /* last: Stop before this one. */
 217 {
 218     dTHR;
 219     I32 min = 0, pars = 0, code;
 220     regnode *scan = *scanp, *next;
 221     I32 delta = 0;
 222     int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
 223     int is_inf_internal = 0;            /* The studied chunk is infinite */
 224     I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
 225     scan_data_t data_fake;
 226
 227     while (scan && OP(scan) != END && scan < last) {
 228         /* Peephole optimizer: */
 229
 230         if (PL_regkind[(U8)OP(scan)] == EXACT) {
 231             regnode *n = regnext(scan);
 232             U32 stringok = 1;
 233 #ifdef DEBUGGING
 234             regnode *stop = scan;
 235 #endif
 236
 237             next = scan + (*OPERAND(scan) + 2 - 1)/sizeof(regnode) + 2;
 238             /* Skip NOTHING, merge EXACT*. */
 239             while (n &&
 240                    ( PL_regkind[(U8)OP(n)] == NOTHING ||
 241                      (stringok && (OP(n) == OP(scan))))
 242                    && NEXT_OFF(n)
 243                    && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX) {
 244                 if (OP(n) == TAIL || n > next)
 245                     stringok = 0;
 246                 if (PL_regkind[(U8)OP(n)] == NOTHING) {
 247                     NEXT_OFF(scan) += NEXT_OFF(n);
 248                     next = n + NODE_STEP_REGNODE;
 249 #ifdef DEBUGGING
 250                     if (stringok)
 251                         stop = n;
 252 #endif
 253                     n = regnext(n);
 254                 }
 255                 else {
 256                     int oldl = *OPERAND(scan);
 257                     regnode *nnext = regnext(n);
 258
 259                     if (oldl + *OPERAND(n) > U8_MAX)
 260                         break;
 261                     NEXT_OFF(scan) += NEXT_OFF(n);
 262                     *OPERAND(scan) += *OPERAND(n);
 263                     next = n + (*OPERAND(n) + 2 - 1)/sizeof(regnode) + 2;
 264                     /* Now we can overwrite *n : */
 265                     Move(OPERAND(n) + 1, OPERAND(scan) + oldl + 1,
 266                          *OPERAND(n) + 1, char);
 267 #ifdef DEBUGGING
 268                     if (stringok)
 269                         stop = next - 1;
 270 #endif
 271                     n = nnext;
 272                 }
 273             }
 274 #ifdef DEBUGGING
 275             /* Allow dumping */
 276             n = scan + (*OPERAND(scan) + 2 - 1)/sizeof(regnode) + 2;
 277             while (n <= stop) {
 278                 /* Purify reports a benign UMR here sometimes, because we
 279                  * don't initialize the OP() slot of a node when that node
 280                  * is occupied by just the trailing null of the string in
 281                  * an EXACT node */
 282                 if (PL_regkind[(U8)OP(n)] != NOTHING || OP(n) == NOTHING) {
 283                     OP(n) = OPTIMIZED;
 284                     NEXT_OFF(n) = 0;
 285                 }
 286                 n++;
 287             }
 288 #endif
 289
 290         }
 291         if (OP(scan) != CURLYX) {
 292             int max = (reg_off_by_arg[OP(scan)]
 293                        ? I32_MAX
 294                        /* I32 may be smaller than U16 on CRAYs! */
 295                        : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
 296             int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
 297             int noff;
 298             regnode *n = scan;
 299
 300             /* Skip NOTHING and LONGJMP. */
 301             while ((n = regnext(n))
 302                    && ((PL_regkind[(U8)OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
 303                        || ((OP(n) == LONGJMP) && (noff = ARG(n))))
 304                    && off + noff < max)
 305                 off += noff;
 306             if (reg_off_by_arg[OP(scan)])
 307                 ARG(scan) = off;
 308             else
 309                 NEXT_OFF(scan) = off;
 310         }
 311         if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
 312                    || OP(scan) == IFTHEN || OP(scan) == SUSPEND) {
 313             next = regnext(scan);
 314             code = OP(scan);
 315
 316             if (OP(next) == code || code == IFTHEN || code == SUSPEND) {
 317                 I32 max1 = 0, min1 = I32_MAX, num = 0;
 318
 319                 if (flags & SCF_DO_SUBSTR)
 320                     scan_commit(data);
 321                 while (OP(scan) == code) {
 322                     I32 deltanext, minnext;
 323
 324                     num++;
 325                     data_fake.flags = 0;
 326                     next = regnext(scan);
 327                     scan = NEXTOPER(scan);
 328                     if (code != BRANCH)
 329                         scan = NEXTOPER(scan);
 330                     /* We suppose the run is continuous, last=next...*/
 331                     minnext = study_chunk(&scan, &deltanext, next,
 332                                           &data_fake, 0);
 333                     if (min1 > minnext)
 334                         min1 = minnext;
 335                     if (max1 < minnext + deltanext)
 336                         max1 = minnext + deltanext;
 337                     if (deltanext == I32_MAX)
 338                         is_inf = is_inf_internal = 1;
 339                     scan = next;
 340                     if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
 341                         pars++;
 342                     if (data && (data_fake.flags & SF_HAS_EVAL))
 343                         data->flags |= SF_HAS_EVAL;
 344                     if (code == SUSPEND)
 345                         break;
 346                 }
 347                 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
 348                     min1 = 0;
 349                 if (flags & SCF_DO_SUBSTR) {
 350                     data->pos_min += min1;
 351                     data->pos_delta += max1 - min1;
 352                     if (max1 != min1 || is_inf)
 353                         data->longest = &(data->longest_float);
 354                 }
 355                 min += min1;
 356                 delta += max1 - min1;
 357             }
 358             else if (code == BRANCHJ)   /* single branch is optimized. */
 359                 scan = NEXTOPER(NEXTOPER(scan));
 360             else                        /* single branch is optimized. */
 361                 scan = NEXTOPER(scan);
 362             continue;
 363         }
 364         else if (OP(scan) == EXACT) {
 365             I32 l = *OPERAND(scan);
 366             if (UTF) {
 367                 unsigned char *s = (unsigned char *)(OPERAND(scan)+1);
 368                 unsigned char *e = s + l;
 369                 I32 newl = 0;
 370                 while (s < e) {
 371                     newl++;
 372                     s += UTF8SKIP(s);
 373                 }
 374                 l = newl;
 375             }
 376             min += l;
 377             if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
 378                 /* The code below prefers earlier match for fixed
 379                    offset, later match for variable offset.  */
 380                 if (data->last_end == -1) { /* Update the start info. */
 381                     data->last_start_min = data->pos_min;
 382                     data->last_start_max = is_inf
 383                         ? I32_MAX : data->pos_min + data->pos_delta;
 384                 }
 385                 sv_catpvn(data->last_found, (char *)(OPERAND(scan)+1), *OPERAND(scan));
 386                 data->last_end = data->pos_min + l;
 387                 data->pos_min += l; /* As in the first entry. */
 388                 data->flags &= ~SF_BEFORE_EOL;
 389             }
 390         }
 391         else if (PL_regkind[(U8)OP(scan)] == EXACT) {
 392             I32 l = *OPERAND(scan);
 393             if (flags & SCF_DO_SUBSTR)
 394                 scan_commit(data);
 395             if (UTF) {
 396                 unsigned char *s = (unsigned char *)(OPERAND(scan)+1);
 397                 unsigned char *e = s + l;
 398                 I32 newl = 0;
 399                 while (s < e) {
 400                     newl++;
 401                     s += UTF8SKIP(s);
 402                 }
 403                 l = newl;
 404             }
 405             min += l;
 406             if (data && (flags & SCF_DO_SUBSTR))
 407                 data->pos_min += l;
 408         }
 409         else if (strchr(PL_varies,OP(scan))) {
 410             I32 mincount, maxcount, minnext, deltanext, pos_before, fl;
 411             regnode *oscan = scan;
 412
 413             switch (PL_regkind[(U8)OP(scan)]) {
 414             case WHILEM:
 415                 scan = NEXTOPER(scan);
 416                 goto finish;
 417             case PLUS:
 418                 if (flags & SCF_DO_SUBSTR) {
 419                     next = NEXTOPER(scan);
 420                     if (OP(next) == EXACT) {
 421                         mincount = 1;
 422                         maxcount = REG_INFTY;
 423                         next = regnext(scan);
 424                         scan = NEXTOPER(scan);
 425                         goto do_curly;
 426                     }
 427                 }
 428                 if (flags & SCF_DO_SUBSTR)
 429                     data->pos_min++;
 430                 min++;
 431                 /* Fall through. */
 432             case STAR:
 433                 is_inf = is_inf_internal = 1;
 434                 scan = regnext(scan);
 435                 if (flags & SCF_DO_SUBSTR) {
 436                     scan_commit(data);
 437                     data->longest = &(data->longest_float);
 438                 }
 439                 goto optimize_curly_tail;
 440             case CURLY:
 441                 mincount = ARG1(scan);
 442                 maxcount = ARG2(scan);
 443                 next = regnext(scan);
 444                 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
 445               do_curly:
 446                 if (flags & SCF_DO_SUBSTR) {
 447                     if (mincount == 0) scan_commit(data);
 448                     pos_before = data->pos_min;
 449                 }
 450                 if (data) {
 451                     fl = data->flags;
 452                     data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
 453                     if (is_inf)
 454                         data->flags |= SF_IS_INF;
 455                 }
 456                 /* This will finish on WHILEM, setting scan, or on NULL: */
 457                 minnext = study_chunk(&scan, &deltanext, last, data,
 458                                       mincount == 0
 459                                         ? (flags & ~SCF_DO_SUBSTR) : flags);
 460                 if (!scan)              /* It was not CURLYX, but CURLY. */
 461                     scan = next;
 462                 if (ckWARN(WARN_UNSAFE) && (minnext + deltanext == 0)
 463                     && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
 464                     && maxcount <= REG_INFTY/3) /* Complement check for big count */
 465                     Perl_warner(aTHX_ WARN_UNSAFE, "Strange *+?{} on zero-length expression");
 466                 min += minnext * mincount;
 467                 is_inf_internal |= (maxcount == REG_INFTY
 468                                     && (minnext + deltanext) > 0
 469                                    || deltanext == I32_MAX);
 470                 is_inf |= is_inf_internal;
 471                 delta += (minnext + deltanext) * maxcount - minnext * mincount;
 472
 473                 /* Try powerful optimization CURLYX => CURLYN. */
 474                 if (  OP(oscan) == CURLYX && data
 475                       && data->flags & SF_IN_PAR
 476                       && !(data->flags & SF_HAS_EVAL)
 477                       && !deltanext && minnext == 1 ) {
 478                     /* Try to optimize to CURLYN.  */
 479                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
 480                     regnode *nxt1 = nxt, *nxt2;
 481
 482                     /* Skip open. */
 483                     nxt = regnext(nxt);
 484                     if (!strchr(PL_simple,OP(nxt))
 485                         && !(PL_regkind[(U8)OP(nxt)] == EXACT
 486                              && *OPERAND(nxt) == 1))
 487                         goto nogo;
 488                     nxt2 = nxt;
 489                     nxt = regnext(nxt);
 490                     if (OP(nxt) != CLOSE)
 491                         goto nogo;
 492                     /* Now we know that nxt2 is the only contents: */
 493                     oscan->flags = ARG(nxt);
 494                     OP(oscan) = CURLYN;
 495                     OP(nxt1) = NOTHING; /* was OPEN. */
 496 #ifdef DEBUGGING
 497                     OP(nxt1 + 1) = OPTIMIZED; /* was count. */
 498                     NEXT_OFF(nxt1+ 1) = 0; /* just for consistancy. */
 499                     NEXT_OFF(nxt2) = 0; /* just for consistancy with CURLY. */
 500                     OP(nxt) = OPTIMIZED;        /* was CLOSE. */
 501                     OP(nxt + 1) = OPTIMIZED; /* was count. */
 502                     NEXT_OFF(nxt+ 1) = 0; /* just for consistancy. */
 503 #endif
 504                 }
 505               nogo:
 506
 507                 /* Try optimization CURLYX => CURLYM. */
 508                 if (  OP(oscan) == CURLYX && data
 509                       && !(data->flags & SF_HAS_PAR)
 510                       && !(data->flags & SF_HAS_EVAL)
 511                       && !deltanext  ) {
 512                     /* XXXX How to optimize if data == 0? */
 513                     /* Optimize to a simpler form.  */
 514                     regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
 515                     regnode *nxt2;
 516
 517                     OP(oscan) = CURLYM;
 518                     while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
 519                             && (OP(nxt2) != WHILEM))
 520                         nxt = nxt2;
 521                     OP(nxt2)  = SUCCEED; /* Whas WHILEM */
 522                     /* Need to optimize away parenths. */
 523                     if (data->flags & SF_IN_PAR) {
 524                         /* Set the parenth number.  */
 525                         regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
 526
 527                         if (OP(nxt) != CLOSE)
 528                             FAIL("panic opt close");
 529                         oscan->flags = ARG(nxt);
 530                         OP(nxt1) = OPTIMIZED;   /* was OPEN. */
 531                         OP(nxt) = OPTIMIZED;    /* was CLOSE. */
 532 #ifdef DEBUGGING
 533                         OP(nxt1 + 1) = OPTIMIZED; /* was count. */
 534                         OP(nxt + 1) = OPTIMIZED; /* was count. */
 535                         NEXT_OFF(nxt1 + 1) = 0; /* just for consistancy. */
 536                         NEXT_OFF(nxt + 1) = 0; /* just for consistancy. */
 537 #endif
 538 #if 0
 539                         while ( nxt1 && (OP(nxt1) != WHILEM)) {
 540                             regnode *nnxt = regnext(nxt1);
 541
 542                             if (nnxt == nxt) {
 543                                 if (reg_off_by_arg[OP(nxt1)])
 544                                     ARG_SET(nxt1, nxt2 - nxt1);
 545                                 else if (nxt2 - nxt1 < U16_MAX)
 546                                     NEXT_OFF(nxt1) = nxt2 - nxt1;
 547                                 else
 548                                     OP(nxt) = NOTHING;  /* Cannot beautify */
 549                             }
 550                             nxt1 = nnxt;
 551                         }
 552 #endif
 553                         /* Optimize again: */
 554                         study_chunk(&nxt1, &deltanext, nxt, NULL, 0);
 555                     }
 556                     else
 557                         oscan->flags = 0;
 558                 }
 559                 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
 560                     pars++;
 561                 if (flags & SCF_DO_SUBSTR) {
 562                     SV *last_str = Nullsv;
 563                     int counted = mincount != 0;
 564
 565                     if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
 566                         I32 b = pos_before >= data->last_start_min
 567                             ? pos_before : data->last_start_min;
 568                         STRLEN l;
 569                         char *s = SvPV(data->last_found, l);
 570                         I32 old = b - data->last_start_min;
 571
 572                         if (UTF)
 573                             old = utf8_hop((U8*)s, old) - (U8*)s;
 574
 575                         l -= old;
 576                         /* Get the added string: */
 577                         last_str = newSVpvn(s  + old, l);
 578                         if (deltanext == 0 && pos_before == b) {
 579                             /* What was added is a constant string */
 580                             if (mincount > 1) {
 581                                 SvGROW(last_str, (mincount * l) + 1);
 582                                 repeatcpy(SvPVX(last_str) + l,
 583                                           SvPVX(last_str), l, mincount - 1);
 584                                 SvCUR(last_str) *= mincount;
 585                                 /* Add additional parts. */
 586                                 SvCUR_set(data->last_found,
 587                                           SvCUR(data->last_found) - l);
 588                                 sv_catsv(data->last_found, last_str);
 589                                 data->last_end += l * (mincount - 1);
 590                             }
 591                         }
 592                     }
 593                     /* It is counted once already... */
 594                     data->pos_min += minnext * (mincount - counted);
 595                     data->pos_delta += - counted * deltanext +
 596                         (minnext + deltanext) * maxcount - minnext * mincount;
 597                     if (mincount != maxcount) {
 598                         scan_commit(data);
 599                         if (mincount && last_str) {
 600                             sv_setsv(data->last_found, last_str);
 601                             data->last_end = data->pos_min;
 602                             data->last_start_min =
 603                                 data->pos_min - CHR_SVLEN(last_str);
 604                             data->last_start_max = is_inf
 605                                 ? I32_MAX
 606                                 : data->pos_min + data->pos_delta
 607                                 - CHR_SVLEN(last_str);
 608                         }
 609                         data->longest = &(data->longest_float);
 610                     }
 611                     SvREFCNT_dec(last_str);
 612                 }
 613                 if (data && (fl & SF_HAS_EVAL))
 614                     data->flags |= SF_HAS_EVAL;
 615               optimize_curly_tail:
 616                 if (OP(oscan) != CURLYX) {
 617                     while (PL_regkind[(U8)OP(next = regnext(oscan))] == NOTHING
 618                            && NEXT_OFF(next))
 619                         NEXT_OFF(oscan) += NEXT_OFF(next);
 620                 }
 621                 continue;
 622             default:                    /* REF only? */
 623                 if (flags & SCF_DO_SUBSTR) {
 624                     scan_commit(data);
 625                     data->longest = &(data->longest_float);
 626                 }
 627                 is_inf = is_inf_internal = 1;
 628                 break;
 629             }
 630         }
 631         else if (strchr(PL_simple,OP(scan)) || PL_regkind[(U8)OP(scan)] == ANYUTF8) {
 632             if (flags & SCF_DO_SUBSTR) {
 633                 scan_commit(data);
 634                 data->pos_min++;
 635             }
 636             min++;
 637         }
 638         else if (PL_regkind[(U8)OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
 639             data->flags |= (OP(scan) == MEOL
 640                             ? SF_BEFORE_MEOL
 641                             : SF_BEFORE_SEOL);
 642         }
 643         else if (PL_regkind[(U8)OP(scan)] == BRANCHJ
 644                    && (scan->flags || data)
 645                    && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
 646             I32 deltanext, minnext;
 647             regnode *nscan;
 648
 649             data_fake.flags = 0;
 650             next = regnext(scan);
 651             nscan = NEXTOPER(NEXTOPER(scan));
 652             minnext = study_chunk(&nscan, &deltanext, last, &data_fake, 0);
 653             if (scan->flags) {
 654                 if (deltanext) {
 655                     FAIL("variable length lookbehind not implemented");
 656                 }
 657                 else if (minnext > U8_MAX) {
 658                     FAIL2("lookbehind longer than %d not implemented", U8_MAX);
 659                 }
 660                 scan->flags = minnext;
 661             }
 662             if (data && data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
 663                 pars++;
 664             if (data && (data_fake.flags & SF_HAS_EVAL))
 665                 data->flags |= SF_HAS_EVAL;
 666         }
 667         else if (OP(scan) == OPEN) {
 668             pars++;
 669         }
 670         else if (OP(scan) == CLOSE && ARG(scan) == is_par) {
 671             next = regnext(scan);
 672
 673             if ( next && (OP(next) != WHILEM) && next < last)
 674                 is_par = 0;             /* Disable optimization */
 675         }
 676         else if (OP(scan) == EVAL) {
 677                 if (data)
 678                     data->flags |= SF_HAS_EVAL;
 679         }
 680         else if (OP(scan) == LOGICAL && scan->flags == 2) { /* Embedded */
 681                 if (flags & SCF_DO_SUBSTR) {
 682                     scan_commit(data);
 683                     data->longest = &(data->longest_float);
 684                 }
 685                 is_inf = is_inf_internal = 1;
 686         }
 687         /* Else: zero-length, ignore. */
 688         scan = regnext(scan);
 689     }
 690
 691   finish:
 692     *scanp = scan;
 693     *deltap = is_inf_internal ? I32_MAX : delta;
 694     if (flags & SCF_DO_SUBSTR && is_inf)
 695         data->pos_delta = I32_MAX - data->pos_min;
 696     if (is_par > U8_MAX)
 697         is_par = 0;
 698     if (is_par && pars==1 && data) {
 699         data->flags |= SF_IN_PAR;
 700         data->flags &= ~SF_HAS_PAR;
 701     }
 702     else if (pars && data) {
 703         data->flags |= SF_HAS_PAR;
 704         data->flags &= ~SF_IN_PAR;
 705     }
 706     return min;
 707 }
 708
 709 STATIC I32
 710 S_add_data(pTHX_ I32 n, char *s)
 711 {
 712     dTHR;
 713     if (PL_regcomp_rx->data) {
 714         Renewc(PL_regcomp_rx->data,
 715                sizeof(*PL_regcomp_rx->data) + sizeof(void*) * (PL_regcomp_rx->data->count + n - 1),
 716                char, struct reg_data);
 717         Renew(PL_regcomp_rx->data->what, PL_regcomp_rx->data->count + n, U8);
 718         PL_regcomp_rx->data->count += n;
 719     }
 720     else {
 721         Newc(1207, PL_regcomp_rx->data, sizeof(*PL_regcomp_rx->data) + sizeof(void*) * (n - 1),
 722              char, struct reg_data);
 723         New(1208, PL_regcomp_rx->data->what, n, U8);
 724         PL_regcomp_rx->data->count = n;
 725     }
 726     Copy(s, PL_regcomp_rx->data->what + PL_regcomp_rx->data->count - n, n, U8);
 727     return PL_regcomp_rx->data->count - n;
 728 }
 729
 730 void
 731 Perl_reginitcolors(pTHX)
 732 {
 733     dTHR;
 734     int i = 0;
 735     char *s = PerlEnv_getenv("PERL_RE_COLORS");
 736
 737     if (s) {
 738         PL_colors[0] = s = savepv(s);
 739         while (++i < 6) {
 740             s = strchr(s, '\t');
 741             if (s) {
 742                 *s = '\0';
 743                 PL_colors[i] = ++s;
 744             }
 745             else
 746                 PL_colors[i] = s = "";
 747         }
 748     } else {
 749         while (i < 6)
 750             PL_colors[i++] = "";
 751     }
 752     PL_colorset = 1;
 753 }
 754
 755 /*
 756  - pregcomp - compile a regular expression into internal code
 757  *
 758  * We can't allocate space until we know how big the compiled form will be,
 759  * but we can't compile it (and thus know how big it is) until we've got a
 760  * place to put the code.  So we cheat:  we compile it twice, once with code
 761  * generation turned off and size counting turned on, and once "for real".
 762  * This also means that we don't allocate space until we are sure that the
 763  * thing really will compile successfully, and we never have to move the
 764  * code and thus invalidate pointers into it.  (Note that it has to be in
 765  * one piece because free() must be able to free it all.) [NB: not true in perl]
 766  *
 767  * Beware that the optimization-preparation code in here knows about some
 768  * of the structure of the compiled regexp.  [I'll say.]
 769  */
 770 regexp *
 771 Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
 772 {
 773     dTHR;
 774     register regexp *r;
 775     regnode *scan;
 776     SV **longest;
 777     SV *longest_fixed;
 778     SV *longest_float;
 779     regnode *first;
 780     I32 flags;
 781     I32 minlen = 0;
 782     I32 sawplus = 0;
 783     I32 sawopen = 0;
 784
 785     if (exp == NULL)
 786         FAIL("NULL regexp argument");
 787
 788     if (PL_curcop == &PL_compiling ? (PL_hints & HINT_UTF8) : IN_UTF8)
 789         PL_reg_flags |= RF_utf8;
 790     else
 791         PL_reg_flags = 0;
 792
 793     PL_regprecomp = savepvn(exp, xend - exp);
 794     DEBUG_r(if (!PL_colorset) reginitcolors());
 795     DEBUG_r(PerlIO_printf(Perl_debug_log, "%sCompiling%s RE `%s%*s%s'\n",
 796                       PL_colors[4],PL_colors[5],PL_colors[0],
 797                       xend - exp, PL_regprecomp, PL_colors[1]));
 798     PL_regflags = pm->op_pmflags;
 799     PL_regsawback = 0;
 800
 801     PL_regseen = 0;
 802     PL_seen_zerolen = *exp == '^' ? -1 : 0;
 803     PL_seen_evals = 0;
 804     PL_extralen = 0;
 805
 806     /* First pass: determine size, legality. */
 807     PL_regcomp_parse = exp;
 808     PL_regxend = xend;
 809     PL_regnaughty = 0;
 810     PL_regnpar = 1;
 811     PL_regsize = 0L;
 812     PL_regcode = &PL_regdummy;
 813     regc((U8)REG_MAGIC, (char*)PL_regcode);
 814     if (reg(0, &flags) == NULL) {
 815         Safefree(PL_regprecomp);
 816         PL_regprecomp = Nullch;
 817         return(NULL);
 818     }
 819     DEBUG_r(PerlIO_printf(Perl_debug_log, "size %d ", PL_regsize));
 820
 821     /* Small enough for pointer-storage convention?
 822        If extralen==0, this means that we will not need long jumps. */
 823     if (PL_regsize >= 0x10000L && PL_extralen)
 824         PL_regsize += PL_extralen;
 825     else
 826         PL_extralen = 0;
 827
 828     /* Allocate space and initialize. */
 829     Newc(1001, r, sizeof(regexp) + (unsigned)PL_regsize * sizeof(regnode),
 830          char, regexp);
 831     if (r == NULL)
 832         FAIL("regexp out of space");
 833     r->refcnt = 1;
 834     r->prelen = xend - exp;
 835     r->precomp = PL_regprecomp;
 836     r->subbeg = NULL;
 837     r->reganch = pm->op_pmflags & PMf_COMPILETIME;
 838     r->nparens = PL_regnpar - 1;        /* set early to validate backrefs */
 839
 840     r->substrs = 0;                     /* Useful during FAIL. */
 841     r->startp = 0;                      /* Useful during FAIL. */
 842     r->endp = 0;                        /* Useful during FAIL. */
 843
 844     PL_regcomp_rx = r;
 845
 846     /* Second pass: emit code. */
 847     PL_regcomp_parse = exp;
 848     PL_regxend = xend;
 849     PL_regnaughty = 0;
 850     PL_regnpar = 1;
 851     PL_regcode = r->program;
 852     /* Store the count of eval-groups for security checks: */
 853     PL_regcode->next_off = ((PL_seen_evals > U16_MAX) ? U16_MAX : PL_seen_evals);
 854     regc((U8)REG_MAGIC, (char*) PL_regcode++);
 855     r->data = 0;
 856     if (reg(0, &flags) == NULL)
 857         return(NULL);
 858
 859     /* Dig out information for optimizations. */
 860     r->reganch = pm->op_pmflags & PMf_COMPILETIME; /* Again? */
 861     pm->op_pmflags = PL_regflags;
 862     if (UTF)
 863         r->reganch |= ROPT_UTF8;
 864     r->regstclass = NULL;
 865     if (PL_regnaughty >= 10)    /* Probably an expensive pattern. */
 866         r->reganch |= ROPT_NAUGHTY;
 867     scan = r->program + 1;              /* First BRANCH. */
 868
 869     /* XXXX To minimize changes to RE engine we always allocate
 870        3-units-long substrs field. */
 871     Newz(1004, r->substrs, 1, struct reg_substr_data);
 872
 873     if (OP(scan) != BRANCH) {   /* Only one top-level choice. */
 874         scan_data_t data;
 875         I32 fake;
 876         STRLEN longest_float_length, longest_fixed_length;
 877
 878         StructCopy(&zero_scan_data, &data, scan_data_t);
 879         first = scan;
 880         /* Skip introductions and multiplicators >= 1. */
 881         while ((OP(first) == OPEN && (sawopen = 1)) ||
 882             (OP(first) == BRANCH && OP(regnext(first)) != BRANCH) ||
 883             (OP(first) == PLUS) ||
 884             (OP(first) == MINMOD) ||
 885             (PL_regkind[(U8)OP(first)] == CURLY && ARG1(first) > 0) ) {
 886                 if (OP(first) == PLUS)
 887                     sawplus = 1;
 888                 else
 889                     first += regarglen[(U8)OP(first)];
 890                 first = NEXTOPER(first);
 891         }
 892
 893         /* Starting-point info. */
 894       again:
 895         if (OP(first) == EXACT);        /* Empty, get anchored substr later. */
 896         else if (strchr(PL_simple+4,OP(first)))
 897             r->regstclass = first;
 898         else if (PL_regkind[(U8)OP(first)] == BOUND ||
 899                  PL_regkind[(U8)OP(first)] == NBOUND)
 900             r->regstclass = first;
 901         else if (PL_regkind[(U8)OP(first)] == BOL) {
 902             r->reganch |= (OP(first) == MBOL
 903                            ? ROPT_ANCH_MBOL
 904                            : (OP(first) == SBOL
 905                               ? ROPT_ANCH_SBOL
 906                               : ROPT_ANCH_BOL));
 907             first = NEXTOPER(first);
 908             goto again;
 909         }
 910         else if (OP(first) == GPOS) {
 911             r->reganch |= ROPT_ANCH_GPOS;
 912             first = NEXTOPER(first);
 913             goto again;
 914         }
 915         else if ((OP(first) == STAR &&
 916             PL_regkind[(U8)OP(NEXTOPER(first))] == REG_ANY) &&
 917             !(r->reganch & ROPT_ANCH) )
 918         {
 919             /* turn .* into ^.* with an implied $*=1 */
 920             int type = OP(NEXTOPER(first));
 921
 922             if (type == REG_ANY || type == ANYUTF8)
 923                 type = ROPT_ANCH_MBOL;
 924             else
 925                 type = ROPT_ANCH_SBOL;
 926
 927             r->reganch |= type | ROPT_IMPLICIT;
 928             first = NEXTOPER(first);
 929             goto again;
 930         }
 931         if (sawplus && (!sawopen || !PL_regsawback)
 932             && !(PL_regseen & REG_SEEN_EVAL)) /* May examine pos and $& */
 933             /* x+ must match at the 1st pos of run of x's */
 934             r->reganch |= ROPT_SKIP;
 935
 936         /* Scan is after the zeroth branch, first is atomic matcher. */
 937         DEBUG_r(PerlIO_printf(Perl_debug_log, "first at %d\n",
 938                               first - scan + 1));
 939         /*
 940         * If there's something expensive in the r.e., find the
 941         * longest literal string that must appear and make it the
 942         * regmust.  Resolve ties in favor of later strings, since
 943         * the regstart check works with the beginning of the r.e.
 944         * and avoiding duplication strengthens checking.  Not a
 945         * strong reason, but sufficient in the absence of others.
 946         * [Now we resolve ties in favor of the earlier string if
 947         * it happens that c_offset_min has been invalidated, since the
 948         * earlier string may buy us something the later one won't.]
 949         */
 950         minlen = 0;
 951
 952         data.longest_fixed = newSVpvn("",0);
 953         data.longest_float = newSVpvn("",0);
 954         data.last_found = newSVpvn("",0);
 955         data.longest = &(data.longest_fixed);
 956         first = scan;
 957
 958         minlen = study_chunk(&first, &fake, scan + PL_regsize, /* Up to end */
 959                              &data, SCF_DO_SUBSTR);
 960         if ( PL_regnpar == 1 && data.longest == &(data.longest_fixed)
 961              && data.last_start_min == 0 && data.last_end > 0
 962              && !PL_seen_zerolen
 963              && (!(PL_regseen & REG_SEEN_GPOS) || (r->reganch & ROPT_ANCH_GPOS)))
 964             r->reganch |= ROPT_CHECK_ALL;
 965         scan_commit(&data);
 966         SvREFCNT_dec(data.last_found);
 967
 968         longest_float_length = CHR_SVLEN(data.longest_float);
 969         if (longest_float_length
 970             || (data.flags & SF_FL_BEFORE_EOL
 971                 && (!(data.flags & SF_FL_BEFORE_MEOL)
 972                     || (PL_regflags & PMf_MULTILINE)))) {
 973             int t;
 974
 975             if (SvCUR(data.longest_fixed)                       /* ok to leave SvCUR */
 976                 && data.offset_fixed == data.offset_float_min
 977                 && SvCUR(data.longest_fixed) == SvCUR(data.longest_float))
 978                     goto remove_float;          /* As in (a)+. */
 979
 980             r->float_substr = data.longest_float;
 981             r->float_min_offset = data.offset_float_min;
 982             r->float_max_offset = data.offset_float_max;
 983             t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */
 984                        && (!(data.flags & SF_FL_BEFORE_MEOL)
 985                            || (PL_regflags & PMf_MULTILINE)));
 986             fbm_compile(r->float_substr, t ? FBMcf_TAIL : 0);
 987         }
 988         else {
 989           remove_float:
 990             r->float_substr = Nullsv;
 991             SvREFCNT_dec(data.longest_float);
 992             longest_float_length = 0;
 993         }
 994
 995         longest_fixed_length = CHR_SVLEN(data.longest_fixed);
 996         if (longest_fixed_length
 997             || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
 998                 && (!(data.flags & SF_FIX_BEFORE_MEOL)
 999                     || (PL_regflags & PMf_MULTILINE)))) {
1000             int t;
1001
1002             r->anchored_substr = data.longest_fixed;
1003             r->anchored_offset = data.offset_fixed;
1004             t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */
1005                  && (!(data.flags & SF_FIX_BEFORE_MEOL)
1006                      || (PL_regflags & PMf_MULTILINE)));
1007             fbm_compile(r->anchored_substr, t ? FBMcf_TAIL : 0);
1008         }
1009         else {
1010             r->anchored_substr = Nullsv;
1011             SvREFCNT_dec(data.longest_fixed);
1012             longest_fixed_length = 0;
1013         }
1014
1015         /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
1016         if (longest_fixed_length > longest_float_length) {
1017             r->check_substr = r->anchored_substr;
1018             r->check_offset_min = r->check_offset_max = r->anchored_offset;
1019             if (r->reganch & ROPT_ANCH_SINGLE)
1020                 r->reganch |= ROPT_NOSCAN;
1021         }
1022         else {
1023             r->check_substr = r->float_substr;
1024             r->check_offset_min = data.offset_float_min;
1025             r->check_offset_max = data.offset_float_max;
1026         }
1027         if (r->check_substr) {
1028             r->reganch |= RE_USE_INTUIT;
1029             if (SvTAIL(r->check_substr))
1030                 r->reganch |= RE_INTUIT_TAIL;
1031         }
1032     }
1033     else {
1034         /* Several toplevels. Best we can is to set minlen. */
1035         I32 fake;
1036
1037         DEBUG_r(PerlIO_printf(Perl_debug_log, "\n"));
1038         scan = r->program + 1;
1039         minlen = study_chunk(&scan, &fake, scan + PL_regsize, NULL, 0);
1040         r->check_substr = r->anchored_substr = r->float_substr = Nullsv;
1041     }
1042
1043     r->minlen = minlen;
1044     if (PL_regseen & REG_SEEN_GPOS)
1045         r->reganch |= ROPT_GPOS_SEEN;
1046     if (PL_regseen & REG_SEEN_LOOKBEHIND)
1047         r->reganch |= ROPT_LOOKBEHIND_SEEN;
1048     if (PL_regseen & REG_SEEN_EVAL)
1049         r->reganch |= ROPT_EVAL_SEEN;
1050     Newz(1002, r->startp, PL_regnpar, I32);
1051     Newz(1002, r->endp, PL_regnpar, I32);
1052     DEBUG_r(regdump(r));
1053     return(r);
1054 }
1055
1056 /*
1057  - reg - regular expression, i.e. main body or parenthesized thing
1058  *
1059  * Caller must absorb opening parenthesis.
1060  *
1061  * Combining parenthesis handling with the base level of regular expression
1062  * is a trifle forced, but the need to tie the tails of the branches to what
1063  * follows makes it hard to avoid.
1064  */
1065 STATIC regnode *
1066 S_reg(pTHX_ I32 paren, I32 *flagp)
1067     /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
1068 {
1069     dTHR;
1070     register regnode *ret;              /* Will be the head of the group. */
1071     register regnode *br;
1072     register regnode *lastbr;
1073     register regnode *ender = 0;
1074     register I32 parno = 0;
1075     I32 flags, oregflags = PL_regflags, have_branch = 0, open = 0;
1076     char c;
1077
1078     *flagp = 0;                         /* Tentatively. */
1079
1080     /* Make an OPEN node, if parenthesized. */
1081     if (paren) {
1082         if (*PL_regcomp_parse == '?') {
1083             U16 posflags = 0, negflags = 0;
1084             U16 *flagsp = &posflags;
1085             int logical = 0;
1086
1087             PL_regcomp_parse++;
1088             paren = *PL_regcomp_parse++;
1089             ret = NULL;                 /* For look-ahead/behind. */
1090             switch (paren) {
1091             case '<':
1092                 PL_regseen |= REG_SEEN_LOOKBEHIND;
1093                 if (*PL_regcomp_parse == '!')
1094                     paren = ',';
1095                 if (*PL_regcomp_parse != '=' && *PL_regcomp_parse != '!')
1096                     goto unknown;
1097                 PL_regcomp_parse++;
1098             case '=':
1099             case '!':
1100                 PL_seen_zerolen++;
1101             case ':':
1102             case '>':
1103                 break;
1104             case '$':
1105             case '@':
1106                 FAIL2("Sequence (?%c...) not implemented", (int)paren);
1107                 break;
1108             case '#':
1109                 while (*PL_regcomp_parse && *PL_regcomp_parse != ')')
1110                     PL_regcomp_parse++;
1111                 if (*PL_regcomp_parse != ')')
1112                     FAIL("Sequence (?#... not terminated");
1113                 nextchar();
1114                 *flagp = TRYAGAIN;
1115                 return NULL;
1116             case 'p':
1117                 logical = 1;
1118                 paren = *PL_regcomp_parse++;
1119                 /* FALL THROUGH */
1120             case '{':
1121             {
1122                 dTHR;
1123                 I32 count = 1, n = 0;
1124                 char c;
1125                 char *s = PL_regcomp_parse;
1126                 SV *sv;
1127                 OP_4tree *sop, *rop;
1128
1129                 PL_seen_zerolen++;
1130                 PL_regseen |= REG_SEEN_EVAL;
1131                 while (count && (c = *PL_regcomp_parse)) {
1132                     if (c == '\\' && PL_regcomp_parse[1])
1133                         PL_regcomp_parse++;
1134                     else if (c == '{')
1135                         count++;
1136                     else if (c == '}')
1137                         count--;
1138                     PL_regcomp_parse++;
1139                 }
1140                 if (*PL_regcomp_parse != ')')
1141                     FAIL("Sequence (?{...}) not terminated or not {}-balanced");
1142                 if (!SIZE_ONLY) {
1143                     AV *av;
1144
1145                     if (PL_regcomp_parse - 1 - s)
1146                         sv = newSVpvn(s, PL_regcomp_parse - 1 - s);
1147                     else
1148                         sv = newSVpvn("", 0);
1149
1150                     rop = sv_compile_2op(sv, &sop, "re", &av);
1151
1152                     n = add_data(3, "nop");
1153                     PL_regcomp_rx->data->data[n] = (void*)rop;
1154                     PL_regcomp_rx->data->data[n+1] = (void*)sop;
1155                     PL_regcomp_rx->data->data[n+2] = (void*)av;
1156                     SvREFCNT_dec(sv);
1157                 }
1158                 else {                                          /* First pass */
1159                     if (PL_reginterp_cnt < ++PL_seen_evals
1160                         && PL_curcop != &PL_compiling)
1161                         /* No compiled RE interpolated, has runtime
1162                            components ===> unsafe.  */
1163                         FAIL("Eval-group not allowed at runtime, use re 'eval'");
1164                     if (PL_tainted)
1165                         FAIL("Eval-group in insecure regular expression");
1166                 }
1167
1168                 nextchar();
1169                 if (logical) {
1170                     ret = reg_node(LOGICAL);
1171                     if (!SIZE_ONLY)
1172                         ret->flags = 2;
1173                     regtail(ret, reganode(EVAL, n));
1174                     return ret;
1175                 }
1176                 return reganode(EVAL, n);
1177             }
1178             case '(':
1179             {
1180                 if (PL_regcomp_parse[0] == '?') {
1181                     if (PL_regcomp_parse[1] == '=' || PL_regcomp_parse[1] == '!'
1182                         || PL_regcomp_parse[1] == '<'
1183                         || PL_regcomp_parse[1] == '{') { /* Lookahead or eval. */
1184                         I32 flag;
1185
1186                         ret = reg_node(LOGICAL);
1187                         if (!SIZE_ONLY)
1188                             ret->flags = 1;
1189                         regtail(ret, reg(1, &flag));
1190                         goto insert_if;
1191                     }
1192                 }
1193                 else if (PL_regcomp_parse[0] >= '1' && PL_regcomp_parse[0] <= '9' ) {
1194                     parno = atoi(PL_regcomp_parse++);
1195
1196                     while (isDIGIT(*PL_regcomp_parse))
1197                         PL_regcomp_parse++;
1198                     ret = reganode(GROUPP, parno);
1199                     if ((c = *nextchar()) != ')')
1200                         FAIL2("Switch (?(number%c not recognized", c);
1201                   insert_if:
1202                     regtail(ret, reganode(IFTHEN, 0));
1203                     br = regbranch(&flags, 1);
1204                     if (br == NULL)
1205                         br = reganode(LONGJMP, 0);
1206                     else
1207                         regtail(br, reganode(LONGJMP, 0));
1208                     c = *nextchar();
1209                     if (flags&HASWIDTH)
1210                         *flagp |= HASWIDTH;
1211                     if (c == '|') {
1212                         lastbr = reganode(IFTHEN, 0); /* Fake one for optimizer. */
1213                         regbranch(&flags, 1);
1214                         regtail(ret, lastbr);
1215                         if (flags&HASWIDTH)
1216                             *flagp |= HASWIDTH;
1217                         c = *nextchar();
1218                     }
1219                     else
1220                         lastbr = NULL;
1221                     if (c != ')')
1222                         FAIL("Switch (?(condition)... contains too many branches");
1223                     ender = reg_node(TAIL);
1224                     regtail(br, ender);
1225                     if (lastbr) {
1226                         regtail(lastbr, ender);
1227                         regtail(NEXTOPER(NEXTOPER(lastbr)), ender);
1228                     }
1229                     else
1230                         regtail(ret, ender);
1231                     return ret;
1232                 }
1233                 else {
1234                     FAIL2("Unknown condition for (?(%.2s", PL_regcomp_parse);
1235                 }
1236             }
1237             case 0:
1238                 FAIL("Sequence (? incomplete");
1239                 break;
1240             default:
1241                 --PL_regcomp_parse;
1242               parse_flags:
1243                 while (*PL_regcomp_parse && strchr("iogcmsx", *PL_regcomp_parse)) {
1244                     if (*PL_regcomp_parse != 'o')
1245                         pmflag(flagsp, *PL_regcomp_parse);
1246                     ++PL_regcomp_parse;
1247                 }
1248                 if (*PL_regcomp_parse == '-') {
1249                     flagsp = &negflags;
1250                     ++PL_regcomp_parse;
1251                     goto parse_flags;
1252                 }
1253                 PL_regflags |= posflags;
1254                 PL_regflags &= ~negflags;
1255                 if (*PL_regcomp_parse == ':') {
1256                     PL_regcomp_parse++;
1257                     paren = ':';
1258                     break;
1259                 }
1260               unknown:
1261                 if (*PL_regcomp_parse != ')')
1262                     FAIL2("Sequence (?%c...) not recognized", *PL_regcomp_parse);
1263                 nextchar();
1264                 *flagp = TRYAGAIN;
1265                 return NULL;
1266             }
1267         }
1268         else {
1269             parno = PL_regnpar;
1270             PL_regnpar++;
1271             ret = reganode(OPEN, parno);
1272             open = 1;
1273         }
1274     }
1275     else
1276         ret = NULL;
1277
1278     /* Pick up the branches, linking them together. */
1279     br = regbranch(&flags, 1);
1280     if (br == NULL)
1281         return(NULL);
1282     if (*PL_regcomp_parse == '|') {
1283         if (!SIZE_ONLY && PL_extralen) {
1284             reginsert(BRANCHJ, br);
1285         }
1286         else
1287             reginsert(BRANCH, br);
1288         have_branch = 1;
1289         if (SIZE_ONLY)
1290             PL_extralen += 1;           /* For BRANCHJ-BRANCH. */
1291     }
1292     else if (paren == ':') {
1293         *flagp |= flags&SIMPLE;
1294     }
1295     if (open) {                         /* Starts with OPEN. */
1296         regtail(ret, br);               /* OPEN -> first. */
1297     }
1298     else if (paren != '?')              /* Not Conditional */
1299         ret = br;
1300     if (flags&HASWIDTH)
1301         *flagp |= HASWIDTH;
1302     *flagp |= flags&SPSTART;
1303     lastbr = br;
1304     while (*PL_regcomp_parse == '|') {
1305         if (!SIZE_ONLY && PL_extralen) {
1306             ender = reganode(LONGJMP,0);
1307             regtail(NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
1308         }
1309         if (SIZE_ONLY)
1310             PL_extralen += 2;           /* Account for LONGJMP. */
1311         nextchar();
1312         br = regbranch(&flags, 0);
1313         if (br == NULL)
1314             return(NULL);
1315         regtail(lastbr, br);            /* BRANCH -> BRANCH. */
1316         lastbr = br;
1317         if (flags&HASWIDTH)
1318             *flagp |= HASWIDTH;
1319         *flagp |= flags&SPSTART;
1320     }
1321
1322     if (have_branch || paren != ':') {
1323         /* Make a closing node, and hook it on the end. */
1324         switch (paren) {
1325         case ':':
1326             ender = reg_node(TAIL);
1327             break;
1328         case 1:
1329             ender = reganode(CLOSE, parno);
1330             break;
1331         case '<':
1332         case ',':
1333         case '=':
1334         case '!':
1335             *flagp &= ~HASWIDTH;
1336             /* FALL THROUGH */
1337         case '>':
1338             ender = reg_node(SUCCEED);
1339             break;
1340         case 0:
1341             ender = reg_node(END);
1342             break;
1343         }
1344         regtail(lastbr, ender);
1345
1346         if (have_branch) {
1347             /* Hook the tails of the branches to the closing node. */
1348             for (br = ret; br != NULL; br = regnext(br)) {
1349                 regoptail(br, ender);
1350             }
1351         }
1352     }
1353
1354     {
1355         char *p;
1356         static char parens[] = "=!<,>";
1357
1358         if (paren && (p = strchr(parens, paren))) {
1359             int node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
1360             int flag = (p - parens) > 1;
1361
1362             if (paren == '>')
1363                 node = SUSPEND, flag = 0;
1364             reginsert(node,ret);
1365             ret->flags = flag;
1366             regtail(ret, reg_node(TAIL));
1367         }
1368     }
1369
1370     /* Check for proper termination. */
1371     if (paren) {
1372         PL_regflags = oregflags;
1373         if (PL_regcomp_parse >= PL_regxend || *nextchar() != ')') {
1374             FAIL("unmatched () in regexp");
1375         }
1376     }
1377     else if (!paren && PL_regcomp_parse < PL_regxend) {
1378         if (*PL_regcomp_parse == ')') {
1379             FAIL("unmatched () in regexp");
1380         }
1381         else
1382             FAIL("junk on end of regexp");      /* "Can't happen". */
1383         /* NOTREACHED */
1384     }
1385
1386     return(ret);
1387 }
1388
1389 /*
1390  - regbranch - one alternative of an | operator
1391  *
1392  * Implements the concatenation operator.
1393  */
1394 STATIC regnode *
1395 S_regbranch(pTHX_ I32 *flagp, I32 first)
1396 {
1397     dTHR;
1398     register regnode *ret;
1399     register regnode *chain = NULL;
1400     register regnode *latest;
1401     I32 flags = 0, c = 0;
1402
1403     if (first)
1404         ret = NULL;
1405     else {
1406         if (!SIZE_ONLY && PL_extralen)
1407             ret = reganode(BRANCHJ,0);
1408         else
1409             ret = reg_node(BRANCH);
1410     }
1411
1412     if (!first && SIZE_ONLY)
1413         PL_extralen += 1;                       /* BRANCHJ */
1414
1415     *flagp = WORST;                     /* Tentatively. */
1416
1417     PL_regcomp_parse--;
1418     nextchar();
1419     while (PL_regcomp_parse < PL_regxend && *PL_regcomp_parse != '|' && *PL_regcomp_parse != ')') {
1420         flags &= ~TRYAGAIN;
1421         latest = regpiece(&flags);
1422         if (latest == NULL) {
1423             if (flags & TRYAGAIN)
1424                 continue;
1425             return(NULL);
1426         }
1427         else if (ret == NULL)
1428             ret = latest;
1429         *flagp |= flags&HASWIDTH;
1430         if (chain == NULL)      /* First piece. */
1431             *flagp |= flags&SPSTART;
1432         else {
1433             PL_regnaughty++;
1434             regtail(chain, latest);
1435         }
1436         chain = latest;
1437         c++;
1438     }
1439     if (chain == NULL) {        /* Loop ran zero times. */
1440         chain = reg_node(NOTHING);
1441         if (ret == NULL)
1442             ret = chain;
1443     }
1444     if (c == 1) {
1445         *flagp |= flags&SIMPLE;
1446     }
1447
1448     return(ret);
1449 }
1450
1451 /*
1452  - regpiece - something followed by possible [*+?]
1453  *
1454  * Note that the branching code sequences used for ? and the general cases
1455  * of * and + are somewhat optimized:  they use the same NOTHING node as
1456  * both the endmarker for their branch list and the body of the last branch.
1457  * It might seem that this node could be dispensed with entirely, but the
1458  * endmarker role is not redundant.
1459  */
1460 STATIC regnode *
1461 S_regpiece(pTHX_ I32 *flagp)
1462 {
1463     dTHR;
1464     register regnode *ret;
1465     register char op;
1466     register char *next;
1467     I32 flags;
1468     char *origparse = PL_regcomp_parse;
1469     char *maxpos;
1470     I32 min;
1471     I32 max = REG_INFTY;
1472
1473     ret = regatom(&flags);
1474     if (ret == NULL) {
1475         if (flags & TRYAGAIN)
1476             *flagp |= TRYAGAIN;
1477         return(NULL);
1478     }
1479
1480     op = *PL_regcomp_parse;
1481
1482     if (op == '{' && regcurly(PL_regcomp_parse)) {
1483         next = PL_regcomp_parse + 1;
1484         maxpos = Nullch;
1485         while (isDIGIT(*next) || *next == ',') {
1486             if (*next == ',') {
1487                 if (maxpos)
1488                     break;
1489                 else
1490                     maxpos = next;
1491             }
1492             next++;
1493         }
1494         if (*next == '}') {             /* got one */
1495             if (!maxpos)
1496                 maxpos = next;
1497             PL_regcomp_parse++;
1498             min = atoi(PL_regcomp_parse);
1499             if (*maxpos == ',')
1500                 maxpos++;
1501             else
1502                 maxpos = PL_regcomp_parse;
1503             max = atoi(maxpos);
1504             if (!max && *maxpos != '0')
1505                 max = REG_INFTY;                /* meaning "infinity" */
1506             else if (max >= REG_INFTY)
1507                 FAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
1508             PL_regcomp_parse = next;
1509             nextchar();
1510
1511         do_curly:
1512             if ((flags&SIMPLE)) {
1513                 PL_regnaughty += 2 + PL_regnaughty / 2;
1514                 reginsert(CURLY, ret);
1515             }
1516             else {
1517                 PL_regnaughty += 4 + PL_regnaughty;     /* compound interest */
1518                 regtail(ret, reg_node(WHILEM));
1519                 if (!SIZE_ONLY && PL_extralen) {
1520                     reginsert(LONGJMP,ret);
1521                     reginsert(NOTHING,ret);
1522                     NEXT_OFF(ret) = 3;  /* Go over LONGJMP. */
1523                 }
1524                 reginsert(CURLYX,ret);
1525                 if (!SIZE_ONLY && PL_extralen)
1526                     NEXT_OFF(ret) = 3;  /* Go over NOTHING to LONGJMP. */
1527                 regtail(ret, reg_node(NOTHING));
1528                 if (SIZE_ONLY)
1529                     PL_extralen += 3;
1530             }
1531             ret->flags = 0;
1532
1533             if (min > 0)
1534                 *flagp = WORST;
1535             if (max > 0)
1536                 *flagp |= HASWIDTH;
1537             if (max && max < min)
1538                 FAIL("Can't do {n,m} with n > m");
1539             if (!SIZE_ONLY) {
1540                 ARG1_SET(ret, min);
1541                 ARG2_SET(ret, max);
1542             }
1543
1544             goto nest_check;
1545         }
1546     }
1547
1548     if (!ISMULT1(op)) {
1549         *flagp = flags;
1550         return(ret);
1551     }
1552
1553 #if 0                           /* Now runtime fix should be reliable. */
1554     if (!(flags&HASWIDTH) && op != '?')
1555       FAIL("regexp *+ operand could be empty");
1556 #endif
1557
1558     nextchar();
1559
1560     *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
1561
1562     if (op == '*' && (flags&SIMPLE)) {
1563         reginsert(STAR, ret);
1564         ret->flags = 0;
1565         PL_regnaughty += 4;
1566     }
1567     else if (op == '*') {
1568         min = 0;
1569         goto do_curly;
1570     }
1571     else if (op == '+' && (flags&SIMPLE)) {
1572         reginsert(PLUS, ret);
1573         ret->flags = 0;
1574         PL_regnaughty += 3;
1575     }
1576     else if (op == '+') {
1577         min = 1;
1578         goto do_curly;
1579     }
1580     else if (op == '?') {
1581         min = 0; max = 1;
1582         goto do_curly;
1583     }
1584   nest_check:
1585     if (ckWARN(WARN_UNSAFE) && !SIZE_ONLY && !(flags&HASWIDTH) && max > REG_INFTY/3) {
1586         Perl_warner(aTHX_ WARN_UNSAFE, "%.*s matches null string many times",
1587             PL_regcomp_parse - origparse, origparse);
1588     }
1589
1590     if (*PL_regcomp_parse == '?') {
1591         nextchar();
1592         reginsert(MINMOD, ret);
1593         regtail(ret, ret + NODE_STEP_REGNODE);
1594     }
1595     if (ISMULT2(PL_regcomp_parse))
1596         FAIL("nested *?+ in regexp");
1597
1598     return(ret);
1599 }
1600
1601 /*
1602  - regatom - the lowest level
1603  *
1604  * Optimization:  gobbles an entire sequence of ordinary characters so that
1605  * it can turn them into a single node, which is smaller to store and
1606  * faster to run.  Backslashed characters are exceptions, each becoming a
1607  * separate node; the code is simpler that way and it's not worth fixing.
1608  *
1609  * [Yes, it is worth fixing, some scripts can run twice the speed.]
1610  */
1611 STATIC regnode *
1612 S_regatom(pTHX_ I32 *flagp)
1613 {
1614     dTHR;
1615     register regnode *ret = 0;
1616     I32 flags;
1617
1618     *flagp = WORST;             /* Tentatively. */
1619
1620 tryagain:
1621     switch (*PL_regcomp_parse) {
1622     case '^':
1623         PL_seen_zerolen++;
1624         nextchar();
1625         if (PL_regflags & PMf_MULTILINE)
1626             ret = reg_node(MBOL);
1627         else if (PL_regflags & PMf_SINGLELINE)
1628             ret = reg_node(SBOL);
1629         else
1630             ret = reg_node(BOL);
1631         break;
1632     case '$':
1633         if (PL_regcomp_parse[1])
1634             PL_seen_zerolen++;
1635         nextchar();
1636         if (PL_regflags & PMf_MULTILINE)
1637             ret = reg_node(MEOL);
1638         else if (PL_regflags & PMf_SINGLELINE)
1639             ret = reg_node(SEOL);
1640         else
1641             ret = reg_node(EOL);
1642         break;
1643     case '.':
1644         nextchar();
1645         if (UTF) {
1646             if (PL_regflags & PMf_SINGLELINE)
1647                 ret = reg_node(SANYUTF8);
1648             else
1649                 ret = reg_node(ANYUTF8);
1650             *flagp |= HASWIDTH;
1651         }
1652         else {
1653             if (PL_regflags & PMf_SINGLELINE)
1654                 ret = reg_node(SANY);
1655             else
1656                 ret = reg_node(REG_ANY);
1657             *flagp |= HASWIDTH|SIMPLE;
1658         }
1659         PL_regnaughty++;
1660         break;
1661     case '[':
1662         PL_regcomp_parse++;
1663         ret = (UTF ? regclassutf8() : regclass());
1664         if (*PL_regcomp_parse != ']')
1665             FAIL("unmatched [] in regexp");
1666         nextchar();
1667         *flagp |= HASWIDTH|SIMPLE;
1668         break;
1669     case '(':
1670         nextchar();
1671         ret = reg(1, &flags);
1672         if (ret == NULL) {
1673                 if (flags & TRYAGAIN)
1674                     goto tryagain;
1675                 return(NULL);
1676         }
1677         *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE);
1678         break;
1679     case '|':
1680     case ')':
1681         if (flags & TRYAGAIN) {
1682             *flagp |= TRYAGAIN;
1683             return NULL;
1684         }
1685         FAIL2("internal urp in regexp at /%s/", PL_regcomp_parse);
1686                                 /* Supposed to be caught earlier. */
1687         break;
1688     case '{':
1689         if (!regcurly(PL_regcomp_parse)) {
1690             PL_regcomp_parse++;
1691             goto defchar;
1692         }
1693         /* FALL THROUGH */
1694     case '?':
1695     case '+':
1696     case '*':
1697         FAIL("?+*{} follows nothing in regexp");
1698         break;
1699     case '\\':
1700         switch (*++PL_regcomp_parse) {
1701         case 'A':
1702             PL_seen_zerolen++;
1703             ret = reg_node(SBOL);
1704             *flagp |= SIMPLE;
1705             nextchar();
1706             break;
1707         case 'G':
1708             ret = reg_node(GPOS);
1709             PL_regseen |= REG_SEEN_GPOS;
1710             *flagp |= SIMPLE;
1711             nextchar();
1712             break;
1713         case 'Z':
1714             ret = reg_node(SEOL);
1715             *flagp |= SIMPLE;
1716             nextchar();
1717             break;
1718         case 'z':
1719             ret = reg_node(EOS);
1720             *flagp |= SIMPLE;
1721             PL_seen_zerolen++;          /* Do not optimize RE away */
1722             nextchar();
1723             break;
1724         case 'C':
1725             ret = reg_node(SANY);
1726             *flagp |= HASWIDTH|SIMPLE;
1727             nextchar();
1728             break;
1729         case 'X':
1730             ret = reg_node(CLUMP);
1731             *flagp |= HASWIDTH;
1732             nextchar();
1733             if (UTF && !PL_utf8_mark)
1734                 is_utf8_mark((U8*)"~");         /* preload table */
1735             break;
1736         case 'w':
1737             ret = reg_node(
1738                 UTF
1739                     ? (LOC ? ALNUMLUTF8 : ALNUMUTF8)
1740                     : (LOC ? ALNUML     : ALNUM));
1741             *flagp |= HASWIDTH|SIMPLE;
1742             nextchar();
1743             if (UTF && !PL_utf8_alnum)
1744                 is_utf8_alnum((U8*)"a");        /* preload table */
1745             break;
1746         case 'W':
1747             ret = reg_node(
1748                 UTF
1749                     ? (LOC ? NALNUMLUTF8 : NALNUMUTF8)
1750                     : (LOC ? NALNUML     : NALNUM));
1751             *flagp |= HASWIDTH|SIMPLE;
1752             nextchar();
1753             if (UTF && !PL_utf8_alnum)
1754                 is_utf8_alnum((U8*)"a");        /* preload table */
1755             break;
1756         case 'b':
1757             PL_seen_zerolen++;
1758             PL_regseen |= REG_SEEN_LOOKBEHIND;
1759             ret = reg_node(
1760                 UTF
1761                     ? (LOC ? BOUNDLUTF8 : BOUNDUTF8)
1762                     : (LOC ? BOUNDL     : BOUND));
1763             *flagp |= SIMPLE;
1764             nextchar();
1765             if (UTF && !PL_utf8_alnum)
1766                 is_utf8_alnum((U8*)"a");        /* preload table */
1767             break;
1768         case 'B':
1769             PL_seen_zerolen++;
1770             PL_regseen |= REG_SEEN_LOOKBEHIND;
1771             ret = reg_node(
1772                 UTF
1773                     ? (LOC ? NBOUNDLUTF8 : NBOUNDUTF8)
1774                     : (LOC ? NBOUNDL     : NBOUND));
1775             *flagp |= SIMPLE;
1776             nextchar();
1777             if (UTF && !PL_utf8_alnum)
1778                 is_utf8_alnum((U8*)"a");        /* preload table */
1779             break;
1780         case 's':
1781             ret = reg_node(
1782                 UTF
1783                     ? (LOC ? SPACELUTF8 : SPACEUTF8)
1784                     : (LOC ? SPACEL     : SPACE));
1785             *flagp |= HASWIDTH|SIMPLE;
1786             nextchar();
1787             if (UTF && !PL_utf8_space)
1788                 is_utf8_space((U8*)" ");        /* preload table */
1789             break;
1790         case 'S':
1791             ret = reg_node(
1792                 UTF
1793                     ? (LOC ? NSPACELUTF8 : NSPACEUTF8)
1794                     : (LOC ? NSPACEL     : NSPACE));
1795             *flagp |= HASWIDTH|SIMPLE;
1796             nextchar();
1797             if (UTF && !PL_utf8_space)
1798                 is_utf8_space((U8*)" ");        /* preload table */
1799             break;
1800         case 'd':
1801             ret = reg_node(UTF ? DIGITUTF8 : DIGIT);
1802             *flagp |= HASWIDTH|SIMPLE;
1803             nextchar();
1804             if (UTF && !PL_utf8_digit)
1805                 is_utf8_digit((U8*)"1");        /* preload table */
1806             break;
1807         case 'D':
1808             ret = reg_node(UTF ? NDIGITUTF8 : NDIGIT);
1809             *flagp |= HASWIDTH|SIMPLE;
1810             nextchar();
1811             if (UTF && !PL_utf8_digit)
1812                 is_utf8_digit((U8*)"1");        /* preload table */
1813             break;
1814         case 'p':
1815         case 'P':
1816             {   /* a lovely hack--pretend we saw [\pX] instead */
1817                 char* oldregxend = PL_regxend;
1818
1819                 if (PL_regcomp_parse[1] == '{') {
1820                     PL_regxend = strchr(PL_regcomp_parse, '}');
1821                     if (!PL_regxend)
1822                         FAIL("Missing right brace on \\p{}");
1823                     PL_regxend++;
1824                 }
1825                 else
1826                     PL_regxend = PL_regcomp_parse + 2;
1827                 PL_regcomp_parse--;
1828
1829                 ret = regclassutf8();
1830
1831                 PL_regxend = oldregxend;
1832                 PL_regcomp_parse--;
1833                 nextchar();
1834                 *flagp |= HASWIDTH|SIMPLE;
1835             }
1836             break;
1837         case 'n':
1838         case 'r':
1839         case 't':
1840         case 'f':
1841         case 'e':
1842         case 'a':
1843         case 'x':
1844         case 'c':
1845         case '0':
1846             goto defchar;
1847         case '1': case '2': case '3': case '4':
1848         case '5': case '6': case '7': case '8': case '9':
1849             {
1850                 I32 num = atoi(PL_regcomp_parse);
1851
1852                 if (num > 9 && num >= PL_regnpar)
1853                     goto defchar;
1854                 else {
1855                     if (!SIZE_ONLY && num > PL_regcomp_rx->nparens)
1856                         FAIL("reference to nonexistent group");
1857                     PL_regsawback = 1;
1858                     ret = reganode(FOLD
1859                                    ? (LOC ? REFFL : REFF)
1860                                    : REF, num);
1861                     *flagp |= HASWIDTH;
1862                     while (isDIGIT(*PL_regcomp_parse))
1863                         PL_regcomp_parse++;
1864                     PL_regcomp_parse--;
1865                     nextchar();
1866                 }
1867             }
1868             break;
1869         case '\0':
1870             if (PL_regcomp_parse >= PL_regxend)
1871                 FAIL("trailing \\ in regexp");
1872             /* FALL THROUGH */
1873         default:
1874             /* Do not generate `unrecognized' warnings here, we fall
1875                back into the quick-grab loop below */
1876             goto defchar;
1877         }
1878         break;
1879
1880     case '#':
1881         if (PL_regflags & PMf_EXTENDED) {
1882             while (PL_regcomp_parse < PL_regxend && *PL_regcomp_parse != '\n') PL_regcomp_parse++;
1883             if (PL_regcomp_parse < PL_regxend)
1884                 goto tryagain;
1885         }
1886         /* FALL THROUGH */
1887
1888     default: {
1889             register I32 len;
1890             register UV ender;
1891             register char *p;
1892             char *oldp, *s;
1893             I32 numlen;
1894
1895             PL_regcomp_parse++;
1896
1897         defchar:
1898             ret = reg_node(FOLD
1899                           ? (LOC ? EXACTFL : EXACTF)
1900                           : EXACT);
1901             s = (char *) OPERAND(ret);
1902             regc(0, s++);               /* save spot for len */
1903             for (len = 0, p = PL_regcomp_parse - 1;
1904               len < 127 && p < PL_regxend;
1905               len++)
1906             {
1907                 oldp = p;
1908
1909                 if (PL_regflags & PMf_EXTENDED)
1910                     p = regwhite(p, PL_regxend);
1911                 switch (*p) {
1912                 case '^':
1913                 case '$':
1914                 case '.':
1915                 case '[':
1916                 case '(':
1917                 case ')':
1918                 case '|':
1919                     goto loopdone;
1920                 case '\\':
1921                     switch (*++p) {
1922                     case 'A':
1923                     case 'G':
1924                     case 'Z':
1925                     case 'z':
1926                     case 'w':
1927                     case 'W':
1928                     case 'b':
1929                     case 'B':
1930                     case 's':
1931                     case 'S':
1932                     case 'd':
1933                     case 'D':
1934                     case 'p':
1935                     case 'P':
1936                         --p;
1937                         goto loopdone;
1938                     case 'n':
1939                         ender = '\n';
1940                         p++;
1941                         break;
1942                     case 'r':
1943                         ender = '\r';
1944                         p++;
1945                         break;
1946                     case 't':
1947                         ender = '\t';
1948                         p++;
1949                         break;
1950                     case 'f':
1951                         ender = '\f';
1952                         p++;
1953                         break;
1954                     case 'e':
1955                         ender = '\033';
1956                         p++;
1957                         break;
1958                     case 'a':
1959                         ender = '\007';
1960                         p++;
1961                         break;
1962                     case 'x':
1963                         if (*++p == '{') {
1964                             char* e = strchr(p, '}');
1965
1966                             if (!e)
1967                                 FAIL("Missing right brace on \\x{}");
1968                             else if (UTF) {
1969                                 ender = scan_hex(p + 1, e - p, &numlen);
1970                                 if (numlen + len >= 127) {      /* numlen is generous */
1971                                     p--;
1972                                     goto loopdone;
1973                                 }
1974                                 p = e + 1;
1975                             }
1976                             else
1977                                 FAIL("Can't use \\x{} without 'use utf8' declaration");
1978                         }
1979                         else {
1980                             ender = scan_hex(p, 2, &numlen);
1981                             p += numlen;
1982                         }
1983                         break;
1984                     case 'c':
1985                         p++;
1986                         ender = UCHARAT(p++);
1987                         ender = toCTRL(ender);
1988                         break;
1989                     case '0': case '1': case '2': case '3':case '4':
1990                     case '5': case '6': case '7': case '8':case '9':
1991                         if (*p == '0' ||
1992                           (isDIGIT(p[1]) && atoi(p) >= PL_regnpar) ) {
1993                             ender = scan_oct(p, 3, &numlen);
1994                             p += numlen;
1995                         }
1996                         else {
1997                             --p;
1998                             goto loopdone;
1999                         }
2000                         break;
2001                     case '\0':
2002                         if (p >= PL_regxend)
2003                             FAIL("trailing \\ in regexp");
2004                         /* FALL THROUGH */
2005                     default:
2006                         if (!SIZE_ONLY && ckWARN(WARN_UNSAFE) && isALPHA(*p))
2007                             Perl_warner(aTHX_ WARN_UNSAFE,
2008                                    "/%.127s/: Unrecognized escape \\%c passed through",
2009                                    PL_regprecomp,
2010                                    *p);
2011                         goto normal_default;
2012                     }
2013                     break;
2014                 default:
2015                   normal_default:
2016                     if ((*p & 0xc0) == 0xc0 && UTF) {
2017                         ender = utf8_to_uv((U8*)p, &numlen);
2018                         p += numlen;
2019                     }
2020                     else
2021                         ender = *p++;
2022                     break;
2023                 }
2024                 if (PL_regflags & PMf_EXTENDED)
2025                     p = regwhite(p, PL_regxend);
2026                 if (UTF && FOLD) {
2027                     if (LOC)
2028                         ender = toLOWER_LC_uni(ender);
2029                     else
2030                         ender = toLOWER_uni(ender);
2031                 }
2032                 if (ISMULT2(p)) { /* Back off on ?+*. */
2033                     if (len)
2034                         p = oldp;
2035                     else if (ender >= 0x80 && UTF) {
2036                         reguni(ender, s, &numlen);
2037                         s += numlen;
2038                         len += numlen;
2039                     }
2040                     else {
2041                         len++;
2042                         regc(ender, s++);
2043                     }
2044                     break;
2045                 }
2046                 if (ender >= 0x80 && UTF) {
2047                     reguni(ender, s, &numlen);
2048                     s += numlen;
2049                     len += numlen - 1;
2050                 }
2051                 else
2052                     regc(ender, s++);
2053             }
2054         loopdone:
2055             PL_regcomp_parse = p - 1;
2056             nextchar();
2057             if (len < 0)
2058                 FAIL("internal disaster in regexp");
2059             if (len > 0)
2060                 *flagp |= HASWIDTH;
2061             if (len == 1)
2062                 *flagp |= SIMPLE;
2063             if (!SIZE_ONLY)
2064                 *OPERAND(ret) = len;
2065             regc('\0', s++);
2066             if (SIZE_ONLY) {
2067                 PL_regsize += (len + 2 + sizeof(regnode) - 1) / sizeof(regnode);
2068             }
2069             else {
2070                 PL_regcode += (len + 2 + sizeof(regnode) - 1) / sizeof(regnode);
2071             }
2072         }
2073         break;
2074     }
2075
2076     return(ret);
2077 }
2078
2079 STATIC char *
2080 S_regwhite(pTHX_ char *p, char *e)
2081 {
2082     while (p < e) {
2083         if (isSPACE(*p))
2084             ++p;
2085         else if (*p == '#') {
2086             do {
2087                 p++;
2088             } while (p < e && *p != '\n');
2089         }
2090         else
2091             break;
2092     }
2093     return p;
2094 }
2095
2096 /* parse POSIX character classes like [[:foo:]] */
2097 STATIC char*
2098 S_regpposixcc(pTHX_ I32 value)
2099 {
2100     dTHR;
2101     char *posixcc = 0;
2102
2103     if (value == '[' && PL_regcomp_parse + 1 < PL_regxend &&
2104         /* I smell either [: or [= or [. -- POSIX has been here, right? */
2105         (*PL_regcomp_parse == ':' ||
2106          *PL_regcomp_parse == '=' ||
2107          *PL_regcomp_parse == '.')) {
2108         char  c = *PL_regcomp_parse;
2109         char* s = PL_regcomp_parse++;
2110
2111         while (PL_regcomp_parse < PL_regxend && *PL_regcomp_parse != c)
2112             PL_regcomp_parse++;
2113         if (PL_regcomp_parse == PL_regxend)
2114             /* Grandfather lone [:, [=, [. */
2115             PL_regcomp_parse = s;
2116         else {
2117             PL_regcomp_parse++; /* skip over the c */
2118             if (*PL_regcomp_parse == ']') {
2119                 /* Not Implemented Yet.
2120                  * (POSIX Extended Character Classes, that is)
2121                  * The text between e.g. [: and :] would start
2122                  * at s + 1 and stop at regcomp_parse - 2. */
2123                 if (ckWARN(WARN_UNSAFE) && !SIZE_ONLY)
2124                     Perl_warner(aTHX_ WARN_UNSAFE,
2125                            "Character class syntax [%c %c] is reserved for future extensions", c, c);
2126                 PL_regcomp_parse++; /* skip over the ending ] */
2127                 posixcc = s + 1;
2128             }
2129             else {
2130                 /* maternal grandfather */
2131                 PL_regcomp_parse = s;
2132             }
2133         }
2134     }
2135
2136     return posixcc;
2137 }
2138
2139 STATIC regnode *
2140 S_regclass(pTHX)
2141 {
2142     dTHR;
2143     register char *opnd, *s;
2144     register I32 value;
2145     register I32 lastvalue = 1234;
2146     register I32 range = 0;
2147     register regnode *ret;
2148     register I32 def;
2149     I32 numlen;
2150
2151     s = opnd = (char *) OPERAND(PL_regcode);
2152     ret = reg_node(ANYOF);
2153     for (value = 0; value < 33; value++)
2154         regc(0, s++);
2155     if (*PL_regcomp_parse == '^') {     /* Complement of range. */
2156         PL_regnaughty++;
2157         PL_regcomp_parse++;
2158         if (!SIZE_ONLY)
2159             *opnd |= ANYOF_INVERT;
2160     }
2161     if (!SIZE_ONLY) {
2162         PL_regcode += ANY_SKIP;
2163         if (FOLD)
2164             *opnd |= ANYOF_FOLD;
2165         if (LOC)
2166             *opnd |= ANYOF_LOCALE;
2167     }
2168     else {
2169         PL_regsize += ANY_SKIP;
2170     }
2171     if (*PL_regcomp_parse == ']' || *PL_regcomp_parse == '-')
2172         goto skipcond;          /* allow 1st char to be ] or - */
2173     while (PL_regcomp_parse < PL_regxend && *PL_regcomp_parse != ']') {
2174        skipcond:
2175         value = UCHARAT(PL_regcomp_parse++);
2176         if (value == '[')
2177             (void)regpposixcc(value); /* ignore the return value for now */
2178         else if (value == '\\') {
2179             value = UCHARAT(PL_regcomp_parse++);
2180             switch (value) {
2181             case 'w':
2182                 if (!SIZE_ONLY) {
2183                     if (LOC)
2184                         *opnd |= ANYOF_ALNUML;
2185                     else {
2186                         for (value = 0; value < 256; value++)
2187                             if (isALNUM(value))
2188                                 ANYOF_SET(opnd, value);
2189                     }
2190                 }
2191                 lastvalue = 1234;
2192                 continue;
2193             case 'W':
2194                 if (!SIZE_ONLY) {
2195                     if (LOC)
2196                         *opnd |= ANYOF_NALNUML;
2197                     else {
2198                         for (value = 0; value < 256; value++)
2199                             if (!isALNUM(value))
2200                                 ANYOF_SET(opnd, value);
2201                     }
2202                 }
2203                 lastvalue = 1234;
2204                 continue;
2205             case 's':
2206                 if (!SIZE_ONLY) {
2207                     if (LOC)
2208                         *opnd |= ANYOF_SPACEL;
2209                     else {
2210                         for (value = 0; value < 256; value++)
2211                             if (isSPACE(value))
2212                                 ANYOF_SET(opnd, value);
2213                     }
2214                 }
2215                 lastvalue = 1234;
2216                 continue;
2217             case 'S':
2218                 if (!SIZE_ONLY) {
2219                     if (LOC)
2220                         *opnd |= ANYOF_NSPACEL;
2221                     else {
2222                         for (value = 0; value < 256; value++)
2223                             if (!isSPACE(value))
2224                                 ANYOF_SET(opnd, value);
2225                     }
2226                 }
2227                 lastvalue = 1234;
2228                 continue;
2229             case 'd':
2230                 if (!SIZE_ONLY) {
2231                     for (value = '0'; value <= '9'; value++)
2232                         ANYOF_SET(opnd, value);
2233                 }
2234                 lastvalue = 1234;
2235                 continue;
2236             case 'D':
2237                 if (!SIZE_ONLY) {
2238                     for (value = 0; value < '0'; value++)
2239                         ANYOF_SET(opnd, value);
2240                     for (value = '9' + 1; value < 256; value++)
2241                         ANYOF_SET(opnd, value);
2242                 }
2243                 lastvalue = 1234;
2244                 continue;
2245             case 'n':
2246                 value = '\n';
2247                 break;
2248             case 'r':
2249                 value = '\r';
2250                 break;
2251             case 't':
2252                 value = '\t';
2253                 break;
2254             case 'f':
2255                 value = '\f';
2256                 break;
2257             case 'b':
2258                 value = '\b';
2259                 break;
2260             case 'e':
2261                 value = '\033';
2262                 break;
2263             case 'a':
2264                 value = '\007';
2265                 break;
2266             case 'x':
2267                 value = scan_hex(PL_regcomp_parse, 2, &numlen);
2268                 PL_regcomp_parse += numlen;
2269                 break;
2270             case 'c':
2271                 value = UCHARAT(PL_regcomp_parse++);
2272                 value = toCTRL(value);
2273                 break;
2274             case '0': case '1': case '2': case '3': case '4':
2275             case '5': case '6': case '7': case '8': case '9':
2276                 value = scan_oct(--PL_regcomp_parse, 3, &numlen);
2277                 PL_regcomp_parse += numlen;
2278                 break;
2279             }
2280         }
2281         if (range) {
2282             if (lastvalue > value)
2283                 FAIL("invalid [] range in regexp");
2284             range = 0;
2285         }
2286         else {
2287             lastvalue = value;
2288             if (*PL_regcomp_parse == '-' && PL_regcomp_parse+1 < PL_regxend &&
2289               PL_regcomp_parse[1] != ']') {
2290                 PL_regcomp_parse++;
2291                 range = 1;
2292                 continue;       /* do it next time */
2293             }
2294         }
2295         if (!SIZE_ONLY) {
2296 #ifndef ASCIIish
2297             if ((isLOWER(lastvalue) && isLOWER(value)) ||
2298                 (isUPPER(lastvalue) && isUPPER(value)))
2299             {
2300                 I32 i;
2301                 if (isLOWER(lastvalue)) {
2302                     for (i = lastvalue; i <= value; i++)
2303                         if (isLOWER(i))
2304                             ANYOF_SET(opnd, i);
2305                 } else {
2306                     for (i = lastvalue; i <= value; i++)
2307                         if (isUPPER(i))
2308                             ANYOF_SET(opnd, i);
2309                 }
2310             }
2311             else
2312 #endif
2313                 for ( ; lastvalue <= value; lastvalue++)
2314                     ANYOF_SET(opnd, lastvalue);
2315         }
2316         lastvalue = value;
2317     }
2318     /* optimize case-insensitive simple patterns (e.g. /[a-z]/i) */
2319     if (!SIZE_ONLY && (*opnd & (0xFF ^ ANYOF_INVERT)) == ANYOF_FOLD) {
2320         for (value = 0; value < 256; ++value) {
2321             if (ANYOF_TEST(opnd, value)) {
2322                 I32 cf = PL_fold[value];
2323                 ANYOF_SET(opnd, cf);
2324             }
2325         }
2326         *opnd &= ~ANYOF_FOLD;
2327     }
2328     /* optimize inverted simple patterns (e.g. [^a-z]) */
2329     if (!SIZE_ONLY && (*opnd & 0xFF) == ANYOF_INVERT) {
2330         for (value = 0; value < 32; ++value)
2331             opnd[1 + value] ^= 0xFF;
2332         *opnd = 0;
2333     }
2334     return ret;
2335 }
2336
2337 STATIC regnode *
2338 S_regclassutf8(pTHX)
2339 {
2340     register char *opnd, *e;
2341     register U32 value;
2342     register U32 lastvalue = 123456;
2343     register I32 range = 0;
2344     register regnode *ret;
2345     I32 numlen;
2346     I32 n;
2347     SV *listsv;
2348     U8 flags = 0;
2349     dTHR;
2350
2351     if (*PL_regcomp_parse == '^') {     /* Complement of range. */
2352         PL_regnaughty++;
2353         PL_regcomp_parse++;
2354         if (!SIZE_ONLY)
2355             flags |= ANYOF_INVERT;
2356     }
2357     if (!SIZE_ONLY) {
2358         if (FOLD)
2359             flags |= ANYOF_FOLD;
2360         if (LOC)
2361             flags |= ANYOF_LOCALE;
2362         listsv = newSVpvn("# comment\n",10);
2363     }
2364
2365     if (*PL_regcomp_parse == ']' || *PL_regcomp_parse == '-')
2366         goto skipcond;          /* allow 1st char to be ] or - */
2367
2368     while (PL_regcomp_parse < PL_regxend && *PL_regcomp_parse != ']') {
2369        skipcond:
2370         value = utf8_to_uv((U8*)PL_regcomp_parse, &numlen);
2371         PL_regcomp_parse += numlen;
2372
2373         if (value == '[')
2374             (void)regpposixcc(value); /* ignore the return value for now */
2375         else if (value == '\\') {
2376             value = utf8_to_uv((U8*)PL_regcomp_parse, &numlen);
2377             PL_regcomp_parse += numlen;
2378             switch (value) {
2379             case 'w':
2380                 if (!SIZE_ONLY) {
2381                     if (LOC)
2382                         flags |= ANYOF_ALNUML;
2383
2384                     Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsAlnum\n");
2385                 }
2386                 lastvalue = 123456;
2387                 continue;
2388             case 'W':
2389                 if (!SIZE_ONLY) {
2390                     if (LOC)
2391                         flags |= ANYOF_NALNUML;
2392
2393                     Perl_sv_catpvf(aTHX_ listsv,
2394                         "-utf8::IsAlpha\n-utf8::IsDigit\n0000\t%04x\n%04x\tffff\n",
2395                         '_' - 1,
2396                         '_' + 1);
2397                 }
2398                 lastvalue = 123456;
2399                 continue;
2400             case 's':
2401                 if (!SIZE_ONLY) {
2402                     if (LOC)
2403                         flags |= ANYOF_SPACEL;
2404                     Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsSpace\n");
2405                     if (!PL_utf8_space)
2406                         is_utf8_space((U8*)" ");
2407                 }
2408                 lastvalue = 123456;
2409                 continue;
2410             case 'S':
2411                 if (!SIZE_ONLY) {
2412                     if (LOC)
2413                         flags |= ANYOF_NSPACEL;
2414                     Perl_sv_catpvf(aTHX_ listsv,
2415                         "!utf8::IsSpace\n");
2416                     if (!PL_utf8_space)
2417                         is_utf8_space((U8*)" ");
2418                 }
2419                 lastvalue = 123456;
2420                 continue;
2421             case 'd':
2422                 if (!SIZE_ONLY) {
2423                     Perl_sv_catpvf(aTHX_ listsv, "+utf8::IsDigit\n");
2424                 }
2425                 lastvalue = 123456;
2426                 continue;
2427             case 'D':
2428                 if (!SIZE_ONLY) {
2429                     Perl_sv_catpvf(aTHX_ listsv,
2430                         "!utf8::IsDigit\n");
2431                 }
2432                 lastvalue = 123456;
2433                 continue;
2434             case 'p':
2435             case 'P':
2436                 if (*PL_regcomp_parse == '{') {
2437                     e = strchr(PL_regcomp_parse++, '}');
2438                     if (!e)
2439                         FAIL("Missing right brace on \\p{}");
2440                     n = e - PL_regcomp_parse;
2441                 }
2442                 else {
2443                     e = PL_regcomp_parse;
2444                     n = 1;
2445                 }
2446                 if (!SIZE_ONLY) {
2447                     if (value == 'p')
2448                         Perl_sv_catpvf(aTHX_ listsv, "+utf8::%.*s\n", n, PL_regcomp_parse);
2449                     else
2450                         Perl_sv_catpvf(aTHX_ listsv,
2451                             "!utf8::%.*s\n", n, PL_regcomp_parse);
2452                 }
2453                 PL_regcomp_parse = e + 1;
2454                 lastvalue = 123456;
2455                 continue;
2456             case 'n':
2457                 value = '\n';
2458                 break;
2459             case 'r':
2460                 value = '\r';
2461                 break;
2462             case 't':
2463                 value = '\t';
2464                 break;
2465             case 'f':
2466                 value = '\f';
2467                 break;
2468             case 'b':
2469                 value = '\b';
2470                 break;
2471             case 'e':
2472                 value = '\033';
2473                 break;
2474             case 'a':
2475                 value = '\007';
2476                 break;
2477             case 'x':
2478                 if (*PL_regcomp_parse == '{') {
2479                     e = strchr(PL_regcomp_parse++, '}');
2480                     if (!e)
2481                         FAIL("Missing right brace on \\x{}");
2482                     value = scan_hex(PL_regcomp_parse, e - PL_regcomp_parse, &numlen);
2483                     PL_regcomp_parse = e + 1;
2484                 }
2485                 else {
2486                     value = scan_hex(PL_regcomp_parse, 2, &numlen);
2487                     PL_regcomp_parse += numlen;
2488                 }
2489                 break;
2490             case 'c':
2491                 value = UCHARAT(PL_regcomp_parse++);
2492                 value = toCTRL(value);
2493                 break;
2494             case '0': case '1': case '2': case '3': case '4':
2495             case '5': case '6': case '7': case '8': case '9':
2496                 value = scan_oct(--PL_regcomp_parse, 3, &numlen);
2497                 PL_regcomp_parse += numlen;
2498                 break;
2499             }
2500         }
2501         if (range) {
2502             if (lastvalue > value)
2503                 FAIL("invalid [] range in regexp");
2504             if (!SIZE_ONLY)
2505                 Perl_sv_catpvf(aTHX_ listsv, "%04x\t%04x\n", lastvalue, value);
2506             lastvalue = value;
2507             range = 0;
2508         }
2509         else {
2510             lastvalue = value;
2511             if (*PL_regcomp_parse == '-' && PL_regcomp_parse+1 < PL_regxend &&
2512               PL_regcomp_parse[1] != ']') {
2513                 PL_regcomp_parse++;
2514                 range = 1;
2515                 continue;       /* do it next time */
2516             }
2517             if (!SIZE_ONLY)
2518                 Perl_sv_catpvf(aTHX_ listsv, "%04x\n", value);
2519         }
2520     }
2521
2522     ret = reganode(ANYOFUTF8, 0);
2523
2524     if (!SIZE_ONLY) {
2525         SV *rv = swash_init("utf8", "", listsv, 1, 0);
2526         SvREFCNT_dec(listsv);
2527         n = add_data(1,"s");
2528         PL_regcomp_rx->data->data[n] = (void*)rv;
2529         ARG1_SET(ret, flags);
2530         ARG2_SET(ret, n);
2531     }
2532
2533     return ret;
2534 }
2535
2536 STATIC char*
2537 S_nextchar(pTHX)
2538 {
2539     dTHR;
2540     char* retval = PL_regcomp_parse++;
2541
2542     for (;;) {
2543         if (*PL_regcomp_parse == '(' && PL_regcomp_parse[1] == '?' &&
2544                 PL_regcomp_parse[2] == '#') {
2545             while (*PL_regcomp_parse && *PL_regcomp_parse != ')')
2546                 PL_regcomp_parse++;
2547             PL_regcomp_parse++;
2548             continue;
2549         }
2550         if (PL_regflags & PMf_EXTENDED) {
2551             if (isSPACE(*PL_regcomp_parse)) {
2552                 PL_regcomp_parse++;
2553                 continue;
2554             }
2555             else if (*PL_regcomp_parse == '#') {
2556                 while (*PL_regcomp_parse && *PL_regcomp_parse != '\n')
2557                     PL_regcomp_parse++;
2558                 PL_regcomp_parse++;
2559                 continue;
2560             }
2561         }
2562         return retval;
2563     }
2564 }
2565
2566 /*
2567 - reg_node - emit a node
2568 */
2569 STATIC regnode *                        /* Location. */
2570 S_reg_node(pTHX_ U8 op)
2571 {
2572     dTHR;
2573     register regnode *ret;
2574     register regnode *ptr;
2575
2576     ret = PL_regcode;
2577     if (SIZE_ONLY) {
2578         SIZE_ALIGN(PL_regsize);
2579         PL_regsize += 1;
2580         return(ret);
2581     }
2582
2583     NODE_ALIGN_FILL(ret);
2584     ptr = ret;
2585     FILL_ADVANCE_NODE(ptr, op);
2586     PL_regcode = ptr;
2587
2588     return(ret);
2589 }
2590
2591 /*
2592 - reganode - emit a node with an argument
2593 */
2594 STATIC regnode *                        /* Location. */
2595 S_reganode(pTHX_ U8 op, U32 arg)
2596 {
2597     dTHR;
2598     register regnode *ret;
2599     register regnode *ptr;
2600
2601     ret = PL_regcode;
2602     if (SIZE_ONLY) {
2603         SIZE_ALIGN(PL_regsize);
2604         PL_regsize += 2;
2605         return(ret);
2606     }
2607
2608     NODE_ALIGN_FILL(ret);
2609     ptr = ret;
2610     FILL_ADVANCE_NODE_ARG(ptr, op, arg);
2611     PL_regcode = ptr;
2612
2613     return(ret);
2614 }
2615
2616 /*
2617 - regc - emit (if appropriate) a Unicode character
2618 */
2619 STATIC void
2620 S_reguni(pTHX_ UV uv, char* s, I32* lenp)
2621 {
2622     dTHR;
2623     if (SIZE_ONLY) {
2624         U8 tmpbuf[10];
2625         *lenp = uv_to_utf8(tmpbuf, uv) - tmpbuf;
2626     }
2627     else
2628         *lenp = uv_to_utf8((U8*)s, uv) - (U8*)s;
2629
2630 }
2631
2632 /*
2633 - regc - emit (if appropriate) a byte of code
2634 */
2635 STATIC void
2636 S_regc(pTHX_ U8 b, char* s)
2637 {
2638     dTHR;
2639     if (!SIZE_ONLY)
2640         *s = b;
2641 }
2642
2643 /*
2644 - reginsert - insert an operator in front of already-emitted operand
2645 *
2646 * Means relocating the operand.
2647 */
2648 STATIC void
2649 S_reginsert(pTHX_ U8 op, regnode *opnd)
2650 {
2651     dTHR;
2652     register regnode *src;
2653     register regnode *dst;
2654     register regnode *place;
2655     register int offset = regarglen[(U8)op];
2656
2657 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
2658
2659     if (SIZE_ONLY) {
2660         PL_regsize += NODE_STEP_REGNODE + offset;
2661         return;
2662     }
2663
2664     src = PL_regcode;
2665     PL_regcode += NODE_STEP_REGNODE + offset;
2666     dst = PL_regcode;
2667     while (src > opnd)
2668         StructCopy(--src, --dst, regnode);
2669
2670     place = opnd;               /* Op node, where operand used to be. */
2671     src = NEXTOPER(place);
2672     FILL_ADVANCE_NODE(place, op);
2673     Zero(src, offset, regnode);
2674 }
2675
2676 /*
2677 - regtail - set the next-pointer at the end of a node chain of p to val.
2678 */
2679 STATIC void
2680 S_regtail(pTHX_ regnode *p, regnode *val)
2681 {
2682     dTHR;
2683     register regnode *scan;
2684     register regnode *temp;
2685     register I32 offset;
2686
2687     if (SIZE_ONLY)
2688         return;
2689
2690     /* Find last node. */
2691     scan = p;
2692     for (;;) {
2693         temp = regnext(scan);
2694         if (temp == NULL)
2695             break;
2696         scan = temp;
2697     }
2698
2699     if (reg_off_by_arg[OP(scan)]) {
2700         ARG_SET(scan, val - scan);
2701     }
2702     else {
2703         NEXT_OFF(scan) = val - scan;
2704     }
2705 }
2706
2707 /*
2708 - regoptail - regtail on operand of first argument; nop if operandless
2709 */
2710 STATIC void
2711 S_regoptail(pTHX_ regnode *p, regnode *val)
2712 {
2713     dTHR;
2714     /* "Operandless" and "op != BRANCH" are synonymous in practice. */
2715     if (p == NULL || SIZE_ONLY)
2716         return;
2717     if (PL_regkind[(U8)OP(p)] == BRANCH) {
2718         regtail(NEXTOPER(p), val);
2719     }
2720     else if ( PL_regkind[(U8)OP(p)] == BRANCHJ) {
2721         regtail(NEXTOPER(NEXTOPER(p)), val);
2722     }
2723     else
2724         return;
2725 }
2726
2727 /*
2728  - regcurly - a little FSA that accepts {\d+,?\d*}
2729  */
2730 STATIC I32
2731 S_regcurly(pTHX_ register char *s)
2732 {
2733     if (*s++ != '{')
2734         return FALSE;
2735     if (!isDIGIT(*s))
2736         return FALSE;
2737     while (isDIGIT(*s))
2738         s++;
2739     if (*s == ',')
2740         s++;
2741     while (isDIGIT(*s))
2742         s++;
2743     if (*s != '}')
2744         return FALSE;
2745     return TRUE;
2746 }
2747
2748
2749 STATIC regnode *
2750 S_dumpuntil(pTHX_ regnode *start, regnode *node, regnode *last, SV* sv, I32 l)
2751 {
2752 #ifdef DEBUGGING
2753     register char op = EXACT;   /* Arbitrary non-END op. */
2754     register regnode *next, *onode;
2755
2756     while (op != END && (!last || node < last)) {
2757         /* While that wasn't END last time... */
2758
2759         NODE_ALIGN(node);
2760         op = OP(node);
2761         if (op == CLOSE)
2762             l--;
2763         next = regnext(node);
2764         /* Where, what. */
2765         if (OP(node) == OPTIMIZED)
2766             goto after_print;
2767         regprop(sv, node);
2768         PerlIO_printf(Perl_debug_log, "%4d:%*s%s", node - start,
2769                       2*l + 1, "", SvPVX(sv));
2770         if (next == NULL)               /* Next ptr. */
2771             PerlIO_printf(Perl_debug_log, "(0)");
2772         else
2773             PerlIO_printf(Perl_debug_log, "(%d)", next - start);
2774         (void)PerlIO_putc(Perl_debug_log, '\n');
2775       after_print:
2776         if (PL_regkind[(U8)op] == BRANCHJ) {
2777             register regnode *nnode = (OP(next) == LONGJMP
2778                                        ? regnext(next)
2779                                        : next);
2780             if (last && nnode > last)
2781                 nnode = last;
2782             node = dumpuntil(start, NEXTOPER(NEXTOPER(node)), nnode, sv, l + 1);
2783         }
2784         else if (PL_regkind[(U8)op] == BRANCH) {
2785             node = dumpuntil(start, NEXTOPER(node), next, sv, l + 1);
2786         }
2787         else if ( op == CURLY) {   /* `next' might be very big: optimizer */
2788             node = dumpuntil(start, NEXTOPER(node) + EXTRA_STEP_2ARGS,
2789                              NEXTOPER(node) + EXTRA_STEP_2ARGS + 1, sv, l + 1);
2790         }
2791         else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
2792             node = dumpuntil(start, NEXTOPER(node) + EXTRA_STEP_2ARGS,
2793                              next, sv, l + 1);
2794         }
2795         else if ( op == PLUS || op == STAR) {
2796             node = dumpuntil(start, NEXTOPER(node), NEXTOPER(node) + 1, sv, l + 1);
2797         }
2798         else if (op == ANYOF) {
2799             node = NEXTOPER(node);
2800             node += ANY_SKIP;
2801         }
2802         else if (PL_regkind[(U8)op] == EXACT) {
2803             /* Literal string, where present. */
2804             node += ((*OPERAND(node)) + 2 + sizeof(regnode) - 1) / sizeof(regnode);
2805             node = NEXTOPER(node);
2806         }
2807         else {
2808             node = NEXTOPER(node);
2809             node += regarglen[(U8)op];
2810         }
2811         if (op == CURLYX || op == OPEN)
2812             l++;
2813         else if (op == WHILEM)
2814             l--;
2815     }
2816 #endif  /* DEBUGGING */
2817     return node;
2818 }
2819
2820 /*
2821  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
2822  */
2823 void
2824 Perl_regdump(pTHX_ regexp *r)
2825 {
2826 #ifdef DEBUGGING
2827     dTHR;
2828     SV *sv = sv_newmortal();
2829
2830     (void)dumpuntil(r->program, r->program + 1, NULL, sv, 0);
2831
2832     /* Header fields of interest. */
2833     if (r->anchored_substr)
2834         PerlIO_printf(Perl_debug_log, "anchored `%s%s%s'%s at %d ",
2835                       PL_colors[0],
2836                       SvPVX(r->anchored_substr),
2837                       PL_colors[1],
2838                       SvTAIL(r->anchored_substr) ? "$" : "",
2839                       r->anchored_offset);
2840     if (r->float_substr)
2841         PerlIO_printf(Perl_debug_log, "floating `%s%s%s'%s at %d..%u ",
2842                       PL_colors[0],
2843                       SvPVX(r->float_substr),
2844                       PL_colors[1],
2845                       SvTAIL(r->float_substr) ? "$" : "",
2846                       r->float_min_offset, r->float_max_offset);
2847     if (r->check_substr)
2848         PerlIO_printf(Perl_debug_log,
2849                       r->check_substr == r->float_substr
2850                       ? "(checking floating" : "(checking anchored");
2851     if (r->reganch & ROPT_NOSCAN)
2852         PerlIO_printf(Perl_debug_log, " noscan");
2853     if (r->reganch & ROPT_CHECK_ALL)
2854         PerlIO_printf(Perl_debug_log, " isall");
2855     if (r->check_substr)
2856         PerlIO_printf(Perl_debug_log, ") ");
2857
2858     if (r->regstclass) {
2859         regprop(sv, r->regstclass);
2860         PerlIO_printf(Perl_debug_log, "stclass `%s' ", SvPVX(sv));
2861     }
2862     if (r->reganch & ROPT_ANCH) {
2863         PerlIO_printf(Perl_debug_log, "anchored");
2864         if (r->reganch & ROPT_ANCH_BOL)
2865             PerlIO_printf(Perl_debug_log, "(BOL)");
2866         if (r->reganch & ROPT_ANCH_MBOL)
2867             PerlIO_printf(Perl_debug_log, "(MBOL)");
2868         if (r->reganch & ROPT_ANCH_SBOL)
2869             PerlIO_printf(Perl_debug_log, "(SBOL)");
2870         if (r->reganch & ROPT_ANCH_GPOS)
2871             PerlIO_printf(Perl_debug_log, "(GPOS)");
2872         PerlIO_putc(Perl_debug_log, ' ');
2873     }
2874     if (r->reganch & ROPT_GPOS_SEEN)
2875         PerlIO_printf(Perl_debug_log, "GPOS ");
2876     if (r->reganch & ROPT_SKIP)
2877         PerlIO_printf(Perl_debug_log, "plus ");
2878     if (r->reganch & ROPT_IMPLICIT)
2879         PerlIO_printf(Perl_debug_log, "implicit ");
2880     PerlIO_printf(Perl_debug_log, "minlen %ld ", (long) r->minlen);
2881     if (r->reganch & ROPT_EVAL_SEEN)
2882         PerlIO_printf(Perl_debug_log, "with eval ");
2883     PerlIO_printf(Perl_debug_log, "\n");
2884 #endif  /* DEBUGGING */
2885 }
2886
2887 /*
2888 - regprop - printable representation of opcode
2889 */
2890 void
2891 Perl_regprop(pTHX_ SV *sv, regnode *o)
2892 {
2893 #ifdef DEBUGGING
2894     dTHR;
2895     register int k;
2896
2897     sv_setpvn(sv, "", 0);
2898     if (OP(o) >= reg_num)               /* regnode.type is unsigned */
2899         FAIL("corrupted regexp opcode");
2900     sv_catpv(sv, (char*)reg_name[OP(o)]); /* Take off const! */
2901
2902     k = PL_regkind[(U8)OP(o)];
2903
2904     if (k == EXACT)
2905         Perl_sv_catpvf(aTHX_ sv, " <%s%s%s>", PL_colors[0], OPERAND(o) + 1, PL_colors[1]);
2906     else if (k == CURLY) {
2907         if (OP(o) == CURLYM || OP(o) == CURLYN)
2908             Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
2909         Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
2910     }
2911     else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP )
2912         Perl_sv_catpvf(aTHX_ sv, "%d", ARG(o)); /* Parenth number */
2913     else if (k == LOGICAL)
2914         Perl_sv_catpvf(aTHX_ sv, "[%d]", ARG(o));       /* 2: embedded, otherwise 1 */
2915     else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
2916         Perl_sv_catpvf(aTHX_ sv, "[-%d]", o->flags);
2917 #endif  /* DEBUGGING */
2918 }
2919
2920 SV *
2921 Perl_re_intuit_string(pTHX_ regexp *prog)
2922 {                               /* Assume that RE_INTUIT is set */
2923     DEBUG_r(
2924         {   STRLEN n_a;
2925             char *s = SvPV(prog->check_substr,n_a);
2926
2927             if (!PL_colorset) reginitcolors();
2928             PerlIO_printf(Perl_debug_log,
2929                       "%sUsing REx substr:%s `%s%.60s%s%s'\n",
2930                       PL_colors[4],PL_colors[5],PL_colors[0],
2931                       s,
2932                       PL_colors[1],
2933                       (strlen(s) > 60 ? "..." : ""));
2934         } );
2935
2936     return prog->check_substr;
2937 }
2938
2939 void
2940 Perl_pregfree(pTHX_ struct regexp *r)
2941 {
2942     dTHR;
2943     DEBUG_r(PerlIO_printf(Perl_debug_log,
2944                       "%sFreeing REx:%s `%s%.60s%s%s'\n",
2945                       PL_colors[4],PL_colors[5],PL_colors[0],
2946                       r->precomp,
2947                       PL_colors[1],
2948                       (strlen(r->precomp) > 60 ? "..." : "")));
2949
2950
2951     if (!r || (--r->refcnt > 0))
2952         return;
2953     if (r->precomp)
2954         Safefree(r->precomp);
2955     if (RX_MATCH_COPIED(r))
2956         Safefree(r->subbeg);
2957     if (r->substrs) {
2958         if (r->anchored_substr)
2959             SvREFCNT_dec(r->anchored_substr);
2960         if (r->float_substr)
2961             SvREFCNT_dec(r->float_substr);
2962         Safefree(r->substrs);
2963     }
2964     if (r->data) {
2965         int n = r->data->count;
2966         AV* new_comppad = NULL;
2967         AV* old_comppad;
2968         SV** old_curpad;
2969
2970         while (--n >= 0) {
2971             switch (r->data->what[n]) {
2972             case 's':
2973                 SvREFCNT_dec((SV*)r->data->data[n]);
2974                 break;
2975             case 'p':
2976                 new_comppad = (AV*)r->data->data[n];
2977                 break;
2978             case 'o':
2979                 if (new_comppad == NULL)
2980                     Perl_croak(aTHX_ "panic: pregfree comppad");
2981                 old_comppad = PL_comppad;
2982                 old_curpad = PL_curpad;
2983                 PL_comppad = new_comppad;
2984                 PL_curpad = AvARRAY(new_comppad);
2985                 op_free((OP_4tree*)r->data->data[n]);
2986                 PL_comppad = old_comppad;
2987                 PL_curpad = old_curpad;
2988                 SvREFCNT_dec((SV*)new_comppad);
2989                 new_comppad = NULL;
2990                 break;
2991             case 'n':
2992                 break;
2993             default:
2994                 FAIL2("panic: regfree data code '%c'", r->data->what[n]);
2995             }
2996         }
2997         Safefree(r->data->what);
2998         Safefree(r->data);
2999     }
3000     Safefree(r->startp);
3001     Safefree(r->endp);
3002     Safefree(r);
3003 }
3004
3005 /*
3006  - regnext - dig the "next" pointer out of a node
3007  *
3008  * [Note, when REGALIGN is defined there are two places in regmatch()
3009  * that bypass this code for speed.]
3010  */
3011 regnode *
3012 Perl_regnext(pTHX_ register regnode *p)
3013 {
3014     dTHR;
3015     register I32 offset;
3016
3017     if (p == &PL_regdummy)
3018         return(NULL);
3019
3020     offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
3021     if (offset == 0)
3022         return(NULL);
3023
3024     return(p+offset);
3025 }
3026
3027 STATIC void
3028 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
3029 {
3030     va_list args;
3031     STRLEN l1 = strlen(pat1);
3032     STRLEN l2 = strlen(pat2);
3033     char buf[512];
3034     SV *msv;
3035     char *message;
3036
3037     if (l1 > 510)
3038         l1 = 510;
3039     if (l1 + l2 > 510)
3040         l2 = 510 - l1;
3041     Copy(pat1, buf, l1 , char);
3042     Copy(pat2, buf + l1, l2 , char);
3043     buf[l1 + l2] = '\n';
3044     buf[l1 + l2 + 1] = '\0';
3045 #ifdef I_STDARG
3046     /* ANSI variant takes additional second argument */
3047     va_start(args, pat2);
3048 #else
3049     va_start(args);
3050 #endif
3051     msv = mess(buf, &args);
3052     va_end(args);
3053     message = SvPV(msv,l1);
3054     if (l1 > 512)
3055         l1 = 512;
3056     Copy(message, buf, l1 , char);
3057     buf[l1] = '\0';                     /* Overwrite \n */
3058     Perl_croak(aTHX_ "%s", buf);
3059 }
3060
3061 /* XXX Here's a total kludge.  But we need to re-enter for swash routines. */
3062
3063 void
3064 Perl_save_re_context(pTHX)
3065 {
3066     dTHR;
3067     SAVEPPTR(PL_bostr);
3068     SAVEPPTR(PL_regprecomp);            /* uncompiled string. */
3069     SAVEI32(PL_regnpar);                /* () count. */
3070     SAVEI32(PL_regsize);                /* Code size. */
3071     SAVEI16(PL_regflags);               /* are we folding, multilining? */
3072     SAVEPPTR(PL_reginput);              /* String-input pointer. */
3073     SAVEPPTR(PL_regbol);                /* Beginning of input, for ^ check. */
3074     SAVEPPTR(PL_regeol);                /* End of input, for $ check. */
3075     SAVESPTR(PL_regstartp);             /* Pointer to startp array. */
3076     SAVESPTR(PL_regendp);               /* Ditto for endp. */
3077     SAVESPTR(PL_reglastparen);          /* Similarly for lastparen. */
3078     SAVEPPTR(PL_regtill);               /* How far we are required to go. */
3079     SAVEI32(PL_regprev);                /* char before regbol, \n if none */
3080     SAVESPTR(PL_reg_start_tmp);         /* from regexec.c */
3081     PL_reg_start_tmp = 0;
3082     SAVEFREEPV(PL_reg_start_tmp);
3083     SAVEI32(PL_reg_start_tmpl);         /* from regexec.c */
3084     PL_reg_start_tmpl = 0;
3085     SAVESPTR(PL_regdata);
3086     SAVEI32(PL_reg_flags);              /* from regexec.c */
3087     SAVEI32(PL_reg_eval_set);           /* from regexec.c */
3088     SAVEI32(PL_regnarrate);             /* from regexec.c */
3089     SAVESPTR(PL_regprogram);            /* from regexec.c */
3090     SAVEINT(PL_regindent);              /* from regexec.c */
3091     SAVESPTR(PL_regcc);                 /* from regexec.c */
3092     SAVESPTR(PL_curcop);
3093     SAVESPTR(PL_regcomp_rx);            /* from regcomp.c */
3094     SAVEI32(PL_regseen);                /* from regcomp.c */
3095     SAVEI32(PL_regsawback);             /* Did we see \1, ...? */
3096     SAVEI32(PL_regnaughty);             /* How bad is this pattern? */
3097     SAVESPTR(PL_regcode);               /* Code-emit pointer; &regdummy = don't */
3098     SAVEPPTR(PL_regxend);               /* End of input for compile */
3099     SAVEPPTR(PL_regcomp_parse);         /* Input-scan pointer. */
3100     SAVESPTR(PL_reg_call_cc);           /* from regexec.c */
3101     SAVESPTR(PL_reg_re);                /* from regexec.c */
3102     SAVEPPTR(PL_reg_ganch);             /* from regexec.c */
3103     SAVESPTR(PL_reg_sv);                /* from regexec.c */
3104     SAVESPTR(PL_reg_magic);             /* from regexec.c */
3105     SAVEI32(PL_reg_oldpos);                     /* from regexec.c */
3106     SAVESPTR(PL_reg_oldcurpm);          /* from regexec.c */
3107     SAVESPTR(PL_reg_curpm);             /* from regexec.c */
3108 #ifdef DEBUGGING
3109     SAVEPPTR(PL_reg_starttry);          /* from regexec.c */
3110 #endif
3111 }