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