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 /*SUPPRESS 112*/
  23 /*
  24  * pregcomp and pregexec -- regsub and regerror are not used in perl
  25  *
  26  *      Copyright (c) 1986 by University of Toronto.
  27  *      Written by Henry Spencer.  Not derived from licensed software.
  28  *
  29  *      Permission is granted to anyone to use this software for any
  30  *      purpose on any computer system, and to redistribute it freely,
  31  *      subject to the following restrictions:
  32  *
  33  *      1. The author is not responsible for the consequences of use of
  34  *              this software, no matter how awful, even if they arise
  35  *              from defects in it.
  36  *
  37  *      2. The origin of this software must not be misrepresented, either
  38  *              by explicit claim or by omission.
  39  *
  40  *      3. Altered versions must be plainly marked as such, and must not
  41  *              be misrepresented as being the original software.
  42  *
  43  *
  44  ****    Alterations to Henry's code are...
  45  ****
  46  ****    Copyright (c) 1991-1997, Larry Wall
  47  ****
  48  ****    You may distribute under the terms of either the GNU General Public
  49  ****    License or the Artistic License, as specified in the README file.
  50
  51  *
  52  * Beware that some of this code is subtly aware of the way operator
  53  * precedence is structured in regular expressions.  Serious changes in
  54  * regular-expression syntax might require a total rethink.
  55  */
  56 #include "EXTERN.h"
  57 #include "perl.h"
  58 #include "INTERN.h"
  59 #include "regcomp.h"
  60
  61 #ifdef MSDOS
  62 # if defined(BUGGY_MSC6)
  63  /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
  64  # pragma optimize("a",off)
  65  /* But MSC 6.00A is happy with 'w', for aliases only across function calls*/
  66  # pragma optimize("w",on )
  67 # endif /* BUGGY_MSC6 */
  68 #endif /* MSDOS */
  69
  70 #ifndef STATIC
  71 #define STATIC  static
  72 #endif
  73
  74 #define ISMULT1(c)      ((c) == '*' || (c) == '+' || (c) == '?')
  75 #define ISMULT2(s)      ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
  76         ((*s) == '{' && regcurly(s)))
  77 #ifdef atarist
  78 #define PERL_META       "^$.[()|?+*\\"
  79 #else
  80 #define META    "^$.[()|?+*\\"
  81 #endif
  82
  83 #ifdef SPSTART
  84 #undef SPSTART          /* dratted cpp namespace... */
  85 #endif
  86 /*
  87  * Flags to be passed up and down.
  88  */
  89 #define WORST           0       /* Worst case. */
  90 #define HASWIDTH        0x1     /* Known never to match null string. */
  91 #define SIMPLE          0x2     /* Simple enough to be STAR/PLUS operand. */
  92 #define SPSTART         0x4     /* Starts with * or +. */
  93 #define TRYAGAIN        0x8     /* Weeded out a declaration. */
  94
  95 /*
  96  * Forward declarations for pregcomp()'s friends.
  97  */
  98
  99 static char *reg _((I32, I32 *));
 100 static char *reganode _((char, unsigned short));
 101 static char *regatom _((I32 *));
 102 static char *regbranch _((I32 *));
 103 static void regc _((char));
 104 static char *regclass _((void));
 105 STATIC I32 regcurly _((char *));
 106 static char *regnode _((char));
 107 static char *regpiece _((I32 *));
 108 static void reginsert _((char, char *));
 109 static void regoptail _((char *, char *));
 110 static void regtail _((char *, char *));
 111 static char* regwhite _((char *, char *));
 112 static char* nextchar _((void));
 113
 114 /*
 115  - pregcomp - compile a regular expression into internal code
 116  *
 117  * We can't allocate space until we know how big the compiled form will be,
 118  * but we can't compile it (and thus know how big it is) until we've got a
 119  * place to put the code.  So we cheat:  we compile it twice, once with code
 120  * generation turned off and size counting turned on, and once "for real".
 121  * This also means that we don't allocate space until we are sure that the
 122  * thing really will compile successfully, and we never have to move the
 123  * code and thus invalidate pointers into it.  (Note that it has to be in
 124  * one piece because free() must be able to free it all.) [NB: not true in perl]
 125  *
 126  * Beware that the optimization-preparation code in here knows about some
 127  * of the structure of the compiled regexp.  [I'll say.]
 128  */
 129 regexp *
 130 pregcomp(exp,xend,pm)
 131 char* exp;
 132 char* xend;
 133 PMOP* pm;
 134 {
 135     register regexp *r;
 136     register char *scan;
 137     register SV *longish;
 138     SV *longest;
 139     register I32 len;
 140     register char *first;
 141     I32 flags;
 142     I32 backish;
 143     I32 backest;
 144     I32 curback;
 145     I32 minlen = 0;
 146     I32 sawplus = 0;
 147     I32 sawopen = 0;
 148 #define MAX_REPEAT_DEPTH 12
 149     struct {
 150         char *opcode;
 151         I32 count;
 152     } repeat_stack[MAX_REPEAT_DEPTH];
 153     I32 repeat_depth = 0;
 154     I32 repeat_count = 1;       /* We start unmultiplied. */
 155
 156     if (exp == NULL)
 157         croak("NULL regexp argument");
 158
 159     regprecomp = savepvn(exp, xend - exp);
 160     regflags = pm->op_pmflags;
 161     regsawback = 0;
 162
 163     /* First pass: determine size, legality. */
 164     regparse = exp;
 165     regxend = xend;
 166     regnaughty = 0;
 167     regnpar = 1;
 168     regsize = 0L;
 169     regcode = &regdummy;
 170     regc((char)MAGIC);
 171     if (reg(0, &flags) == NULL) {
 172         Safefree(regprecomp);
 173         regprecomp = Nullch;
 174         return(NULL);
 175     }
 176
 177     /* Small enough for pointer-storage convention? */
 178     if (regsize >= 32767L)              /* Probably could be 65535L. */
 179         FAIL("regexp too big");
 180
 181     /* Allocate space and initialize. */
 182     Newc(1001, r, sizeof(regexp) + (unsigned)regsize, char, regexp);
 183     if (r == NULL)
 184         FAIL("regexp out of space");
 185     r->prelen = xend - exp;
 186     r->precomp = regprecomp;
 187     r->subbeg = r->subbase = NULL;
 188
 189     /* Second pass: emit code. */
 190     regparse = exp;
 191     regxend = xend;
 192     regnaughty = 0;
 193     regnpar = 1;
 194     regcode = r->program;
 195     regc((char)MAGIC);
 196     if (reg(0, &flags) == NULL)
 197         return(NULL);
 198
 199     /* Dig out information for optimizations. */
 200     pm->op_pmflags = regflags;
 201     r->regstart = Nullsv;       /* Worst-case defaults. */
 202     r->reganch = 0;
 203     r->regmust = Nullsv;
 204     r->regback = -1;
 205     r->regstclass = Nullch;
 206     r->naughty = regnaughty >= 10;      /* Probably an expensive pattern. */
 207     scan = r->program+1;                        /* First BRANCH. */
 208     if (OP(regnext(scan)) == END) {/* Only one top-level choice. */
 209         scan = NEXTOPER(scan);
 210
 211         first = scan;
 212         while ((OP(first) == OPEN && (sawopen = 1)) ||
 213             (OP(first) == BRANCH && OP(regnext(first)) != BRANCH) ||
 214             (OP(first) == PLUS) ||
 215             (OP(first) == MINMOD) ||
 216             (regkind[(U8)OP(first)] == CURLY && ARG1(first) > 0) ) {
 217                 if (OP(first) == PLUS)
 218                     sawplus = 1;
 219                 else
 220                     first += regarglen[(U8)OP(first)];
 221                 first = NEXTOPER(first);
 222         }
 223
 224         /* Starting-point info. */
 225       again:
 226         if (OP(first) == EXACT) {
 227             r->regstart = newSVpv(OPERAND(first)+1,*OPERAND(first));
 228             if (SvCUR(r->regstart) > !sawstudy)
 229                 fbm_compile(r->regstart);
 230             (void)SvUPGRADE(r->regstart, SVt_PVBM);
 231         }
 232         else if (strchr(simple+2,OP(first)))
 233             r->regstclass = first;
 234         else if (regkind[(U8)OP(first)] == BOUND ||
 235                  regkind[(U8)OP(first)] == NBOUND)
 236             r->regstclass = first;
 237         else if (regkind[(U8)OP(first)] == BOL) {
 238             r->reganch |= ROPT_ANCH_BOL;
 239             first = NEXTOPER(first);
 240             goto again;
 241         }
 242         else if (OP(first) == GPOS) {
 243             r->reganch |= ROPT_ANCH_GPOS;
 244             first = NEXTOPER(first);
 245             goto again;
 246         }
 247         else if ((OP(first) == STAR &&
 248             regkind[(U8)OP(NEXTOPER(first))] == ANY) &&
 249             !(r->reganch & ROPT_ANCH) )
 250         {
 251             /* turn .* into ^.* with an implied $*=1 */
 252             r->reganch |= ROPT_ANCH_BOL | ROPT_IMPLICIT;
 253             first = NEXTOPER(first);
 254             goto again;
 255         }
 256         if (sawplus && (!sawopen || !regsawback))
 257             r->reganch |= ROPT_SKIP;    /* x+ must match 1st of run */
 258
 259         DEBUG_r(PerlIO_printf(Perl_debug_log, "first %d next %d offset %ld\n",
 260            OP(first), OP(NEXTOPER(first)), (long)(first - scan)));
 261         /*
 262         * If there's something expensive in the r.e., find the
 263         * longest literal string that must appear and make it the
 264         * regmust.  Resolve ties in favor of later strings, since
 265         * the regstart check works with the beginning of the r.e.
 266         * and avoiding duplication strengthens checking.  Not a
 267         * strong reason, but sufficient in the absence of others.
 268         * [Now we resolve ties in favor of the earlier string if
 269         * it happens that curback has been invalidated, since the
 270         * earlier string may buy us something the later one won't.]
 271         */
 272         longish = newSVpv("",0);
 273         longest = newSVpv("",0);
 274         len = 0;
 275         minlen = 0;
 276         curback = 0;
 277         backish = 0;
 278         backest = 0;
 279         while (OP(scan) != END) {
 280             if (OP(scan) == BRANCH) {
 281                 if (OP(regnext(scan)) == BRANCH) {
 282                     curback = -30000;
 283                     while (OP(scan) == BRANCH)
 284                         scan = regnext(scan);
 285                 }
 286                 else    /* single branch is ok */
 287                     scan = NEXTOPER(scan);
 288                 continue;
 289             }
 290             if (OP(scan) == UNLESSM) {
 291                 curback = -30000;
 292                 scan = regnext(scan);
 293                 continue;
 294             }
 295             if (OP(scan) == EXACT) {
 296                 char *t;
 297
 298                 first = scan;
 299                 while ((t = regnext(scan)) && OP(t) == CLOSE)
 300                     scan = t;
 301                 minlen += *OPERAND(first) * repeat_count;
 302                 if (curback - backish == len) {
 303                     sv_catpvn(longish, OPERAND(first)+1,
 304                         *OPERAND(first));
 305                     len += *OPERAND(first);
 306                     curback += *OPERAND(first);
 307                     first = regnext(scan);
 308                 }
 309                 else if (*OPERAND(first) >= len + (curback >= 0)) {
 310                     len = *OPERAND(first);
 311                     sv_setpvn(longish, OPERAND(first)+1,len);
 312                     backish = curback;
 313                     curback += len;
 314                     first = regnext(scan);
 315                 }
 316                 else
 317                     curback += *OPERAND(first);
 318             }
 319             else if (strchr(varies,OP(scan))) {
 320                 int tcount;
 321                 char *next;
 322
 323                 if (repeat_depth < MAX_REPEAT_DEPTH
 324                     && ((OP(scan) == PLUS
 325                          && (tcount = 1)
 326                          && (next = NEXTOPER(scan)))
 327                         || (regkind[(U8)OP(scan)] == CURLY
 328                             && (tcount = ARG1(scan))
 329                             && (next = NEXTOPER(scan)+4))))
 330                 {
 331                     /* We treat (abc)+ as (abc)(abc)*. */
 332
 333                     /* Mark the place to return back. */
 334                     repeat_stack[repeat_depth].opcode = regnext(scan);
 335                     repeat_stack[repeat_depth].count = repeat_count;
 336                     repeat_depth++;
 337                     repeat_count *= tcount;
 338
 339                     /* Go deeper: */
 340                     scan = next;
 341                     continue;
 342                 }
 343                 else {
 344                     curback = -30000;
 345                     len = 0;
 346                     if (SvCUR(longish) > SvCUR(longest)) {
 347                         sv_setsv(longest,longish);
 348                         backest = backish;
 349                     }
 350                     sv_setpvn(longish,"",0);
 351                 }
 352             }
 353             else if (strchr(simple,OP(scan))) {
 354                 curback++;
 355                 minlen += repeat_count;
 356                 len = 0;
 357                 if (SvCUR(longish) > SvCUR(longest)) {
 358                     sv_setsv(longest,longish);
 359                     backest = backish;
 360                 }
 361                 sv_setpvn(longish,"",0);
 362             }
 363             scan = regnext(scan);
 364             if (!scan) {                /* Go up PLUS or CURLY. */
 365                 if (!repeat_depth--)
 366                     croak("panic: re scan");
 367                 scan = repeat_stack[repeat_depth].opcode;
 368                 repeat_count = repeat_stack[repeat_depth].count;
 369                 /* Need to submit the longest string found: */
 370                 curback = -30000;
 371                 len = 0;
 372                 if (SvCUR(longish) > SvCUR(longest)) {
 373                     sv_setsv(longest,longish);
 374                     backest = backish;
 375                 }
 376                 sv_setpvn(longish,"",0);
 377             }
 378         }
 379
 380         /* Prefer earlier on tie, unless we can tail match latter */
 381
 382         if (SvCUR(longish) + (first && regkind[(U8)OP(first)] == EOL)
 383                 > SvCUR(longest))
 384         {
 385             sv_setsv(longest,longish);
 386             backest = backish;
 387         }
 388         else
 389             sv_setpvn(longish,"",0);
 390         if (SvCUR(longest)
 391             && (!r->regstart
 392                 || !fbm_instr((unsigned char*) SvPVX(r->regstart),
 393                               (unsigned char *) (SvPVX(r->regstart)
 394                                                  + SvCUR(r->regstart)),
 395                               longest)))
 396         {
 397             r->regmust = longest;
 398             if (backest < 0)
 399                 backest = -1;
 400             r->regback = backest;
 401             if (SvCUR(longest) > !(sawstudy ||
 402                                    (first && regkind[(U8)OP(first)] == EOL)))
 403                 fbm_compile(r->regmust);
 404             (void)SvUPGRADE(r->regmust, SVt_PVBM);
 405             BmUSEFUL(r->regmust) = 100;
 406             if (first && regkind[(U8)OP(first)] == EOL && SvCUR(longish))
 407                 SvTAIL_on(r->regmust);
 408         }
 409         else {
 410             SvREFCNT_dec(longest);
 411             longest = Nullsv;
 412         }
 413         SvREFCNT_dec(longish);
 414     }
 415
 416     r->nparens = regnpar - 1;
 417     r->minlen = minlen;
 418     Newz(1002, r->startp, regnpar, char*);
 419     Newz(1002, r->endp, regnpar, char*);
 420     DEBUG_r(regdump(r));
 421     return(r);
 422 }
 423
 424 /*
 425  - reg - regular expression, i.e. main body or parenthesized thing
 426  *
 427  * Caller must absorb opening parenthesis.
 428  *
 429  * Combining parenthesis handling with the base level of regular expression
 430  * is a trifle forced, but the need to tie the tails of the branches to what
 431  * follows makes it hard to avoid.
 432  */
 433 static char *
 434 reg(paren, flagp)
 435 I32 paren;                      /* Parenthesized? */
 436 I32 *flagp;
 437 {
 438     register char *ret;
 439     register char *br;
 440     register char *ender = 0;
 441     register I32 parno = 0;
 442     I32 flags;
 443
 444     *flagp = HASWIDTH;  /* Tentatively. */
 445
 446     /* Make an OPEN node, if parenthesized. */
 447     if (paren) {
 448         if (*regparse == '?') {
 449             regparse++;
 450             paren = *regparse++;
 451             ret = NULL;
 452             switch (paren) {
 453             case ':':
 454             case '=':
 455             case '!':
 456                 break;
 457             case '$':
 458             case '@':
 459                 croak("Sequence (?%c...) not implemented", (int)paren);
 460                 break;
 461             case '#':
 462                 while (*regparse && *regparse != ')')
 463                     regparse++;
 464                 if (*regparse != ')')
 465                     croak("Sequence (?#... not terminated");
 466                 nextchar();
 467                 *flagp = TRYAGAIN;
 468                 return NULL;
 469             case 0:
 470                 croak("Sequence (? incomplete");
 471                 break;
 472             default:
 473                 --regparse;
 474                 while (*regparse && strchr("iogcmsx", *regparse))
 475                     pmflag(&regflags, *regparse++);
 476                 if (*regparse != ')')
 477                     croak("Sequence (?%c...) not recognized", *regparse);
 478                 nextchar();
 479                 *flagp = TRYAGAIN;
 480                 return NULL;
 481             }
 482         }
 483         else {
 484             parno = regnpar;
 485             regnpar++;
 486             ret = reganode(OPEN, parno);
 487         }
 488     } else
 489         ret = NULL;
 490
 491     /* Pick up the branches, linking them together. */
 492     br = regbranch(&flags);
 493     if (br == NULL)
 494         return(NULL);
 495     if (ret != NULL)
 496         regtail(ret, br);       /* OPEN -> first. */
 497     else
 498         ret = br;
 499     if (!(flags&HASWIDTH))
 500         *flagp &= ~HASWIDTH;
 501     *flagp |= flags&SPSTART;
 502     while (*regparse == '|') {
 503         nextchar();
 504         br = regbranch(&flags);
 505         if (br == NULL)
 506             return(NULL);
 507         regtail(ret, br);       /* BRANCH -> BRANCH. */
 508         if (!(flags&HASWIDTH))
 509             *flagp &= ~HASWIDTH;
 510         *flagp |= flags&SPSTART;
 511     }
 512
 513     /* Make a closing node, and hook it on the end. */
 514     switch (paren) {
 515     case ':':
 516         ender = regnode(NOTHING);
 517         break;
 518     case 1:
 519         ender = reganode(CLOSE, parno);
 520         break;
 521     case '=':
 522     case '!':
 523         ender = regnode(SUCCEED);
 524         *flagp &= ~HASWIDTH;
 525         break;
 526     case 0:
 527         ender = regnode(END);
 528         break;
 529     }
 530     regtail(ret, ender);
 531
 532     /* Hook the tails of the branches to the closing node. */
 533     for (br = ret; br != NULL; br = regnext(br))
 534         regoptail(br, ender);
 535
 536     if (paren == '=') {
 537         reginsert(IFMATCH,ret);
 538         regtail(ret, regnode(NOTHING));
 539     }
 540     else if (paren == '!') {
 541         reginsert(UNLESSM,ret);
 542         regtail(ret, regnode(NOTHING));
 543     }
 544
 545     /* Check for proper termination. */
 546     if (paren && (regparse >= regxend || *nextchar() != ')')) {
 547         FAIL("unmatched () in regexp");
 548     } else if (!paren && regparse < regxend) {
 549         if (*regparse == ')') {
 550             FAIL("unmatched () in regexp");
 551         } else
 552             FAIL("junk on end of regexp");      /* "Can't happen". */
 553         /* NOTREACHED */
 554     }
 555
 556     return(ret);
 557 }
 558
 559 /*
 560  - regbranch - one alternative of an | operator
 561  *
 562  * Implements the concatenation operator.
 563  */
 564 static char *
 565 regbranch(flagp)
 566 I32 *flagp;
 567 {
 568     register char *ret;
 569     register char *chain;
 570     register char *latest;
 571     I32 flags = 0;
 572
 573     *flagp = WORST;             /* Tentatively. */
 574
 575     ret = regnode(BRANCH);
 576     chain = NULL;
 577     regparse--;
 578     nextchar();
 579     while (regparse < regxend && *regparse != '|' && *regparse != ')') {
 580         flags &= ~TRYAGAIN;
 581         latest = regpiece(&flags);
 582         if (latest == NULL) {
 583             if (flags & TRYAGAIN)
 584                 continue;
 585             return(NULL);
 586         }
 587         *flagp |= flags&HASWIDTH;
 588         if (chain == NULL)      /* First piece. */
 589             *flagp |= flags&SPSTART;
 590         else {
 591             regnaughty++;
 592             regtail(chain, latest);
 593         }
 594         chain = latest;
 595     }
 596     if (chain == NULL)  /* Loop ran zero times. */
 597         (void) regnode(NOTHING);
 598
 599     return(ret);
 600 }
 601
 602 /*
 603  - regpiece - something followed by possible [*+?]
 604  *
 605  * Note that the branching code sequences used for ? and the general cases
 606  * of * and + are somewhat optimized:  they use the same NOTHING node as
 607  * both the endmarker for their branch list and the body of the last branch.
 608  * It might seem that this node could be dispensed with entirely, but the
 609  * endmarker role is not redundant.
 610  */
 611 static char *
 612 regpiece(flagp)
 613 I32 *flagp;
 614 {
 615     register char *ret;
 616     register char op;
 617     register char *next;
 618     I32 flags;
 619     char *origparse = regparse;
 620     char *maxpos;
 621     I32 min;
 622     I32 max = 32767;
 623
 624     ret = regatom(&flags);
 625     if (ret == NULL) {
 626         if (flags & TRYAGAIN)
 627             *flagp |= TRYAGAIN;
 628         return(NULL);
 629     }
 630
 631     op = *regparse;
 632     if (op == '(' && regparse[1] == '?' && regparse[2] == '#') {
 633         while (op && op != ')')
 634             op = *++regparse;
 635         if (op) {
 636             nextchar();
 637             op = *regparse;
 638         }
 639     }
 640
 641     if (op == '{' && regcurly(regparse)) {
 642         next = regparse + 1;
 643         maxpos = Nullch;
 644         while (isDIGIT(*next) || *next == ',') {
 645             if (*next == ',') {
 646                 if (maxpos)
 647                     break;
 648                 else
 649                     maxpos = next;
 650             }
 651             next++;
 652         }
 653         if (*next == '}') {             /* got one */
 654             if (!maxpos)
 655                 maxpos = next;
 656             regparse++;
 657             min = atoi(regparse);
 658             if (*maxpos == ',')
 659                 maxpos++;
 660             else
 661                 maxpos = regparse;
 662             max = atoi(maxpos);
 663             if (!max && *maxpos != '0')
 664                 max = 32767;            /* meaning "infinity" */
 665             regparse = next;
 666             nextchar();
 667
 668         do_curly:
 669             if ((flags&SIMPLE)) {
 670                 regnaughty += 2 + regnaughty / 2;
 671                 reginsert(CURLY, ret);
 672             }
 673             else {
 674                 regnaughty += 4 + regnaughty;   /* compound interest */
 675                 regtail(ret, regnode(WHILEM));
 676                 reginsert(CURLYX,ret);
 677                 regtail(ret, regnode(NOTHING));
 678             }
 679
 680             if (min > 0)
 681                 *flagp = (WORST|HASWIDTH);
 682             if (max && max < min)
 683                 croak("Can't do {n,m} with n > m");
 684             if (regcode != &regdummy) {
 685 #ifdef REGALIGN
 686                 *(unsigned short *)(ret+3) = min;
 687                 *(unsigned short *)(ret+5) = max;
 688 #else
 689                 ret[3] = min >> 8; ret[4] = min & 0377;
 690                 ret[5] = max  >> 8; ret[6] = max  & 0377;
 691 #endif
 692             }
 693
 694             goto nest_check;
 695         }
 696     }
 697
 698     if (!ISMULT1(op)) {
 699         *flagp = flags;
 700         return(ret);
 701     }
 702
 703     if (!(flags&HASWIDTH) && op != '?')
 704       FAIL("regexp *+ operand could be empty"); /* else may core dump */
 705
 706     nextchar();
 707
 708     *flagp = (op != '+') ? (WORST|SPSTART) : (WORST|HASWIDTH);
 709
 710     if (op == '*' && (flags&SIMPLE)) {
 711         reginsert(STAR, ret);
 712         regnaughty += 4;
 713     }
 714     else if (op == '*') {
 715         min = 0;
 716         goto do_curly;
 717     } else if (op == '+' && (flags&SIMPLE)) {
 718         reginsert(PLUS, ret);
 719         regnaughty += 3;
 720     }
 721     else if (op == '+') {
 722         min = 1;
 723         goto do_curly;
 724     } else if (op == '?') {
 725         min = 0; max = 1;
 726         goto do_curly;
 727     }
 728   nest_check:
 729     if (dowarn && regcode != &regdummy && !(flags&HASWIDTH) && max > 10000) {
 730         warn("%.*s matches null string many times",
 731             regparse - origparse, origparse);
 732     }
 733
 734     if (*regparse == '?') {
 735         nextchar();
 736         reginsert(MINMOD, ret);
 737 #ifdef REGALIGN
 738         regtail(ret, ret + 4);
 739 #else
 740         regtail(ret, ret + 3);
 741 #endif
 742     }
 743     if (ISMULT2(regparse))
 744         FAIL("nested *?+ in regexp");
 745
 746     return(ret);
 747 }
 748
 749 /*
 750  - regatom - the lowest level
 751  *
 752  * Optimization:  gobbles an entire sequence of ordinary characters so that
 753  * it can turn them into a single node, which is smaller to store and
 754  * faster to run.  Backslashed characters are exceptions, each becoming a
 755  * separate node; the code is simpler that way and it's not worth fixing.
 756  *
 757  * [Yes, it is worth fixing, some scripts can run twice the speed.]
 758  */
 759 static char *
 760 regatom(flagp)
 761 I32 *flagp;
 762 {
 763     register char *ret = 0;
 764     I32 flags;
 765
 766     *flagp = WORST;             /* Tentatively. */
 767
 768 tryagain:
 769     switch (*regparse) {
 770     case '^':
 771         nextchar();
 772         if (regflags & PMf_MULTILINE)
 773             ret = regnode(MBOL);
 774         else if (regflags & PMf_SINGLELINE)
 775             ret = regnode(SBOL);
 776         else
 777             ret = regnode(BOL);
 778         break;
 779     case '$':
 780         nextchar();
 781         if (regflags & PMf_MULTILINE)
 782             ret = regnode(MEOL);
 783         else if (regflags & PMf_SINGLELINE)
 784             ret = regnode(SEOL);
 785         else
 786             ret = regnode(EOL);
 787         break;
 788     case '.':
 789         nextchar();
 790         if (regflags & PMf_SINGLELINE)
 791             ret = regnode(SANY);
 792         else
 793             ret = regnode(ANY);
 794         regnaughty++;
 795         *flagp |= HASWIDTH|SIMPLE;
 796         break;
 797     case '[':
 798         regparse++;
 799         ret = regclass();
 800         *flagp |= HASWIDTH|SIMPLE;
 801         break;
 802     case '(':
 803         nextchar();
 804         ret = reg(1, &flags);
 805         if (ret == NULL) {
 806                 if (flags & TRYAGAIN)
 807                     goto tryagain;
 808                 return(NULL);
 809         }
 810         *flagp |= flags&(HASWIDTH|SPSTART);
 811         break;
 812     case '|':
 813     case ')':
 814         if (flags & TRYAGAIN) {
 815             *flagp |= TRYAGAIN;
 816             return NULL;
 817         }
 818         croak("internal urp in regexp at /%s/", regparse);
 819                                 /* Supposed to be caught earlier. */
 820         break;
 821     case '{':
 822         if (!regcurly(regparse)) {
 823             regparse++;
 824             goto defchar;
 825         }
 826         /* FALL THROUGH */
 827     case '?':
 828     case '+':
 829     case '*':
 830         FAIL("?+*{} follows nothing in regexp");
 831         break;
 832     case '\\':
 833         switch (*++regparse) {
 834         case 'A':
 835             ret = regnode(SBOL);
 836             *flagp |= SIMPLE;
 837             nextchar();
 838             break;
 839         case 'G':
 840             ret = regnode(GPOS);
 841             *flagp |= SIMPLE;
 842             nextchar();
 843             break;
 844         case 'Z':
 845             ret = regnode(SEOL);
 846             *flagp |= SIMPLE;
 847             nextchar();
 848             break;
 849         case 'w':
 850             ret = regnode((regflags & PMf_LOCALE) ? ALNUML : ALNUM);
 851             *flagp |= HASWIDTH|SIMPLE;
 852             nextchar();
 853             break;
 854         case 'W':
 855             ret = regnode((regflags & PMf_LOCALE) ? NALNUML : NALNUM);
 856             *flagp |= HASWIDTH|SIMPLE;
 857             nextchar();
 858             break;
 859         case 'b':
 860             ret = regnode((regflags & PMf_LOCALE) ? BOUNDL : BOUND);
 861             *flagp |= SIMPLE;
 862             nextchar();
 863             break;
 864         case 'B':
 865             ret = regnode((regflags & PMf_LOCALE) ? NBOUNDL : NBOUND);
 866             *flagp |= SIMPLE;
 867             nextchar();
 868             break;
 869         case 's':
 870             ret = regnode((regflags & PMf_LOCALE) ? SPACEL : SPACE);
 871             *flagp |= HASWIDTH|SIMPLE;
 872             nextchar();
 873             break;
 874         case 'S':
 875             ret = regnode((regflags & PMf_LOCALE) ? NSPACEL : NSPACE);
 876             *flagp |= HASWIDTH|SIMPLE;
 877             nextchar();
 878             break;
 879         case 'd':
 880             ret = regnode(DIGIT);
 881             *flagp |= HASWIDTH|SIMPLE;
 882             nextchar();
 883             break;
 884         case 'D':
 885             ret = regnode(NDIGIT);
 886             *flagp |= HASWIDTH|SIMPLE;
 887             nextchar();
 888             break;
 889         case 'n':
 890         case 'r':
 891         case 't':
 892         case 'f':
 893         case 'e':
 894         case 'a':
 895         case 'x':
 896         case 'c':
 897         case '0':
 898             goto defchar;
 899         case '1': case '2': case '3': case '4':
 900         case '5': case '6': case '7': case '8': case '9':
 901             {
 902                 I32 num = atoi(regparse);
 903
 904                 if (num > 9 && num >= regnpar)
 905                     goto defchar;
 906                 else {
 907                     regsawback = 1;
 908                     ret = reganode((regflags & PMf_FOLD)
 909                                    ? ((regflags & PMf_LOCALE) ? REFFL : REFF)
 910                                    : REF, num);
 911                     *flagp |= HASWIDTH;
 912                     while (isDIGIT(*regparse))
 913                         regparse++;
 914                     regparse--;
 915                     nextchar();
 916                 }
 917             }
 918             break;
 919         case '\0':
 920             if (regparse >= regxend)
 921                 FAIL("trailing \\ in regexp");
 922             /* FALL THROUGH */
 923         default:
 924             goto defchar;
 925         }
 926         break;
 927
 928     case '#':
 929         if (regflags & PMf_EXTENDED) {
 930             while (regparse < regxend && *regparse != '\n') regparse++;
 931             if (regparse < regxend)
 932                 goto tryagain;
 933         }
 934         /* FALL THROUGH */
 935
 936     default: {
 937             register I32 len;
 938             register char ender;
 939             register char *p;
 940             char *oldp;
 941             I32 numlen;
 942
 943             regparse++;
 944
 945         defchar:
 946             ret = regnode((regflags & PMf_FOLD)
 947                           ? ((regflags & PMf_LOCALE) ? EXACTFL : EXACTF)
 948                           : EXACT);
 949             regc(0);            /* save spot for len */
 950             for (len = 0, p = regparse - 1;
 951               len < 127 && p < regxend;
 952               len++)
 953             {
 954                 oldp = p;
 955
 956                 if (regflags & PMf_EXTENDED)
 957                     p = regwhite(p, regxend);
 958                 switch (*p) {
 959                 case '^':
 960                 case '$':
 961                 case '.':
 962                 case '[':
 963                 case '(':
 964                 case ')':
 965                 case '|':
 966                     goto loopdone;
 967                 case '\\':
 968                     switch (*++p) {
 969                     case 'A':
 970                     case 'G':
 971                     case 'Z':
 972                     case 'w':
 973                     case 'W':
 974                     case 'b':
 975                     case 'B':
 976                     case 's':
 977                     case 'S':
 978                     case 'd':
 979                     case 'D':
 980                         --p;
 981                         goto loopdone;
 982                     case 'n':
 983                         ender = '\n';
 984                         p++;
 985                         break;
 986                     case 'r':
 987                         ender = '\r';
 988                         p++;
 989                         break;
 990                     case 't':
 991                         ender = '\t';
 992                         p++;
 993                         break;
 994                     case 'f':
 995                         ender = '\f';
 996                         p++;
 997                         break;
 998                     case 'e':
 999                         ender = '\033';
1000                         p++;
1001                         break;
1002                     case 'a':
1003                         ender = '\007';
1004                         p++;
1005                         break;
1006                     case 'x':
1007                         ender = scan_hex(++p, 2, &numlen);
1008                         p += numlen;
1009                         break;
1010                     case 'c':
1011                         p++;
1012                         ender = UCHARAT(p++);
1013                         ender = toCTRL(ender);
1014                         break;
1015                     case '0': case '1': case '2': case '3':case '4':
1016                     case '5': case '6': case '7': case '8':case '9':
1017                         if (*p == '0' ||
1018                           (isDIGIT(p[1]) && atoi(p) >= regnpar) ) {
1019                             ender = scan_oct(p, 3, &numlen);
1020                             p += numlen;
1021                         }
1022                         else {
1023                             --p;
1024                             goto loopdone;
1025                         }
1026                         break;
1027                     case '\0':
1028                         if (p >= regxend)
1029                             FAIL("trailing \\ in regexp");
1030                         /* FALL THROUGH */
1031                     default:
1032                         ender = *p++;
1033                         break;
1034                     }
1035                     break;
1036                 default:
1037                     ender = *p++;
1038                     break;
1039                 }
1040                 if (regflags & PMf_EXTENDED)
1041                     p = regwhite(p, regxend);
1042                 if (ISMULT2(p)) { /* Back off on ?+*. */
1043                     if (len)
1044                         p = oldp;
1045                     else {
1046                         len++;
1047                         regc(ender);
1048                     }
1049                     break;
1050                 }
1051                 regc(ender);
1052             }
1053         loopdone:
1054             regparse = p - 1;
1055             nextchar();
1056             if (len < 0)
1057                 FAIL("internal disaster in regexp");
1058             if (len > 0)
1059                 *flagp |= HASWIDTH;
1060             if (len == 1)
1061                 *flagp |= SIMPLE;
1062             if (regcode != &regdummy)
1063                 *OPERAND(ret) = len;
1064             regc('\0');
1065         }
1066         break;
1067     }
1068
1069     return(ret);
1070 }
1071
1072 static char *
1073 regwhite(p, e)
1074 char *p;
1075 char *e;
1076 {
1077     while (p < e) {
1078         if (isSPACE(*p))
1079             ++p;
1080         else if (*p == '#') {
1081             do {
1082                 p++;
1083             } while (p < e && *p != '\n');
1084         }
1085         else
1086             break;
1087     }
1088     return p;
1089 }
1090
1091 static char *
1092 regclass()
1093 {
1094     register char *opnd;
1095     register I32 class;
1096     register I32 lastclass = 1234;
1097     register I32 range = 0;
1098     register char *ret;
1099     register I32 def;
1100     I32 numlen;
1101
1102     ret = regnode(ANYOF);
1103     opnd = regcode;
1104     for (class = 0; class < 33; class++)
1105         regc(0);
1106     if (*regparse == '^') {     /* Complement of range. */
1107         regnaughty++;
1108         regparse++;
1109         if (opnd != &regdummy)
1110             *opnd |= ANYOF_INVERT;
1111     }
1112     if (opnd != &regdummy) {
1113         if (regflags & PMf_FOLD)
1114             *opnd |= ANYOF_FOLD;
1115         if (regflags & PMf_LOCALE)
1116             *opnd |= ANYOF_LOCALE;
1117     }
1118     if (*regparse == ']' || *regparse == '-')
1119         goto skipcond;          /* allow 1st char to be ] or - */
1120     while (regparse < regxend && *regparse != ']') {
1121        skipcond:
1122         class = UCHARAT(regparse++);
1123         if (class == '\\') {
1124             class = UCHARAT(regparse++);
1125             switch (class) {
1126             case 'w':
1127                 if (opnd != &regdummy) {
1128                     if (regflags & PMf_LOCALE)
1129                         *opnd |= ANYOF_ALNUML;
1130                     else {
1131                         for (class = 0; class < 256; class++)
1132                             if (isALNUM(class))
1133                                 ANYOF_SET(opnd, class);
1134                     }
1135                 }
1136                 lastclass = 1234;
1137                 continue;
1138             case 'W':
1139                 if (opnd != &regdummy) {
1140                     if (regflags & PMf_LOCALE)
1141                         *opnd |= ANYOF_NALNUML;
1142                     else {
1143                         for (class = 0; class < 256; class++)
1144                             if (!isALNUM(class))
1145                                 ANYOF_SET(opnd, class);
1146                     }
1147                 }
1148                 lastclass = 1234;
1149                 continue;
1150             case 's':
1151                 if (opnd != &regdummy) {
1152                     if (regflags & PMf_LOCALE)
1153                         *opnd |= ANYOF_SPACEL;
1154                     else {
1155                         for (class = 0; class < 256; class++)
1156                             if (isSPACE(class))
1157                                 ANYOF_SET(opnd, class);
1158                     }
1159                 }
1160                 lastclass = 1234;
1161                 continue;
1162             case 'S':
1163                 if (opnd != &regdummy) {
1164                     if (regflags & PMf_LOCALE)
1165                         *opnd |= ANYOF_NSPACEL;
1166                     else {
1167                         for (class = 0; class < 256; class++)
1168                             if (!isSPACE(class))
1169                                 ANYOF_SET(opnd, class);
1170                     }
1171                 }
1172                 lastclass = 1234;
1173                 continue;
1174             case 'd':
1175                 if (opnd != &regdummy) {
1176                     for (class = '0'; class <= '9'; class++)
1177                         ANYOF_SET(opnd, class);
1178                 }
1179                 lastclass = 1234;
1180                 continue;
1181             case 'D':
1182                 if (opnd != &regdummy) {
1183                     for (class = 0; class < '0'; class++)
1184                         ANYOF_SET(opnd, class);
1185                     for (class = '9' + 1; class < 256; class++)
1186                         ANYOF_SET(opnd, class);
1187                 }
1188                 lastclass = 1234;
1189                 continue;
1190             case 'n':
1191                 class = '\n';
1192                 break;
1193             case 'r':
1194                 class = '\r';
1195                 break;
1196             case 't':
1197                 class = '\t';
1198                 break;
1199             case 'f':
1200                 class = '\f';
1201                 break;
1202             case 'b':
1203                 class = '\b';
1204                 break;
1205             case 'e':
1206                 class = '\033';
1207                 break;
1208             case 'a':
1209                 class = '\007';
1210                 break;
1211             case 'x':
1212                 class = scan_hex(regparse, 2, &numlen);
1213                 regparse += numlen;
1214                 break;
1215             case 'c':
1216                 class = UCHARAT(regparse++);
1217                 class = toCTRL(class);
1218                 break;
1219             case '0': case '1': case '2': case '3': case '4':
1220             case '5': case '6': case '7': case '8': case '9':
1221                 class = scan_oct(--regparse, 3, &numlen);
1222                 regparse += numlen;
1223                 break;
1224             }
1225         }
1226         if (range) {
1227             if (lastclass > class)
1228                 FAIL("invalid [] range in regexp");
1229             range = 0;
1230         }
1231         else {
1232             lastclass = class;
1233             if (*regparse == '-' && regparse+1 < regxend &&
1234               regparse[1] != ']') {
1235                 regparse++;
1236                 range = 1;
1237                 continue;       /* do it next time */
1238             }
1239         }
1240         if (opnd != &regdummy) {
1241             for ( ; lastclass <= class; lastclass++)
1242                 ANYOF_SET(opnd, lastclass);
1243         }
1244         lastclass = class;
1245     }
1246     if (*regparse != ']')
1247         FAIL("unmatched [] in regexp");
1248     nextchar();
1249     /* optimize case-insensitive simple patterns (e.g. /[a-z]/i) */
1250     if (opnd != &regdummy && (*opnd & (0xFF ^ ANYOF_INVERT)) == ANYOF_FOLD) {
1251         for (class = 0; class < 256; ++class) {
1252             if (ANYOF_TEST(opnd, class)) {
1253                 I32 cf = fold[class];
1254                 ANYOF_SET(opnd, cf);
1255             }
1256         }
1257         *opnd &= ~ANYOF_FOLD;
1258     }
1259     /* optimize inverted simple patterns (e.g. [^a-z]) */
1260     if (opnd != &regdummy && (*opnd & 0xFF) == ANYOF_INVERT) {
1261         for (class = 0; class < 32; ++class)
1262             opnd[1 + class] ^= 0xFF;
1263         *opnd = 0;
1264     }
1265     return ret;
1266 }
1267
1268 static char*
1269 nextchar()
1270 {
1271     char* retval = regparse++;
1272
1273     for (;;) {
1274         if (*regparse == '(' && regparse[1] == '?' &&
1275                 regparse[2] == '#') {
1276             while (*regparse && *regparse != ')')
1277                 regparse++;
1278             regparse++;
1279             continue;
1280         }
1281         if (regflags & PMf_EXTENDED) {
1282             if (isSPACE(*regparse)) {
1283                 regparse++;
1284                 continue;
1285             }
1286             else if (*regparse == '#') {
1287                 while (*regparse && *regparse != '\n')
1288                     regparse++;
1289                 regparse++;
1290                 continue;
1291             }
1292         }
1293         return retval;
1294     }
1295 }
1296
1297 /*
1298 - regnode - emit a node
1299 */
1300 #ifdef CAN_PROTOTYPE
1301 static char *                   /* Location. */
1302 regnode(char op)
1303 #else
1304 static char *                   /* Location. */
1305 regnode(op)
1306 char op;
1307 #endif
1308 {
1309     register char *ret;
1310     register char *ptr;
1311
1312     ret = regcode;
1313     if (ret == &regdummy) {
1314 #ifdef REGALIGN
1315         if (!(regsize & 1))
1316             regsize++;
1317 #endif
1318         regsize += 3;
1319         return(ret);
1320     }
1321
1322 #ifdef REGALIGN
1323 #ifndef lint
1324     if (!((long)ret & 1))
1325       *ret++ = 127;
1326 #endif
1327 #endif
1328     ptr = ret;
1329     *ptr++ = op;
1330     *ptr++ = '\0';              /* Null "next" pointer. */
1331     *ptr++ = '\0';
1332     regcode = ptr;
1333
1334     return(ret);
1335 }
1336
1337 /*
1338 - reganode - emit a node with an argument
1339 */
1340 #ifdef CAN_PROTOTYPE
1341 static char *                   /* Location. */
1342 reganode(char op, unsigned short arg)
1343 #else
1344 static char *                   /* Location. */
1345 reganode(op, arg)
1346 char op;
1347 unsigned short arg;
1348 #endif
1349 {
1350     register char *ret;
1351     register char *ptr;
1352
1353     ret = regcode;
1354     if (ret == &regdummy) {
1355 #ifdef REGALIGN
1356         if (!(regsize & 1))
1357             regsize++;
1358 #endif
1359         regsize += 5;
1360         return(ret);
1361     }
1362
1363 #ifdef REGALIGN
1364 #ifndef lint
1365     if (!((long)ret & 1))
1366       *ret++ = 127;
1367 #endif
1368 #endif
1369     ptr = ret;
1370     *ptr++ = op;
1371     *ptr++ = '\0';              /* Null "next" pointer. */
1372     *ptr++ = '\0';
1373 #ifdef REGALIGN
1374     *(unsigned short *)(ret+3) = arg;
1375 #else
1376     ret[3] = arg >> 8; ret[4] = arg & 0377;
1377 #endif
1378     ptr += 2;
1379     regcode = ptr;
1380
1381     return(ret);
1382 }
1383
1384 /*
1385 - regc - emit (if appropriate) a byte of code
1386 */
1387 #ifdef CAN_PROTOTYPE
1388 static void
1389 regc(char b)
1390 #else
1391 static void
1392 regc(b)
1393 char b;
1394 #endif
1395 {
1396     if (regcode != &regdummy)
1397         *regcode++ = b;
1398     else
1399         regsize++;
1400 }
1401
1402 /*
1403 - reginsert - insert an operator in front of already-emitted operand
1404 *
1405 * Means relocating the operand.
1406 */
1407 #ifdef CAN_PROTOTYPE
1408 static void
1409 reginsert(char op, char *opnd)
1410 #else
1411 static void
1412 reginsert(op, opnd)
1413 char op;
1414 char *opnd;
1415 #endif
1416 {
1417     register char *src;
1418     register char *dst;
1419     register char *place;
1420     register int offset = (regkind[(U8)op] == CURLY ? 4 : 0);
1421
1422     if (regcode == &regdummy) {
1423 #ifdef REGALIGN
1424         regsize += 4 + offset;
1425 #else
1426         regsize += 3 + offset;
1427 #endif
1428         return;
1429     }
1430
1431     src = regcode;
1432 #ifdef REGALIGN
1433     regcode += 4 + offset;
1434 #else
1435     regcode += 3 + offset;
1436 #endif
1437     dst = regcode;
1438     while (src > opnd)
1439         *--dst = *--src;
1440
1441     place = opnd;               /* Op node, where operand used to be. */
1442     *place++ = op;
1443     *place++ = '\0';
1444     *place++ = '\0';
1445     while (offset-- > 0)
1446         *place++ = '\0';
1447 #ifdef REGALIGN
1448     *place++ = '\177';
1449 #endif
1450 }
1451
1452 /*
1453 - regtail - set the next-pointer at the end of a node chain
1454 */
1455 static void
1456 regtail(p, val)
1457 char *p;
1458 char *val;
1459 {
1460     register char *scan;
1461     register char *temp;
1462     register I32 offset;
1463
1464     if (p == &regdummy)
1465         return;
1466
1467     /* Find last node. */
1468     scan = p;
1469     for (;;) {
1470         temp = regnext(scan);
1471         if (temp == NULL)
1472             break;
1473         scan = temp;
1474     }
1475
1476 #ifdef REGALIGN
1477     offset = val - scan;
1478 #ifndef lint
1479     *(short*)(scan+1) = offset;
1480 #else
1481     offset = offset;
1482 #endif
1483 #else
1484     if (OP(scan) == BACK)
1485         offset = scan - val;
1486     else
1487         offset = val - scan;
1488     *(scan+1) = (offset>>8)&0377;
1489     *(scan+2) = offset&0377;
1490 #endif
1491 }
1492
1493 /*
1494 - regoptail - regtail on operand of first argument; nop if operandless
1495 */
1496 static void
1497 regoptail(p, val)
1498 char *p;
1499 char *val;
1500 {
1501     /* "Operandless" and "op != BRANCH" are synonymous in practice. */
1502     if (p == NULL || p == &regdummy || regkind[(U8)OP(p)] != BRANCH)
1503         return;
1504     regtail(NEXTOPER(p), val);
1505 }
1506
1507 /*
1508  - regcurly - a little FSA that accepts {\d+,?\d*}
1509  */
1510 STATIC I32
1511 regcurly(s)
1512 register char *s;
1513 {
1514     if (*s++ != '{')
1515         return FALSE;
1516     if (!isDIGIT(*s))
1517         return FALSE;
1518     while (isDIGIT(*s))
1519         s++;
1520     if (*s == ',')
1521         s++;
1522     while (isDIGIT(*s))
1523         s++;
1524     if (*s != '}')
1525         return FALSE;
1526     return TRUE;
1527 }
1528
1529 #ifdef DEBUGGING
1530
1531 /*
1532  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
1533  */
1534 void
1535 regdump(r)
1536 regexp *r;
1537 {
1538     register char *s;
1539     register char op = EXACT;   /* Arbitrary non-END op. */
1540     register char *next;
1541     SV *sv = sv_newmortal();
1542
1543     s = r->program + 1;
1544     while (op != END) { /* While that wasn't END last time... */
1545 #ifdef REGALIGN
1546         if (!((long)s & 1))
1547             s++;
1548 #endif
1549         op = OP(s);
1550         /* where, what */
1551         regprop(sv, s);
1552         PerlIO_printf(Perl_debug_log, "%2ld%s", (long)(s - r->program), SvPVX(sv));
1553         next = regnext(s);
1554         s += regarglen[(U8)op];
1555         if (next == NULL)               /* Next ptr. */
1556             PerlIO_printf(Perl_debug_log, "(0)");
1557         else
1558             PerlIO_printf(Perl_debug_log, "(%ld)", (long)(s-r->program)+(next-s));
1559         s += 3;
1560         if (op == ANYOF) {
1561             s += 33;
1562         }
1563         if (regkind[(U8)op] == EXACT) {
1564             /* Literal string, where present. */
1565             s++;
1566             (void)PerlIO_putc(Perl_debug_log, ' ');
1567             (void)PerlIO_putc(Perl_debug_log, '<');
1568             while (*s != '\0') {
1569                 (void)PerlIO_putc(Perl_debug_log,*s);
1570                 s++;
1571             }
1572             (void)PerlIO_putc(Perl_debug_log, '>');
1573             s++;
1574         }
1575         (void)PerlIO_putc(Perl_debug_log, '\n');
1576     }
1577
1578     /* Header fields of interest. */
1579     if (r->regstart)
1580         PerlIO_printf(Perl_debug_log, "start `%s' ", SvPVX(r->regstart));
1581     if (r->regstclass) {
1582         regprop(sv, r->regstclass);
1583         PerlIO_printf(Perl_debug_log, "stclass `%s' ", SvPVX(sv));
1584     }
1585     if (r->reganch & ROPT_ANCH) {
1586         PerlIO_printf(Perl_debug_log, "anchored");
1587         if (r->reganch & ROPT_ANCH_BOL)
1588             PerlIO_printf(Perl_debug_log, "(BOL)");
1589         if (r->reganch & ROPT_ANCH_GPOS)
1590             PerlIO_printf(Perl_debug_log, "(GPOS)");
1591         PerlIO_putc(Perl_debug_log, ' ');
1592     }
1593     if (r->reganch & ROPT_SKIP)
1594         PerlIO_printf(Perl_debug_log, "plus ");
1595     if (r->reganch & ROPT_IMPLICIT)
1596         PerlIO_printf(Perl_debug_log, "implicit ");
1597     if (r->regmust != NULL)
1598         PerlIO_printf(Perl_debug_log, "must have \"%s\" back %ld ", SvPVX(r->regmust),
1599          (long) r->regback);
1600     PerlIO_printf(Perl_debug_log, "minlen %ld ", (long) r->minlen);
1601     PerlIO_printf(Perl_debug_log, "\n");
1602 }
1603
1604 /*
1605 - regprop - printable representation of opcode
1606 */
1607 void
1608 regprop(sv, op)
1609 SV *sv;
1610 char *op;
1611 {
1612     register char *p = 0;
1613
1614     sv_setpv(sv, ":");
1615     switch (OP(op)) {
1616     case BOL:
1617         p = "BOL";
1618         break;
1619     case MBOL:
1620         p = "MBOL";
1621         break;
1622     case SBOL:
1623         p = "SBOL";
1624         break;
1625     case EOL:
1626         p = "EOL";
1627         break;
1628     case MEOL:
1629         p = "MEOL";
1630         break;
1631     case SEOL:
1632         p = "SEOL";
1633         break;
1634     case ANY:
1635         p = "ANY";
1636         break;
1637     case SANY:
1638         p = "SANY";
1639         break;
1640     case ANYOF:
1641         p = "ANYOF";
1642         break;
1643     case BRANCH:
1644         p = "BRANCH";
1645         break;
1646     case EXACT:
1647         p = "EXACT";
1648         break;
1649     case EXACTF:
1650         p = "EXACTF";
1651         break;
1652     case EXACTFL:
1653         p = "EXACTFL";
1654         break;
1655     case NOTHING:
1656         p = "NOTHING";
1657         break;
1658     case BACK:
1659         p = "BACK";
1660         break;
1661     case END:
1662         p = "END";
1663         break;
1664     case BOUND:
1665         p = "BOUND";
1666         break;
1667     case BOUNDL:
1668         p = "BOUNDL";
1669         break;
1670     case NBOUND:
1671         p = "NBOUND";
1672         break;
1673     case NBOUNDL:
1674         p = "NBOUNDL";
1675         break;
1676     case CURLY:
1677         sv_catpvf(sv, "CURLY {%d,%d}", ARG1(op), ARG2(op));
1678         break;
1679     case CURLYX:
1680         sv_catpvf(sv, "CURLYX {%d,%d}", ARG1(op), ARG2(op));
1681         break;
1682     case REF:
1683         sv_catpvf(sv, "REF%d", ARG1(op));
1684         break;
1685     case REFF:
1686         sv_catpvf(sv, "REFF%d", ARG1(op));
1687         break;
1688     case REFFL:
1689         sv_catpvf(sv, "REFFL%d", ARG1(op));
1690         break;
1691     case OPEN:
1692         sv_catpvf(sv, "OPEN%d", ARG1(op));
1693         break;
1694     case CLOSE:
1695         sv_catpvf(sv, "CLOSE%d", ARG1(op));
1696         p = NULL;
1697         break;
1698     case STAR:
1699         p = "STAR";
1700         break;
1701     case PLUS:
1702         p = "PLUS";
1703         break;
1704     case MINMOD:
1705         p = "MINMOD";
1706         break;
1707     case GPOS:
1708         p = "GPOS";
1709         break;
1710     case UNLESSM:
1711         p = "UNLESSM";
1712         break;
1713     case IFMATCH:
1714         p = "IFMATCH";
1715         break;
1716     case SUCCEED:
1717         p = "SUCCEED";
1718         break;
1719     case WHILEM:
1720         p = "WHILEM";
1721         break;
1722     case DIGIT:
1723         p = "DIGIT";
1724         break;
1725     case NDIGIT:
1726         p = "NDIGIT";
1727         break;
1728     case ALNUM:
1729         p = "ALNUM";
1730         break;
1731     case NALNUM:
1732         p = "NALNUM";
1733         break;
1734     case SPACE:
1735         p = "SPACE";
1736         break;
1737     case NSPACE:
1738         p = "NSPACE";
1739         break;
1740     case ALNUML:
1741         p = "ALNUML";
1742         break;
1743     case NALNUML:
1744         p = "NALNUML";
1745         break;
1746     case SPACEL:
1747         p = "SPACEL";
1748         break;
1749     case NSPACEL:
1750         p = "NSPACEL";
1751         break;
1752     default:
1753         FAIL("corrupted regexp opcode");
1754     }
1755     if (p)
1756         sv_catpv(sv, p);
1757 }
1758 #endif /* DEBUGGING */
1759
1760 void
1761 pregfree(r)
1762 struct regexp *r;
1763 {
1764     if (!r)
1765         return;
1766     if (r->precomp) {
1767         Safefree(r->precomp);
1768         r->precomp = Nullch;
1769     }
1770     if (r->subbase) {
1771         Safefree(r->subbase);
1772         r->subbase = Nullch;
1773     }
1774     if (r->regmust) {
1775         SvREFCNT_dec(r->regmust);
1776         r->regmust = Nullsv;
1777     }
1778     if (r->regstart) {
1779         SvREFCNT_dec(r->regstart);
1780         r->regstart = Nullsv;
1781     }
1782     Safefree(r->startp);
1783     Safefree(r->endp);
1784     Safefree(r);
1785 }