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