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