This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Allow redirection of debug messages
[perl5.git] / regcomp.c
CommitLineData
a0d0e21e
LW
1/* regcomp.c
2 */
3
4/*
5 * "A fair jaw-cracker dwarf-language must be." --Samwise Gamgee
6 */
7
a687059c
LW
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
e50aee73
AD
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
f0fcb552 22/*SUPPRESS 112*/
a687059c 23/*
e50aee73 24 * pregcomp and pregexec -- regsub and regerror are not used in perl
a687059c
LW
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 ****
a0d0e21e 46 **** Copyright (c) 1991-1994, Larry Wall
a687059c 47 ****
9ef589d8
LW
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
a687059c
LW
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
fe14fcc3
LW
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
a687059c
LW
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)))
2b69d0c2
LW
77#ifdef atarist
78#define PERL_META "^$.[()|?+*\\"
79#else
a687059c 80#define META "^$.[()|?+*\\"
2b69d0c2 81#endif
a687059c 82
35c8bce7
LW
83#ifdef SPSTART
84#undef SPSTART /* dratted cpp namespace... */
85#endif
a687059c
LW
86/*
87 * Flags to be passed up and down.
88 */
a687059c 89#define WORST 0 /* Worst case. */
a0d0e21e
LW
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. */
a687059c
LW
94
95/*
e50aee73 96 * Forward declarations for pregcomp()'s friends.
a687059c 97 */
a0d0e21e
LW
98
99static char *reg _((I32, I32 *));
100static char *reganode _((char, unsigned short));
101static char *regatom _((I32 *));
102static char *regbranch _((I32 *));
103static void regc _((char));
104static char *regclass _((void));
105STATIC I32 regcurly _((char *));
106static char *regnode _((char));
107static char *regpiece _((I32 *));
108static void reginsert _((char, char *));
109static void regoptail _((char *, char *));
110static void regset _((char *, I32, I32));
111static void regtail _((char *, char *));
112static char* nextchar _((void));
a687059c
LW
113
114/*
e50aee73 115 - pregcomp - compile a regular expression into internal code
a687059c
LW
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 */
129regexp *
e50aee73 130pregcomp(exp,xend,pm)
a0d0e21e
LW
131char* exp;
132char* xend;
133PMOP* pm;
a687059c 134{
a0d0e21e
LW
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);
a687059c
LW
215 }
216
a0d0e21e
LW
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
fd181c75 247 DEBUG_r(fprintf(Perl_debug_log,"first %d next %d offset %d\n",
a0d0e21e
LW
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);
00bf170e 273 }
a0d0e21e
LW
274 else /* single branch is ok */
275 scan = NEXTOPER(scan);
748a9306 276 continue;
a0d0e21e
LW
277 }
278 if (OP(scan) == UNLESSM) {
279 curback = -30000;
280 scan = regnext(scan);
748a9306 281 continue;
a0d0e21e
LW
282 }
283 if (OP(scan) == EXACTLY) {
284 char *t;
a687059c 285
a0d0e21e
LW
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);
2b69d0c2 296 }
a0d0e21e
LW
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);
9ef589d8 303 }
a0d0e21e
LW
304 else
305 curback += *OPERAND(first);
306 }
307 else if (strchr(varies,OP(scan))) {
308 curback = -30000;
a687059c 309 len = 0;
a0d0e21e 310 if (SvCUR(longish) > SvCUR(longest)) {
79072805 311 sv_setsv(longest,longish);
34de22dd
LW
312 backest = backish;
313 }
a0d0e21e
LW
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;
fe14fcc3 328 }
a0d0e21e
LW
329 sv_setpvn(longish,"",0);
330 }
331 scan = regnext(scan);
a687059c
LW
332 }
333
a0d0e21e
LW
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);
a687059c
LW
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 */
392static char *
393reg(paren, flagp)
79072805
LW
394I32 paren; /* Parenthesized? */
395I32 *flagp;
a687059c 396{
a0d0e21e
LW
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++;
748a9306 409 paren = *regparse++;
a0d0e21e
LW
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 != ')')
748a9306 424 croak("Sequence (?#... not terminated");
a0d0e21e
LW
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();
a687059c
LW
460 br = regbranch(&flags);
461 if (br == NULL)
a0d0e21e
LW
462 return(NULL);
463 regtail(ret, br); /* BRANCH -> BRANCH. */
a687059c 464 if (!(flags&HASWIDTH))
a0d0e21e 465 *flagp &= ~HASWIDTH;
a687059c 466 *flagp |= flags&SPSTART;
a0d0e21e
LW
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. */
4633a7c4 502 if (paren && (regparse >= regxend || *nextchar() != ')')) {
a0d0e21e
LW
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 }
a687059c 511
a0d0e21e 512 return(ret);
a687059c
LW
513}
514
515/*
516 - regbranch - one alternative of an | operator
517 *
518 * Implements the concatenation operator.
519 */
520static char *
521regbranch(flagp)
79072805 522I32 *flagp;
a687059c 523{
a0d0e21e
LW
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);
a687059c 549 }
a0d0e21e
LW
550 chain = latest;
551 }
552 if (chain == NULL) /* Loop ran zero times. */
553 (void) regnode(NOTHING);
a687059c 554
a0d0e21e 555 return(ret);
a687059c
LW
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 */
567static char *
568regpiece(flagp)
79072805 569I32 *flagp;
a687059c 570{
a0d0e21e
LW
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;
a687059c 606 }
a0d0e21e
LW
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) {
00bf170e 641#ifdef REGALIGN
a0d0e21e
LW
642 *(unsigned short *)(ret+3) = min;
643 *(unsigned short *)(ret+5) = max;
00bf170e 644#else
a0d0e21e
LW
645 ret[3] = min >> 8; ret[4] = min & 0377;
646 ret[5] = max >> 8; ret[6] = max & 0377;
00bf170e 647#endif
a687059c 648 }
a687059c 649
a0d0e21e 650 goto nest_check;
a687059c 651 }
a0d0e21e 652 }
a687059c 653
a0d0e21e
LW
654 if (!ISMULT1(op)) {
655 *flagp = flags;
a687059c 656 return(ret);
a0d0e21e
LW
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);
a687059c
LW
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 */
711static char *
712regatom(flagp)
79072805 713I32 *flagp;
a687059c 714{
a0d0e21e
LW
715 register char *ret = 0;
716 I32 flags;
717
718 *flagp = WORST; /* Tentatively. */
719
720tryagain:
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))
a687059c 857 regparse++;
a0d0e21e
LW
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;
4633a7c4
LW
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
a0d0e21e
LW
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++;
a687059c 924 break;
a0d0e21e
LW
925 case 'r':
926 ender = '\r';
927 p++;
a687059c 928 break;
a0d0e21e
LW
929 case 't':
930 ender = '\t';
931 p++;
a687059c 932 break;
a0d0e21e
LW
933 case 'f':
934 ender = '\f';
935 p++;
a687059c 936 break;
a0d0e21e
LW
937 case 'e':
938 ender = '\033';
939 p++;
a687059c 940 break;
a0d0e21e
LW
941 case 'a':
942 ender = '\007';
943 p++;
a687059c 944 break;
a0d0e21e
LW
945 case 'x':
946 ender = scan_hex(++p, 2, &numlen);
947 p += numlen;
a687059c 948 break;
a0d0e21e
LW
949 case 'c':
950 p++;
951 ender = *p++;
952 if (isLOWER(ender))
953 ender = toUPPER(ender);
954 ender ^= 64;
a687059c 955 break;
a0d0e21e
LW
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;
a687059c
LW
966 }
967 break;
a0d0e21e
LW
968 case '\0':
969 if (p >= regxend)
a687059c
LW
970 FAIL("trailing \\ in regexp");
971 /* FALL THROUGH */
a0d0e21e
LW
972 default:
973 ender = *p++;
974 break;
975 }
976 break;
4633a7c4
LW
977 case '#':
978 if (regflags & PMf_EXTENDED) {
979 while (p < regxend && *p != '\n') p++;
980 }
981 /* FALL THROUGH */
a0d0e21e
LW
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 */
a687059c 989 default:
a0d0e21e
LW
990 ender = *p++;
991 break;
a687059c 992 }
a0d0e21e
LW
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;
a687059c 1003 }
a0d0e21e
LW
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');
a687059c 1018 }
a0d0e21e
LW
1019 break;
1020 }
a687059c 1021
a0d0e21e 1022 return(ret);
a687059c
LW
1023}
1024
1025static void
1026regset(bits,def,c)
1027char *bits;
79072805
LW
1028I32 def;
1029register I32 c;
a687059c 1030{
a0d0e21e
LW
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));
a687059c
LW
1038}
1039
1040static char *
1041regclass()
1042{
a0d0e21e
LW
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] != ']') {
a687059c 1153 regparse++;
a0d0e21e
LW
1154 range = 1;
1155 continue; /* do it next time */
1156 }
a687059c 1157 }
a0d0e21e
LW
1158 for ( ; lastclass <= class; lastclass++) {
1159 regset(bits,def,lastclass);
1160 if (regflags & PMf_FOLD && isUPPER(lastclass))
1161 regset(bits,def,toLOWER(lastclass));
a687059c 1162 }
a0d0e21e
LW
1163 lastclass = class;
1164 }
1165 if (*regparse != ']')
1166 FAIL("unmatched [] in regexp");
1167 nextchar();
1168 return ret;
1169}
1170
1171static char*
1172nextchar()
1173{
1174 char* retval = regparse++;
1175
4633a7c4
LW
1176 for (;;) {
1177 if (*regparse == '(' && regparse[1] == '?' &&
1178 regparse[2] == '#') {
1179 while (*regparse && *regparse != ')')
748a9306 1180 regparse++;
4633a7c4
LW
1181 regparse++;
1182 continue;
1183 }
1184 if (regflags & PMf_EXTENDED) {
1185 if (isSPACE(*regparse)) {
748a9306
LW
1186 regparse++;
1187 continue;
1188 }
1189 else if (*regparse == '#') {
1190 while (*regparse && *regparse != '\n')
1191 regparse++;
1192 regparse++;
1193 continue;
1194 }
748a9306 1195 }
4633a7c4 1196 return retval;
a0d0e21e 1197 }
a687059c
LW
1198}
1199
1200/*
a0d0e21e
LW
1201- regnode - emit a node
1202*/
1203#ifdef CAN_PROTOTYPE
1204static char * /* Location. */
1205regnode(char op)
1206#else
a687059c
LW
1207static char * /* Location. */
1208regnode(op)
1209char op;
a0d0e21e 1210#endif
a687059c 1211{
a0d0e21e
LW
1212 register char *ret;
1213 register char *ptr;
a687059c 1214
a0d0e21e
LW
1215 ret = regcode;
1216 if (ret == &regdummy) {
a687059c 1217#ifdef REGALIGN
a0d0e21e
LW
1218 if (!(regsize & 1))
1219 regsize++;
a687059c 1220#endif
a0d0e21e
LW
1221 regsize += 3;
1222 return(ret);
1223 }
a687059c
LW
1224
1225#ifdef REGALIGN
1226#ifndef lint
a0d0e21e
LW
1227 if (!((long)ret & 1))
1228 *ret++ = 127;
a687059c
LW
1229#endif
1230#endif
a0d0e21e
LW
1231 ptr = ret;
1232 *ptr++ = op;
1233 *ptr++ = '\0'; /* Null "next" pointer. */
1234 *ptr++ = '\0';
1235 regcode = ptr;
a687059c 1236
a0d0e21e 1237 return(ret);
a687059c
LW
1238}
1239
1240/*
a0d0e21e
LW
1241- reganode - emit a node with an argument
1242*/
1243#ifdef CAN_PROTOTYPE
1244static char * /* Location. */
1245reganode(char op, unsigned short arg)
1246#else
fe14fcc3
LW
1247static char * /* Location. */
1248reganode(op, arg)
1249char op;
1250unsigned short arg;
a0d0e21e 1251#endif
fe14fcc3 1252{
a0d0e21e
LW
1253 register char *ret;
1254 register char *ptr;
fe14fcc3 1255
a0d0e21e
LW
1256 ret = regcode;
1257 if (ret == &regdummy) {
fe14fcc3 1258#ifdef REGALIGN
a0d0e21e
LW
1259 if (!(regsize & 1))
1260 regsize++;
fe14fcc3 1261#endif
a0d0e21e
LW
1262 regsize += 5;
1263 return(ret);
1264 }
fe14fcc3
LW
1265
1266#ifdef REGALIGN
1267#ifndef lint
a0d0e21e
LW
1268 if (!((long)ret & 1))
1269 *ret++ = 127;
fe14fcc3
LW
1270#endif
1271#endif
a0d0e21e
LW
1272 ptr = ret;
1273 *ptr++ = op;
1274 *ptr++ = '\0'; /* Null "next" pointer. */
1275 *ptr++ = '\0';
fe14fcc3 1276#ifdef REGALIGN
a0d0e21e 1277 *(unsigned short *)(ret+3) = arg;
fe14fcc3 1278#else
a0d0e21e 1279 ret[3] = arg >> 8; ret[4] = arg & 0377;
fe14fcc3 1280#endif
a0d0e21e
LW
1281 ptr += 2;
1282 regcode = ptr;
fe14fcc3 1283
a0d0e21e 1284 return(ret);
fe14fcc3
LW
1285}
1286
1287/*
a0d0e21e
LW
1288- regc - emit (if appropriate) a byte of code
1289*/
1290#ifdef CAN_PROTOTYPE
1291static void
1292regc(char b)
1293#else
a687059c
LW
1294static void
1295regc(b)
1296char b;
a0d0e21e 1297#endif
a687059c 1298{
a0d0e21e
LW
1299 if (regcode != &regdummy)
1300 *regcode++ = b;
1301 else
1302 regsize++;
a687059c
LW
1303}
1304
1305/*
a0d0e21e
LW
1306- reginsert - insert an operator in front of already-emitted operand
1307*
1308* Means relocating the operand.
1309*/
1310#ifdef CAN_PROTOTYPE
1311static void
1312reginsert(char op, char *opnd)
1313#else
a687059c
LW
1314static void
1315reginsert(op, opnd)
1316char op;
1317char *opnd;
a0d0e21e 1318#endif
a687059c 1319{
a0d0e21e
LW
1320 register char *src;
1321 register char *dst;
1322 register char *place;
1323 register int offset = (regkind[(U8)op] == CURLY ? 4 : 0);
a687059c 1324
a0d0e21e 1325 if (regcode == &regdummy) {
a687059c 1326#ifdef REGALIGN
a0d0e21e 1327 regsize += 4 + offset;
a687059c 1328#else
a0d0e21e 1329 regsize += 3 + offset;
a687059c 1330#endif
a0d0e21e
LW
1331 return;
1332 }
a687059c 1333
a0d0e21e 1334 src = regcode;
a687059c 1335#ifdef REGALIGN
a0d0e21e 1336 regcode += 4 + offset;
a687059c 1337#else
a0d0e21e 1338 regcode += 3 + offset;
a687059c 1339#endif
a0d0e21e
LW
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)
a687059c 1349 *place++ = '\0';
2b69d0c2 1350#ifdef REGALIGN
a0d0e21e 1351 *place++ = '\177';
2b69d0c2 1352#endif
a687059c
LW
1353}
1354
1355/*
a0d0e21e
LW
1356- regtail - set the next-pointer at the end of a node chain
1357*/
a687059c
LW
1358static void
1359regtail(p, val)
1360char *p;
1361char *val;
1362{
a0d0e21e
LW
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 }
a687059c
LW
1378
1379#ifdef REGALIGN
a0d0e21e 1380 offset = val - scan;
a687059c 1381#ifndef lint
a0d0e21e 1382 *(short*)(scan+1) = offset;
a687059c 1383#else
a0d0e21e 1384 offset = offset;
a687059c
LW
1385#endif
1386#else
a0d0e21e
LW
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;
a687059c
LW
1393#endif
1394}
1395
1396/*
a0d0e21e
LW
1397- regoptail - regtail on operand of first argument; nop if operandless
1398*/
a687059c
LW
1399static void
1400regoptail(p, val)
1401char *p;
1402char *val;
1403{
a0d0e21e
LW
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);
a687059c
LW
1408}
1409
1410/*
1411 - regcurly - a little FSA that accepts {\d+,?\d*}
1412 */
79072805 1413STATIC I32
a687059c
LW
1414regcurly(s)
1415register char *s;
1416{
1417 if (*s++ != '{')
1418 return FALSE;
f0fcb552 1419 if (!isDIGIT(*s))
a687059c 1420 return FALSE;
f0fcb552 1421 while (isDIGIT(*s))
a687059c
LW
1422 s++;
1423 if (*s == ',')
1424 s++;
f0fcb552 1425 while (isDIGIT(*s))
a687059c
LW
1426 s++;
1427 if (*s != '}')
1428 return FALSE;
1429 return TRUE;
1430}
1431
1432#ifdef DEBUGGING
1433
1434/*
fd181c75 1435 - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
a687059c
LW
1436 */
1437void
1438regdump(r)
1439regexp *r;
1440{
a0d0e21e
LW
1441 register char *s;
1442 register char op = EXACTLY; /* Arbitrary non-END op. */
1443 register char *next;
a687059c
LW
1444
1445
a0d0e21e
LW
1446 s = r->program + 1;
1447 while (op != END) { /* While that wasn't END last time... */
a687059c 1448#ifdef REGALIGN
a0d0e21e
LW
1449 if (!((long)s & 1))
1450 s++;
a687059c 1451#endif
a0d0e21e 1452 op = OP(s);
fd181c75 1453 fprintf(Perl_debug_log,"%2d%s", s-r->program, regprop(s)); /* Where, what. */
a0d0e21e
LW
1454 next = regnext(s);
1455 s += regarglen[(U8)op];
1456 if (next == NULL) /* Next ptr. */
fd181c75 1457 fprintf(Perl_debug_log,"(0)");
a0d0e21e 1458 else
fd181c75 1459 fprintf(Perl_debug_log,"(%d)", (s-r->program)+(next-s));
a0d0e21e
LW
1460 s += 3;
1461 if (op == ANYOF) {
1462 s += 32;
a687059c 1463 }
a0d0e21e
LW
1464 if (op == EXACTLY) {
1465 /* Literal string, where present. */
1466 s++;
fd181c75
PP
1467 (void)putc(' ', Perl_debug_log);
1468 (void)putc('<', Perl_debug_log);
a0d0e21e 1469 while (*s != '\0') {
fd181c75 1470 (void)putc(*s, Perl_debug_log);
a0d0e21e
LW
1471 s++;
1472 }
fd181c75 1473 (void)putc('>', Perl_debug_log);
a0d0e21e
LW
1474 s++;
1475 }
fd181c75 1476 (void)putc('\n', Perl_debug_log);
a0d0e21e
LW
1477 }
1478
1479 /* Header fields of interest. */
1480 if (r->regstart)
fd181c75 1481 fprintf(Perl_debug_log,"start `%s' ", SvPVX(r->regstart));
a0d0e21e 1482 if (r->regstclass)
fd181c75 1483 fprintf(Perl_debug_log,"stclass `%s' ", regprop(r->regstclass));
a0d0e21e 1484 if (r->reganch & ROPT_ANCH)
fd181c75 1485 fprintf(Perl_debug_log,"anchored ");
a0d0e21e 1486 if (r->reganch & ROPT_SKIP)
fd181c75 1487 fprintf(Perl_debug_log,"plus ");
a0d0e21e 1488 if (r->reganch & ROPT_IMPLICIT)
fd181c75 1489 fprintf(Perl_debug_log,"implicit ");
a0d0e21e 1490 if (r->regmust != NULL)
fd181c75 1491 fprintf(Perl_debug_log,"must have \"%s\" back %ld ", SvPVX(r->regmust),
a0d0e21e 1492 (long) r->regback);
fd181c75
PP
1493 fprintf(Perl_debug_log, "minlen %ld ", (long) r->minlen);
1494 fprintf(Perl_debug_log,"\n");
a687059c
LW
1495}
1496
1497/*
a0d0e21e
LW
1498- regprop - printable representation of opcode
1499*/
a687059c
LW
1500char *
1501regprop(op)
1502char *op;
1503{
a0d0e21e
LW
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);
a687059c
LW
1625}
1626#endif /* DEBUGGING */
1627
2b69d0c2 1628void
e50aee73 1629pregfree(r)
a687059c
LW
1630struct regexp *r;
1631{
a0d0e21e
LW
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);
a687059c 1653}