Fix C< $x=''; pos($x)=0; $x=~/\G$/ >
[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-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("iogmsx", *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(REF, num);
907                     *flagp |= HASWIDTH;
908                     while (isDIGIT(*regparse))
909                         regparse++;
910                     regparse--;
911                     nextchar();
912                 }
913             }
914             break;
915         case '\0':
916             if (regparse >= regxend)
917                 FAIL("trailing \\ in regexp");
918             /* FALL THROUGH */
919         default:
920             goto defchar;
921         }
922         break;
923
924     case '#':
925         if (regflags & PMf_EXTENDED) {
926             while (regparse < regxend && *regparse != '\n') regparse++;
927             if (regparse < regxend)
928                 goto tryagain;
929         }
930         /* FALL THROUGH */
931
932     default: {
933             register I32 len;
934             register char ender;
935             register char *p;
936             char *oldp;
937             I32 numlen;
938
939             regparse++;
940
941         defchar:
942             ret = regnode((regflags & PMf_FOLD)
943                           ? ((regflags & PMf_LOCALE) ? EXACTFL : EXACTF)
944                           : EXACT);
945             regc(0);            /* save spot for len */
946             for (len = 0, p = regparse - 1;
947               len < 127 && p < regxend;
948               len++)
949             {
950                 oldp = p;
951
952                 if (regflags & PMf_EXTENDED)
953                     p = regwhite(p, regxend);
954                 switch (*p) {
955                 case '^':
956                 case '$':
957                 case '.':
958                 case '[':
959                 case '(':
960                 case ')':
961                 case '|':
962                     goto loopdone;
963                 case '\\':
964                     switch (*++p) {
965                     case 'A':
966                     case 'G':
967                     case 'Z':
968                     case 'w':
969                     case 'W':
970                     case 'b':
971                     case 'B':
972                     case 's':
973                     case 'S':
974                     case 'd':
975                     case 'D':
976                         --p;
977                         goto loopdone;
978                     case 'n':
979                         ender = '\n';
980                         p++;
981                         break;
982                     case 'r':
983                         ender = '\r';
984                         p++;
985                         break;
986                     case 't':
987                         ender = '\t';
988                         p++;
989                         break;
990                     case 'f':
991                         ender = '\f';
992                         p++;
993                         break;
994                     case 'e':
995                         ender = '\033';
996                         p++;
997                         break;
998                     case 'a':
999                         ender = '\007';
1000                         p++;
1001                         break;
1002                     case 'x':
1003                         ender = scan_hex(++p, 2, &numlen);
1004                         p += numlen;
1005                         break;
1006                     case 'c':
1007                         p++;
1008                         ender = UCHARAT(p++);
1009                         ender = toCTRL(ender);
1010                         break;
1011                     case '0': case '1': case '2': case '3':case '4':
1012                     case '5': case '6': case '7': case '8':case '9':
1013                         if (*p == '0' ||
1014                           (isDIGIT(p[1]) && atoi(p) >= regnpar) ) {
1015                             ender = scan_oct(p, 3, &numlen);
1016                             p += numlen;
1017                         }
1018                         else {
1019                             --p;
1020                             goto loopdone;
1021                         }
1022                         break;
1023                     case '\0':
1024                         if (p >= regxend)
1025                             FAIL("trailing \\ in regexp");
1026                         /* FALL THROUGH */
1027                     default:
1028                         ender = *p++;
1029                         break;
1030                     }
1031                     break;
1032                 default:
1033                     ender = *p++;
1034                     break;
1035                 }
1036                 if (regflags & PMf_EXTENDED)
1037                     p = regwhite(p, regxend);
1038                 if (ISMULT2(p)) { /* Back off on ?+*. */
1039                     if (len)
1040                         p = oldp;
1041                     else {
1042                         len++;
1043                         regc(ender);
1044                     }
1045                     break;
1046                 }
1047                 regc(ender);
1048             }
1049         loopdone:
1050             regparse = p - 1;
1051             nextchar();
1052             if (len < 0)
1053                 FAIL("internal disaster in regexp");
1054             if (len > 0)
1055                 *flagp |= HASWIDTH;
1056             if (len == 1)
1057                 *flagp |= SIMPLE;
1058             if (regcode != &regdummy)
1059                 *OPERAND(ret) = len;
1060             regc('\0');
1061         }
1062         break;
1063     }
1064
1065     return(ret);
1066 }
1067
1068 static char *
1069 regwhite(p, e)
1070 char *p;
1071 char *e;
1072 {
1073     while (p < e) {
1074         if (isSPACE(*p))
1075             ++p;
1076         else if (*p == '#') {
1077             do {
1078                 p++;
1079             } while (p < e && *p != '\n');
1080         }
1081         else
1082             break;
1083     }
1084     return p;
1085 }
1086
1087 static void
1088 regset(opnd, c)
1089 char *opnd;
1090 register I32 c;
1091 {
1092     if (opnd == &regdummy)
1093         return;
1094     c &= 0xFF;
1095     opnd[1 + (c >> 3)] |= (1 << (c & 7));
1096 }
1097
1098 static char *
1099 regclass()
1100 {
1101     register char *opnd;
1102     register I32 class;
1103     register I32 lastclass = 1234;
1104     register I32 range = 0;
1105     register char *ret;
1106     register I32 def;
1107     I32 numlen;
1108
1109     ret = regnode(ANYOF);
1110     opnd = regcode;
1111     for (class = 0; class < 33; class++)
1112         regc(0);
1113     if (*regparse == '^') {     /* Complement of range. */
1114         regnaughty++;
1115         regparse++;
1116         if (opnd != &regdummy)
1117             *opnd |= ANYOF_INVERT;
1118     }
1119     if (opnd != &regdummy) {
1120         if (regflags & PMf_FOLD)
1121             *opnd |= ANYOF_FOLD;
1122         if (regflags & PMf_LOCALE)
1123             *opnd |= ANYOF_LOCALE;
1124     }
1125     if (*regparse == ']' || *regparse == '-')
1126         goto skipcond;          /* allow 1st char to be ] or - */
1127     while (regparse < regxend && *regparse != ']') {
1128        skipcond:
1129         class = UCHARAT(regparse++);
1130         if (class == '\\') {
1131             class = UCHARAT(regparse++);
1132             switch (class) {
1133             case 'w':
1134                 if (regflags & PMf_LOCALE) {
1135                     if (opnd != &regdummy)
1136                         *opnd |= ANYOF_ALNUML;
1137                 }
1138                 else {
1139                     for (class = 0; class < 256; class++)
1140                         if (isALNUM(class))
1141                             regset(opnd, class);
1142                 }
1143                 lastclass = 1234;
1144                 continue;
1145             case 'W':
1146                 if (regflags & PMf_LOCALE) {
1147                     if (opnd != &regdummy)
1148                         *opnd |= ANYOF_NALNUML;
1149                 }
1150                 else {
1151                     for (class = 0; class < 256; class++)
1152                         if (!isALNUM(class))
1153                             regset(opnd, class);
1154                 }
1155                 lastclass = 1234;
1156                 continue;
1157             case 's':
1158                 if (regflags & PMf_LOCALE) {
1159                     if (opnd != &regdummy)
1160                         *opnd |= ANYOF_SPACEL;
1161                 }
1162                 else {
1163                     for (class = 0; class < 256; class++)
1164                         if (isSPACE(class))
1165                             regset(opnd, class);
1166                 }
1167                 lastclass = 1234;
1168                 continue;
1169             case 'S':
1170                 if (regflags & PMf_LOCALE) {
1171                     if (opnd != &regdummy)
1172                         *opnd |= ANYOF_NSPACEL;
1173                 }
1174                 else {
1175                     for (class = 0; class < 256; class++)
1176                         if (!isSPACE(class))
1177                             regset(opnd, class);
1178                 }
1179                 lastclass = 1234;
1180                 continue;
1181             case 'd':
1182                 for (class = '0'; class <= '9'; class++)
1183                     regset(opnd, class);
1184                 lastclass = 1234;
1185                 continue;
1186             case 'D':
1187                 for (class = 0; class < '0'; class++)
1188                     regset(opnd, class);
1189                 for (class = '9' + 1; class < 256; class++)
1190                     regset(opnd, class);
1191                 lastclass = 1234;
1192                 continue;
1193             case 'n':
1194                 class = '\n';
1195                 break;
1196             case 'r':
1197                 class = '\r';
1198                 break;
1199             case 't':
1200                 class = '\t';
1201                 break;
1202             case 'f':
1203                 class = '\f';
1204                 break;
1205             case 'b':
1206                 class = '\b';
1207                 break;
1208             case 'e':
1209                 class = '\033';
1210                 break;
1211             case 'a':
1212                 class = '\007';
1213                 break;
1214             case 'x':
1215                 class = scan_hex(regparse, 2, &numlen);
1216                 regparse += numlen;
1217                 break;
1218             case 'c':
1219                 class = UCHARAT(regparse++);
1220                 class = toCTRL(class);
1221                 break;
1222             case '0': case '1': case '2': case '3': case '4':
1223             case '5': case '6': case '7': case '8': case '9':
1224                 class = scan_oct(--regparse, 3, &numlen);
1225                 regparse += numlen;
1226                 break;
1227             }
1228         }
1229         if (range) {
1230             if (lastclass > class)
1231                 FAIL("invalid [] range in regexp");
1232             range = 0;
1233         }
1234         else {
1235             lastclass = class;
1236             if (*regparse == '-' && regparse+1 < regxend &&
1237               regparse[1] != ']') {
1238                 regparse++;
1239                 range = 1;
1240                 continue;       /* do it next time */
1241             }
1242         }
1243         for ( ; lastclass <= class; lastclass++)
1244             regset(opnd, lastclass);
1245         lastclass = class;
1246     }
1247     if (*regparse != ']')
1248         FAIL("unmatched [] in regexp");
1249     nextchar();
1250     return ret;
1251 }
1252
1253 static char*
1254 nextchar()
1255 {
1256     char* retval = regparse++;
1257
1258     for (;;) {
1259         if (*regparse == '(' && regparse[1] == '?' &&
1260                 regparse[2] == '#') {
1261             while (*regparse && *regparse != ')')
1262                 regparse++;
1263             regparse++;
1264             continue;
1265         }
1266         if (regflags & PMf_EXTENDED) {
1267             if (isSPACE(*regparse)) {
1268                 regparse++;
1269                 continue;
1270             }
1271             else if (*regparse == '#') {
1272                 while (*regparse && *regparse != '\n')
1273                     regparse++;
1274                 regparse++;
1275                 continue;
1276             }
1277         }
1278         return retval;
1279     }
1280 }
1281
1282 /*
1283 - regnode - emit a node
1284 */
1285 #ifdef CAN_PROTOTYPE
1286 static char *                   /* Location. */
1287 regnode(char op)
1288 #else
1289 static char *                   /* Location. */
1290 regnode(op)
1291 char op;
1292 #endif
1293 {
1294     register char *ret;
1295     register char *ptr;
1296
1297     ret = regcode;
1298     if (ret == &regdummy) {
1299 #ifdef REGALIGN
1300         if (!(regsize & 1))
1301             regsize++;
1302 #endif
1303         regsize += 3;
1304         return(ret);
1305     }
1306
1307 #ifdef REGALIGN
1308 #ifndef lint
1309     if (!((long)ret & 1))
1310       *ret++ = 127;
1311 #endif
1312 #endif
1313     ptr = ret;
1314     *ptr++ = op;
1315     *ptr++ = '\0';              /* Null "next" pointer. */
1316     *ptr++ = '\0';
1317     regcode = ptr;
1318
1319     return(ret);
1320 }
1321
1322 /*
1323 - reganode - emit a node with an argument
1324 */
1325 #ifdef CAN_PROTOTYPE
1326 static char *                   /* Location. */
1327 reganode(char op, unsigned short arg)
1328 #else
1329 static char *                   /* Location. */
1330 reganode(op, arg)
1331 char op;
1332 unsigned short arg;
1333 #endif
1334 {
1335     register char *ret;
1336     register char *ptr;
1337
1338     ret = regcode;
1339     if (ret == &regdummy) {
1340 #ifdef REGALIGN
1341         if (!(regsize & 1))
1342             regsize++;
1343 #endif
1344         regsize += 5;
1345         return(ret);
1346     }
1347
1348 #ifdef REGALIGN
1349 #ifndef lint
1350     if (!((long)ret & 1))
1351       *ret++ = 127;
1352 #endif
1353 #endif
1354     ptr = ret;
1355     *ptr++ = op;
1356     *ptr++ = '\0';              /* Null "next" pointer. */
1357     *ptr++ = '\0';
1358 #ifdef REGALIGN
1359     *(unsigned short *)(ret+3) = arg;
1360 #else
1361     ret[3] = arg >> 8; ret[4] = arg & 0377;
1362 #endif
1363     ptr += 2;
1364     regcode = ptr;
1365
1366     return(ret);
1367 }
1368
1369 /*
1370 - regc - emit (if appropriate) a byte of code
1371 */
1372 #ifdef CAN_PROTOTYPE
1373 static void
1374 regc(char b)
1375 #else
1376 static void
1377 regc(b)
1378 char b;
1379 #endif
1380 {
1381     if (regcode != &regdummy)
1382         *regcode++ = b;
1383     else
1384         regsize++;
1385 }
1386
1387 /*
1388 - reginsert - insert an operator in front of already-emitted operand
1389 *
1390 * Means relocating the operand.
1391 */
1392 #ifdef CAN_PROTOTYPE
1393 static void
1394 reginsert(char op, char *opnd)
1395 #else
1396 static void
1397 reginsert(op, opnd)
1398 char op;
1399 char *opnd;
1400 #endif
1401 {
1402     register char *src;
1403     register char *dst;
1404     register char *place;
1405     register int offset = (regkind[(U8)op] == CURLY ? 4 : 0);
1406
1407     if (regcode == &regdummy) {
1408 #ifdef REGALIGN
1409         regsize += 4 + offset;
1410 #else
1411         regsize += 3 + offset;
1412 #endif
1413         return;
1414     }
1415
1416     src = regcode;
1417 #ifdef REGALIGN
1418     regcode += 4 + offset;
1419 #else
1420     regcode += 3 + offset;
1421 #endif
1422     dst = regcode;
1423     while (src > opnd)
1424         *--dst = *--src;
1425
1426     place = opnd;               /* Op node, where operand used to be. */
1427     *place++ = op;
1428     *place++ = '\0';
1429     *place++ = '\0';
1430     while (offset-- > 0)
1431         *place++ = '\0';
1432 #ifdef REGALIGN
1433     *place++ = '\177';
1434 #endif
1435 }
1436
1437 /*
1438 - regtail - set the next-pointer at the end of a node chain
1439 */
1440 static void
1441 regtail(p, val)
1442 char *p;
1443 char *val;
1444 {
1445     register char *scan;
1446     register char *temp;
1447     register I32 offset;
1448
1449     if (p == &regdummy)
1450         return;
1451
1452     /* Find last node. */
1453     scan = p;
1454     for (;;) {
1455         temp = regnext(scan);
1456         if (temp == NULL)
1457             break;
1458         scan = temp;
1459     }
1460
1461 #ifdef REGALIGN
1462     offset = val - scan;
1463 #ifndef lint
1464     *(short*)(scan+1) = offset;
1465 #else
1466     offset = offset;
1467 #endif
1468 #else
1469     if (OP(scan) == BACK)
1470         offset = scan - val;
1471     else
1472         offset = val - scan;
1473     *(scan+1) = (offset>>8)&0377;
1474     *(scan+2) = offset&0377;
1475 #endif
1476 }
1477
1478 /*
1479 - regoptail - regtail on operand of first argument; nop if operandless
1480 */
1481 static void
1482 regoptail(p, val)
1483 char *p;
1484 char *val;
1485 {
1486     /* "Operandless" and "op != BRANCH" are synonymous in practice. */
1487     if (p == NULL || p == &regdummy || regkind[(U8)OP(p)] != BRANCH)
1488         return;
1489     regtail(NEXTOPER(p), val);
1490 }
1491
1492 /*
1493  - regcurly - a little FSA that accepts {\d+,?\d*}
1494  */
1495 STATIC I32
1496 regcurly(s)
1497 register char *s;
1498 {
1499     if (*s++ != '{')
1500         return FALSE;
1501     if (!isDIGIT(*s))
1502         return FALSE;
1503     while (isDIGIT(*s))
1504         s++;
1505     if (*s == ',')
1506         s++;
1507     while (isDIGIT(*s))
1508         s++;
1509     if (*s != '}')
1510         return FALSE;
1511     return TRUE;
1512 }
1513
1514 #ifdef DEBUGGING
1515
1516 /*
1517  - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
1518  */
1519 void
1520 regdump(r)
1521 regexp *r;
1522 {
1523     register char *s;
1524     register char op = EXACT;   /* Arbitrary non-END op. */
1525     register char *next;
1526
1527
1528     s = r->program + 1;
1529     while (op != END) { /* While that wasn't END last time... */
1530 #ifdef REGALIGN
1531         if (!((long)s & 1))
1532             s++;
1533 #endif
1534         op = OP(s);
1535         PerlIO_printf(Perl_debug_log, "%2d%s", s-r->program, regprop(s));       /* Where, what. */
1536         next = regnext(s);
1537         s += regarglen[(U8)op];
1538         if (next == NULL)               /* Next ptr. */
1539             PerlIO_printf(Perl_debug_log, "(0)");
1540         else 
1541             PerlIO_printf(Perl_debug_log, "(%d)", (s-r->program)+(next-s));
1542         s += 3;
1543         if (op == ANYOF) {
1544             s += 33;
1545         }
1546         if (regkind[(U8)op] == EXACT) {
1547             /* Literal string, where present. */
1548             s++;
1549             (void)PerlIO_putc(Perl_debug_log, ' ');
1550             (void)PerlIO_putc(Perl_debug_log, '<');
1551             while (*s != '\0') {
1552                 (void)PerlIO_putc(Perl_debug_log,*s);
1553                 s++;
1554             }
1555             (void)PerlIO_putc(Perl_debug_log, '>');
1556             s++;
1557         }
1558         (void)PerlIO_putc(Perl_debug_log, '\n');
1559     }
1560
1561     /* Header fields of interest. */
1562     if (r->regstart)
1563         PerlIO_printf(Perl_debug_log, "start `%s' ", SvPVX(r->regstart));
1564     if (r->regstclass)
1565         PerlIO_printf(Perl_debug_log, "stclass `%s' ", regprop(r->regstclass));
1566     if (r->reganch & ROPT_ANCH) {
1567         PerlIO_printf(Perl_debug_log, "anchored");
1568         if (r->reganch & ROPT_ANCH_BOL)
1569             PerlIO_printf(Perl_debug_log, "(BOL)");
1570         if (r->reganch & ROPT_ANCH_GPOS)
1571             PerlIO_printf(Perl_debug_log, "(GPOS)");
1572         PerlIO_putc(Perl_debug_log, ' ');
1573     }
1574     if (r->reganch & ROPT_SKIP)
1575         PerlIO_printf(Perl_debug_log, "plus ");
1576     if (r->reganch & ROPT_IMPLICIT)
1577         PerlIO_printf(Perl_debug_log, "implicit ");
1578     if (r->regmust != NULL)
1579         PerlIO_printf(Perl_debug_log, "must have \"%s\" back %ld ", SvPVX(r->regmust),
1580          (long) r->regback);
1581     PerlIO_printf(Perl_debug_log, "minlen %ld ", (long) r->minlen);
1582     PerlIO_printf(Perl_debug_log, "\n");
1583 }
1584
1585 /*
1586 - regprop - printable representation of opcode
1587 */
1588 char *
1589 regprop(op)
1590 char *op;
1591 {
1592     register char *p = 0;
1593
1594     (void) strcpy(buf, ":");
1595
1596     switch (OP(op)) {
1597     case BOL:
1598         p = "BOL";
1599         break;
1600     case MBOL:
1601         p = "MBOL";
1602         break;
1603     case SBOL:
1604         p = "SBOL";
1605         break;
1606     case EOL:
1607         p = "EOL";
1608         break;
1609     case MEOL:
1610         p = "MEOL";
1611         break;
1612     case SEOL:
1613         p = "SEOL";
1614         break;
1615     case ANY:
1616         p = "ANY";
1617         break;
1618     case SANY:
1619         p = "SANY";
1620         break;
1621     case ANYOF:
1622         p = "ANYOF";
1623         break;
1624     case BRANCH:
1625         p = "BRANCH";
1626         break;
1627     case EXACT:
1628         p = "EXACT";
1629         break;
1630     case EXACTF:
1631         p = "EXACTF";
1632         break;
1633     case EXACTFL:
1634         p = "EXACTFL";
1635         break;
1636     case NOTHING:
1637         p = "NOTHING";
1638         break;
1639     case BACK:
1640         p = "BACK";
1641         break;
1642     case END:
1643         p = "END";
1644         break;
1645     case BOUND:
1646         p = "BOUND";
1647         break;
1648     case BOUNDL:
1649         p = "BOUNDL";
1650         break;
1651     case NBOUND:
1652         p = "NBOUND";
1653         break;
1654     case NBOUNDL:
1655         p = "NBOUNDL";
1656         break;
1657     case CURLY:
1658         (void)sprintf(buf+strlen(buf), "CURLY {%d,%d}", ARG1(op),ARG2(op));
1659         p = NULL;
1660         break;
1661     case CURLYX:
1662         (void)sprintf(buf+strlen(buf), "CURLYX {%d,%d}", ARG1(op),ARG2(op));
1663         p = NULL;
1664         break;
1665     case REF:
1666         (void)sprintf(buf+strlen(buf), "REF%d", ARG1(op));
1667         p = NULL;
1668         break;
1669     case OPEN:
1670         (void)sprintf(buf+strlen(buf), "OPEN%d", ARG1(op));
1671         p = NULL;
1672         break;
1673     case CLOSE:
1674         (void)sprintf(buf+strlen(buf), "CLOSE%d", ARG1(op));
1675         p = NULL;
1676         break;
1677     case STAR:
1678         p = "STAR";
1679         break;
1680     case PLUS:
1681         p = "PLUS";
1682         break;
1683     case MINMOD:
1684         p = "MINMOD";
1685         break;
1686     case GPOS:
1687         p = "GPOS";
1688         break;
1689     case UNLESSM:
1690         p = "UNLESSM";
1691         break;
1692     case IFMATCH:
1693         p = "IFMATCH";
1694         break;
1695     case SUCCEED:
1696         p = "SUCCEED";
1697         break;
1698     case WHILEM:
1699         p = "WHILEM";
1700         break;
1701     case DIGIT:
1702         p = "DIGIT";
1703         break;
1704     case NDIGIT:
1705         p = "NDIGIT";
1706         break;
1707     case ALNUM:
1708         p = "ALNUM";
1709         break;
1710     case NALNUM:
1711         p = "NALNUM";
1712         break;
1713     case SPACE:
1714         p = "SPACE";
1715         break;
1716     case NSPACE:
1717         p = "NSPACE";
1718         break;
1719     case ALNUML:
1720         p = "ALNUML";
1721         break;
1722     case NALNUML:
1723         p = "NALNUML";
1724         break;
1725     case SPACEL:
1726         p = "SPACEL";
1727         break;
1728     case NSPACEL:
1729         p = "NSPACEL";
1730         break;
1731     default:
1732         FAIL("corrupted regexp opcode");
1733     }
1734     if (p != NULL)
1735         (void) strcat(buf, p);
1736     return(buf);
1737 }
1738 #endif /* DEBUGGING */
1739
1740 void
1741 pregfree(r)
1742 struct regexp *r;
1743 {
1744     if (!r)
1745         return;
1746     if (r->precomp) {
1747         Safefree(r->precomp);
1748         r->precomp = Nullch;
1749     }
1750     if (r->subbase) {
1751         Safefree(r->subbase);
1752         r->subbase = Nullch;
1753     }
1754     if (r->regmust) {
1755         SvREFCNT_dec(r->regmust);
1756         r->regmust = Nullsv;
1757     }
1758     if (r->regstart) {
1759         SvREFCNT_dec(r->regstart);
1760         r->regstart = Nullsv;
1761     }
1762     Safefree(r->startp);
1763     Safefree(r->endp);
1764     Safefree(r);
1765 }