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