lwall@netlabs.com (Larry Wall) (04/17/91)
Submitted-by: Larry Wall <lwall@netlabs.com>
Posting-number: Volume 18, Issue 36
Archive-name: perl/part18
[There are 36 kits for perl version 4.0.]
#! /bin/sh
# Make a new directory for the perl sources, cd to it, and run kits 1
# thru 36 through sh. When all 36 kits have been run, read README.
echo "This is perl 4.0 kit 18 (of 36). If kit 18 is complete, the line"
echo '"'"End of kit 18 (of 36)"'" will echo at the end.'
echo ""
export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
mkdir eg eg/scan emacs 2>/dev/null
echo Extracting regcomp.c
sed >regcomp.c <<'!STUFFY!FUNK!' -e 's/X//'
X/* NOTE: this is derived from Henry Spencer's regexp code, and should not
X * confused with the original package (see point 3 below). Thanks, Henry!
X */
X
X/* Additional note: this code is very heavily munged from Henry's version
X * in places. In some spots I've traded clarity for efficiency, so don't
X * blame Henry for some of the lack of readability.
X */
X
X/* $RCSfile: regcomp.c,v $$Revision: 4.0.1.1 $$Date: 91/04/12 09:04:45 $
X *
X * $Log: regcomp.c,v $
X * Revision 4.0.1.1 91/04/12 09:04:45 lwall
X * patch1: random cleanup in cpp namespace
X *
X * Revision 4.0 91/03/20 01:39:01 lwall
X * 4.0 baseline.
X *
X */
X
X/*
X * regcomp and regexec -- regsub and regerror are not used in perl
X *
X * Copyright (c) 1986 by University of Toronto.
X * Written by Henry Spencer. Not derived from licensed software.
X *
X * Permission is granted to anyone to use this software for any
X * purpose on any computer system, and to redistribute it freely,
X * subject to the following restrictions:
X *
X * 1. The author is not responsible for the consequences of use of
X * this software, no matter how awful, even if they arise
X * from defects in it.
X *
X * 2. The origin of this software must not be misrepresented, either
X * by explicit claim or by omission.
X *
X * 3. Altered versions must be plainly marked as such, and must not
X * be misrepresented as being the original software.
X *
X *
X **** Alterations to Henry's code are...
X ****
X **** Copyright (c) 1989, Larry Wall
X ****
X **** You may distribute under the terms of the GNU General Public License
X **** as specified in the README file that comes with the perl 3.0 kit.
X *
X * Beware that some of this code is subtly aware of the way operator
X * precedence is structured in regular expressions. Serious changes in
X * regular-expression syntax might require a total rethink.
X */
X#include "EXTERN.h"
X#include "perl.h"
X#include "INTERN.h"
X#include "regcomp.h"
X
X#ifdef MSDOS
X# if defined(BUGGY_MSC6)
X /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
X # pragma optimize("a",off)
X /* But MSC 6.00A is happy with 'w', for aliases only across function calls*/
X # pragma optimize("w",on )
X# endif /* BUGGY_MSC6 */
X#endif /* MSDOS */
X
X#ifndef STATIC
X#define STATIC static
X#endif
X
X#define ISMULT1(c) ((c) == '*' || (c) == '+' || (c) == '?')
X#define ISMULT2(s) ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
X ((*s) == '{' && regcurly(s)))
X#define META "^$.[()|?+*\\"
X
X#ifdef SPSTART
X#undef SPSTART /* dratted cpp namespace... */
X#endif
X/*
X * Flags to be passed up and down.
X */
X#define HASWIDTH 01 /* Known never to match null string. */
X#define SIMPLE 02 /* Simple enough to be STAR/PLUS operand. */
X#define SPSTART 04 /* Starts with * or +. */
X#define WORST 0 /* Worst case. */
X
X/*
X * Global work variables for regcomp().
X */
Xstatic char *regprecomp; /* uncompiled string. */
Xstatic char *regparse; /* Input-scan pointer. */
Xstatic char *regxend; /* End of input for compile */
Xstatic int regnpar; /* () count. */
Xstatic char *regcode; /* Code-emit pointer; ®dummy = don't. */
Xstatic long regsize; /* Code size. */
Xstatic int regfold;
Xstatic int regsawbracket; /* Did we do {d,d} trick? */
X
X/*
X * Forward declarations for regcomp()'s friends.
X */
XSTATIC int regcurly();
XSTATIC char *reg();
XSTATIC char *regbranch();
XSTATIC char *regpiece();
XSTATIC char *regatom();
XSTATIC char *regclass();
XSTATIC char *regnode();
XSTATIC char *reganode();
XSTATIC void regc();
XSTATIC void reginsert();
XSTATIC void regtail();
XSTATIC void regoptail();
X
X/*
X - regcomp - compile a regular expression into internal code
X *
X * We can't allocate space until we know how big the compiled form will be,
X * but we can't compile it (and thus know how big it is) until we've got a
X * place to put the code. So we cheat: we compile it twice, once with code
X * generation turned off and size counting turned on, and once "for real".
X * This also means that we don't allocate space until we are sure that the
X * thing really will compile successfully, and we never have to move the
X * code and thus invalidate pointers into it. (Note that it has to be in
X * one piece because free() must be able to free it all.) [NB: not true in perl]
X *
X * Beware that the optimization-preparation code in here knows about some
X * of the structure of the compiled regexp. [I'll say.]
X */
Xregexp *
Xregcomp(exp,xend,fold)
Xchar *exp;
Xchar *xend;
Xint fold;
X{
X register regexp *r;
X register char *scan;
X register STR *longish;
X STR *longest;
X register int len;
X register char *first;
X int flags;
X int backish;
X int backest;
X int curback;
X extern char *safemalloc();
X extern char *savestr();
X int sawplus = 0;
X
X if (exp == NULL)
X fatal("NULL regexp argument");
X
X /* First pass: determine size, legality. */
X regfold = fold;
X regparse = exp;
X regxend = xend;
X regprecomp = nsavestr(exp,xend-exp);
X regsawbracket = 0;
X regnpar = 1;
X regsize = 0L;
X regcode = ®dummy;
X regc(MAGIC);
X if (reg(0, &flags) == NULL) {
X Safefree(regprecomp);
X regprecomp = Nullch;
X return(NULL);
X }
X
X /* Small enough for pointer-storage convention? */
X if (regsize >= 32767L) /* Probably could be 65535L. */
X FAIL("regexp too big");
X
X /* Allocate space. */
X Newc(1001, r, sizeof(regexp) + (unsigned)regsize, char, regexp);
X if (r == NULL)
X FAIL("regexp out of space");
X
X /* Second pass: emit code. */
X if (regsawbracket)
X bcopy(regprecomp,exp,xend-exp);
X r->precomp = regprecomp;
X r->subbase = NULL;
X regparse = exp;
X regnpar = 1;
X regcode = r->program;
X regc(MAGIC);
X if (reg(0, &flags) == NULL)
X return(NULL);
X
X /* Dig out information for optimizations. */
X r->regstart = Nullstr; /* Worst-case defaults. */
X r->reganch = 0;
X r->regmust = Nullstr;
X r->regback = -1;
X r->regstclass = Nullch;
X scan = r->program+1; /* First BRANCH. */
X if (OP(regnext(scan)) == END) {/* Only one top-level choice. */
X scan = NEXTOPER(scan);
X
X first = scan;
X while (OP(first) == OPEN ||
X (OP(first) == BRANCH && OP(regnext(first)) != BRANCH) ||
X (OP(first) == PLUS) ||
X (OP(first) == CURLY && ARG1(first) > 0) ) {
X if (OP(first) == PLUS)
X sawplus = 2;
X else
X first += regarglen[OP(first)];
X first = NEXTOPER(first);
X }
X
X /* Starting-point info. */
X if (OP(first) == EXACTLY) {
X r->regstart =
X str_make(OPERAND(first)+1,*OPERAND(first));
X if (r->regstart->str_cur > !(sawstudy|fold))
X fbmcompile(r->regstart,fold);
X }
X else if ((exp = index(simple,OP(first))) && exp > simple)
X r->regstclass = first;
X else if (OP(first) == BOUND || OP(first) == NBOUND)
X r->regstclass = first;
X else if (OP(first) == BOL ||
X (OP(first) == STAR && OP(NEXTOPER(first)) == ANY) )
X r->reganch = 1; /* kinda turn .* into ^.* */
X r->reganch |= sawplus;
X
X#ifdef DEBUGGING
X if (debug & 512)
X fprintf(stderr,"first %d next %d offset %d\n",
X OP(first), OP(NEXTOPER(first)), first - scan);
X#endif
X /*
X * If there's something expensive in the r.e., find the
X * longest literal string that must appear and make it the
X * regmust. Resolve ties in favor of later strings, since
X * the regstart check works with the beginning of the r.e.
X * and avoiding duplication strengthens checking. Not a
X * strong reason, but sufficient in the absence of others.
X * [Now we resolve ties in favor of the earlier string if
X * it happens that curback has been invalidated, since the
X * earlier string may buy us something the later one won't.]
X */
X longish = str_make("",0);
X longest = str_make("",0);
X len = 0;
X curback = 0;
X backish = 0;
X backest = 0;
X while (OP(scan) != END) {
X if (OP(scan) == BRANCH) {
X if (OP(regnext(scan)) == BRANCH) {
X curback = -30000;
X while (OP(scan) == BRANCH)
X scan = regnext(scan);
X }
X else /* single branch is ok */
X scan = NEXTOPER(scan);
X }
X if (OP(scan) == EXACTLY) {
X char *t;
X
X first = scan;
X while (OP(t = regnext(scan)) == CLOSE)
X scan = t;
X if (curback - backish == len) {
X str_ncat(longish, OPERAND(first)+1,
X *OPERAND(first));
X len += *OPERAND(first);
X curback += *OPERAND(first);
X first = regnext(scan);
X }
X else if (*OPERAND(first) >= len + (curback >= 0)) {
X len = *OPERAND(first);
X str_nset(longish, OPERAND(first)+1,len);
X backish = curback;
X curback += len;
X first = regnext(scan);
X }
X else
X curback += *OPERAND(first);
X }
X else if (index(varies,OP(scan))) {
X curback = -30000;
X len = 0;
X if (longish->str_cur > longest->str_cur) {
X str_sset(longest,longish);
X backest = backish;
X }
X str_nset(longish,"",0);
X }
X else if (index(simple,OP(scan))) {
X curback++;
X len = 0;
X if (longish->str_cur > longest->str_cur) {
X str_sset(longest,longish);
X backest = backish;
X }
X str_nset(longish,"",0);
X }
X scan = regnext(scan);
X }
X
X /* Prefer earlier on tie, unless we can tail match latter */
X
X if (longish->str_cur + (OP(first) == EOL) > longest->str_cur) {
X str_sset(longest,longish);
X backest = backish;
X }
X else
X str_nset(longish,"",0);
X if (longest->str_cur
X &&
X (!r->regstart
X ||
X !fbminstr(r->regstart->str_ptr,
X r->regstart->str_ptr + r->regstart->str_cur,
X longest)
X )
X )
X {
X r->regmust = longest;
X if (backest < 0)
X backest = -1;
X r->regback = backest;
X if (longest->str_cur
X > !(sawstudy || fold || OP(first) == EOL) )
X fbmcompile(r->regmust,fold);
X r->regmust->str_u.str_useful = 100;
X if (OP(first) == EOL && longish->str_cur)
X r->regmust->str_pok |= SP_TAIL;
X }
X else {
X str_free(longest);
X longest = Nullstr;
X }
X str_free(longish);
X }
X
X r->do_folding = fold;
X r->nparens = regnpar - 1;
X New(1002, r->startp, regnpar, char*);
X New(1002, r->endp, regnpar, char*);
X#ifdef DEBUGGING
X if (debug & 512)
X regdump(r);
X#endif
X return(r);
X}
X
X/*
X - reg - regular expression, i.e. main body or parenthesized thing
X *
X * Caller must absorb opening parenthesis.
X *
X * Combining parenthesis handling with the base level of regular expression
X * is a trifle forced, but the need to tie the tails of the branches to what
X * follows makes it hard to avoid.
X */
Xstatic char *
Xreg(paren, flagp)
Xint paren; /* Parenthesized? */
Xint *flagp;
X{
X register char *ret;
X register char *br;
X register char *ender;
X register int parno;
X int flags;
X
X *flagp = HASWIDTH; /* Tentatively. */
X
X /* Make an OPEN node, if parenthesized. */
X if (paren) {
X parno = regnpar;
X regnpar++;
X ret = reganode(OPEN, parno);
X } else
X ret = NULL;
X
X /* Pick up the branches, linking them together. */
X br = regbranch(&flags);
X if (br == NULL)
X return(NULL);
X if (ret != NULL)
X regtail(ret, br); /* OPEN -> first. */
X else
X ret = br;
X if (!(flags&HASWIDTH))
X *flagp &= ~HASWIDTH;
X *flagp |= flags&SPSTART;
X while (*regparse == '|') {
X regparse++;
X br = regbranch(&flags);
X if (br == NULL)
X return(NULL);
X regtail(ret, br); /* BRANCH -> BRANCH. */
X if (!(flags&HASWIDTH))
X *flagp &= ~HASWIDTH;
X *flagp |= flags&SPSTART;
X }
X
X /* Make a closing node, and hook it on the end. */
X if (paren)
X ender = reganode(CLOSE, parno);
X else
X ender = regnode(END);
X regtail(ret, ender);
X
X /* Hook the tails of the branches to the closing node. */
X for (br = ret; br != NULL; br = regnext(br))
X regoptail(br, ender);
X
X /* Check for proper termination. */
X if (paren && *regparse++ != ')') {
X FAIL("unmatched () in regexp");
X } else if (!paren && regparse < regxend) {
X if (*regparse == ')') {
X FAIL("unmatched () in regexp");
X } else
X FAIL("junk on end of regexp"); /* "Can't happen". */
X /* NOTREACHED */
X }
X
X return(ret);
X}
X
X/*
X - regbranch - one alternative of an | operator
X *
X * Implements the concatenation operator.
X */
Xstatic char *
Xregbranch(flagp)
Xint *flagp;
X{
X register char *ret;
X register char *chain;
X register char *latest;
X int flags;
X
X *flagp = WORST; /* Tentatively. */
X
X ret = regnode(BRANCH);
X chain = NULL;
X while (regparse < regxend && *regparse != '|' && *regparse != ')') {
X latest = regpiece(&flags);
X if (latest == NULL)
X return(NULL);
X *flagp |= flags&HASWIDTH;
X if (chain == NULL) /* First piece. */
X *flagp |= flags&SPSTART;
X else
X regtail(chain, latest);
X chain = latest;
X }
X if (chain == NULL) /* Loop ran zero times. */
X (void) regnode(NOTHING);
X
X return(ret);
X}
X
X/*
X - regpiece - something followed by possible [*+?]
X *
X * Note that the branching code sequences used for ? and the general cases
X * of * and + are somewhat optimized: they use the same NOTHING node as
X * both the endmarker for their branch list and the body of the last branch.
X * It might seem that this node could be dispensed with entirely, but the
X * endmarker role is not redundant.
X */
Xstatic char *
Xregpiece(flagp)
Xint *flagp;
X{
X register char *ret;
X register char op;
X register char *next;
X int flags;
X char *origparse = regparse;
X int orignpar = regnpar;
X char *max;
X int iter;
X char ch;
X
X ret = regatom(&flags);
X if (ret == NULL)
X return(NULL);
X
X op = *regparse;
X
X /* Here's a total kludge: if after the atom there's a {\d+,?\d*}
X * then we decrement the first number by one and reset our
X * parsing back to the beginning of the same atom. If the first number
X * is down to 0, decrement the second number instead and fake up
X * a ? after it. Given the way this compiler doesn't keep track
X * of offsets on the first pass, this is the only way to replicate
X * a piece of code. Sigh.
X */
X if (op == '{' && regcurly(regparse)) {
X next = regparse + 1;
X max = Nullch;
X while (isdigit(*next) || *next == ',') {
X if (*next == ',') {
X if (max)
X break;
X else
X max = next;
X }
X next++;
X }
X if (*next == '}') { /* got one */
X if (!max)
X max = next;
X regparse++;
X iter = atoi(regparse);
X if (flags&SIMPLE) { /* we can do it right after all */
X int tmp;
X
X reginsert(CURLY, ret);
X if (iter > 0)
X *flagp = (WORST|HASWIDTH);
X if (*max == ',')
X max++;
X else
X max = regparse;
X tmp = atoi(max);
X if (tmp && tmp < iter)
X fatal("Can't do {n,m} with n > m");
X if (regcode != ®dummy) {
X#ifdef REGALIGN
X *(unsigned short *)(ret+3) = iter;
X *(unsigned short *)(ret+5) = tmp;
X#else
X ret[3] = iter >> 8; ret[4] = iter & 0377;
X ret[5] = tmp >> 8; ret[6] = tmp & 0377;
X#endif
X }
X regparse = next;
X goto nest_check;
X }
X regsawbracket++; /* remember we clobbered exp */
X if (iter > 0) {
X ch = *max;
X sprintf(regparse,"%.*d", max-regparse, iter - 1);
X *max = ch;
X if (*max == ',' && max[1] != '}') {
X if (atoi(max+1) <= 0)
X fatal("Can't do {n,m} with n > m");
X ch = *next;
X sprintf(max+1,"%.*d", next-(max+1), atoi(max+1) - 1);
X *next = ch;
X }
X if (iter != 1 || *max == ',') {
X regparse = origparse; /* back up input pointer */
X regnpar = orignpar; /* don't make more parens */
X }
X else {
X regparse = next;
X goto nest_check;
X }
X *flagp = flags;
X return ret;
X }
X if (*max == ',') {
X max++;
X iter = atoi(max);
X if (max == next) { /* any number more? */
X regparse = next;
X op = '*'; /* fake up one with a star */
X }
X else if (iter > 0) {
X op = '?'; /* fake up optional atom */
X ch = *next;
X sprintf(max,"%.*d", next-max, iter - 1);
X *next = ch;
X if (iter == 1)
X regparse = next;
X else {
X regparse = origparse - 1; /* offset ++ below */
X regnpar = orignpar;
X }
X }
X else
X fatal("Can't do {n,0}");
X }
X else
X fatal("Can't do {0}");
X }
X }
X
X if (!ISMULT1(op)) {
X *flagp = flags;
X return(ret);
X }
X
X if (!(flags&HASWIDTH) && op != '?')
X FAIL("regexp *+ operand could be empty");
X *flagp = (op != '+') ? (WORST|SPSTART) : (WORST|HASWIDTH);
X
X if (op == '*' && (flags&SIMPLE))
X reginsert(STAR, ret);
X else if (op == '*') {
X /* Emit x* as (x&|), where & means "self". */
X reginsert(BRANCH, ret); /* Either x */
X regoptail(ret, regnode(BACK)); /* and loop */
X regoptail(ret, ret); /* back */
X regtail(ret, regnode(BRANCH)); /* or */
X regtail(ret, regnode(NOTHING)); /* null. */
X } else if (op == '+' && (flags&SIMPLE))
X reginsert(PLUS, ret);
X else if (op == '+') {
X /* Emit x+ as x(&|), where & means "self". */
X next = regnode(BRANCH); /* Either */
X regtail(ret, next);
X regtail(regnode(BACK), ret); /* loop back */
X regtail(next, regnode(BRANCH)); /* or */
X regtail(ret, regnode(NOTHING)); /* null. */
X } else if (op == '?') {
X /* Emit x? as (x|) */
X reginsert(BRANCH, ret); /* Either x */
X regtail(ret, regnode(BRANCH)); /* or */
X next = regnode(NOTHING); /* null. */
X regtail(ret, next);
X regoptail(ret, next);
X }
X nest_check:
X regparse++;
X if (ISMULT2(regparse))
X FAIL("nested *?+ in regexp");
X
X return(ret);
X}
X
X/*
X - regatom - the lowest level
X *
X * Optimization: gobbles an entire sequence of ordinary characters so that
X * it can turn them into a single node, which is smaller to store and
X * faster to run. Backslashed characters are exceptions, each becoming a
X * separate node; the code is simpler that way and it's not worth fixing.
X *
X * [Yes, it is worth fixing, some scripts can run twice the speed.]
X */
Xstatic char *
Xregatom(flagp)
Xint *flagp;
X{
X register char *ret;
X int flags;
X
X *flagp = WORST; /* Tentatively. */
X
X switch (*regparse++) {
X case '^':
X ret = regnode(BOL);
X break;
X case '$':
X ret = regnode(EOL);
X break;
X case '.':
X ret = regnode(ANY);
X *flagp |= HASWIDTH|SIMPLE;
X break;
X case '[':
X ret = regclass();
X *flagp |= HASWIDTH|SIMPLE;
X break;
X case '(':
X ret = reg(1, &flags);
X if (ret == NULL)
X return(NULL);
X *flagp |= flags&(HASWIDTH|SPSTART);
X break;
X case '|':
X case ')':
X FAIL("internal urp in regexp"); /* Supposed to be caught earlier. */
X break;
X case '?':
X case '+':
X case '*':
X FAIL("?+* follows nothing in regexp");
X break;
X case '\\':
X switch (*regparse) {
X case 'w':
X ret = regnode(ALNUM);
X *flagp |= HASWIDTH|SIMPLE;
X regparse++;
X break;
X case 'W':
X ret = regnode(NALNUM);
X *flagp |= HASWIDTH|SIMPLE;
X regparse++;
X break;
X case 'b':
X ret = regnode(BOUND);
X *flagp |= SIMPLE;
X regparse++;
X break;
X case 'B':
X ret = regnode(NBOUND);
X *flagp |= SIMPLE;
X regparse++;
X break;
X case 's':
X ret = regnode(SPACE);
X *flagp |= HASWIDTH|SIMPLE;
X regparse++;
X break;
X case 'S':
X ret = regnode(NSPACE);
X *flagp |= HASWIDTH|SIMPLE;
X regparse++;
X break;
X case 'd':
X ret = regnode(DIGIT);
X *flagp |= HASWIDTH|SIMPLE;
X regparse++;
X break;
X case 'D':
X ret = regnode(NDIGIT);
X *flagp |= HASWIDTH|SIMPLE;
X regparse++;
X break;
X case 'n':
X case 'r':
X case 't':
X case 'f':
X case 'e':
X case 'a':
X case 'x':
X case 'c':
X case '0':
X goto defchar;
X case '1': case '2': case '3': case '4':
X case '5': case '6': case '7': case '8': case '9':
X {
X int num = atoi(regparse);
X
X if (num > 9 && num >= regnpar)
X goto defchar;
X else {
X ret = reganode(REF, num);
X while (isascii(*regparse) && isdigit(*regparse))
X regparse++;
X *flagp |= SIMPLE;
X }
X }
X break;
X case '\0':
X if (regparse >= regxend)
X FAIL("trailing \\ in regexp");
X /* FALL THROUGH */
X default:
X goto defchar;
X }
X break;
X default: {
X register int len;
X register char ender;
X register char *p;
X char *oldp;
X int numlen;
X
X defchar:
X ret = regnode(EXACTLY);
X regc(0); /* save spot for len */
X for (len=0, p=regparse-1;
X len < 127 && p < regxend;
X len++)
X {
X oldp = p;
X switch (*p) {
X case '^':
X case '$':
X case '.':
X case '[':
X case '(':
X case ')':
X case '|':
X goto loopdone;
X case '\\':
X switch (*++p) {
X case 'w':
X case 'W':
X case 'b':
X case 'B':
X case 's':
X case 'S':
X case 'd':
X case 'D':
X --p;
X goto loopdone;
X case 'n':
X ender = '\n';
X p++;
X break;
X case 'r':
X ender = '\r';
X p++;
X break;
X case 't':
X ender = '\t';
X p++;
X break;
X case 'f':
X ender = '\f';
X p++;
X break;
X case 'e':
X ender = '\033';
X p++;
X break;
X case 'a':
X ender = '\007';
X p++;
X break;
X case 'x':
X ender = scanhex(++p, 2, &numlen);
X p += numlen;
X break;
X case 'c':
X p++;
X ender = *p++;
X if (islower(ender))
X ender = toupper(ender);
X ender ^= 64;
X break;
X case '0': case '1': case '2': case '3':case '4':
X case '5': case '6': case '7': case '8':case '9':
X if (*p == '0' ||
X (isdigit(p[1]) && atoi(p) >= regnpar) ) {
X ender = scanoct(p, 3, &numlen);
X p += numlen;
X }
X else {
X --p;
X goto loopdone;
X }
X break;
X case '\0':
X if (p >= regxend)
X FAIL("trailing \\ in regexp");
X /* FALL THROUGH */
X default:
X ender = *p++;
X break;
X }
X break;
X default:
X ender = *p++;
X break;
X }
X if (regfold && isupper(ender))
X ender = tolower(ender);
X if (ISMULT2(p)) { /* Back off on ?+*. */
X if (len)
X p = oldp;
X else {
X len++;
X regc(ender);
X }
X break;
X }
X regc(ender);
X }
X loopdone:
X regparse = p;
X if (len <= 0)
X FAIL("internal disaster in regexp");
X *flagp |= HASWIDTH;
X if (len == 1)
X *flagp |= SIMPLE;
X if (regcode != ®dummy)
X *OPERAND(ret) = len;
X regc('\0');
X }
X break;
X }
X
X return(ret);
X}
X
Xstatic void
Xregset(bits,def,c)
Xchar *bits;
Xint def;
Xregister int c;
X{
X if (regcode == ®dummy)
X return;
X c &= 255;
X if (def)
X bits[c >> 3] &= ~(1 << (c & 7));
X else
X bits[c >> 3] |= (1 << (c & 7));
X}
X
Xstatic char *
Xregclass()
X{
X register char *bits;
X register int class;
X register int lastclass;
X register int range = 0;
X register char *ret;
X register int def;
X int numlen;
X
X ret = regnode(ANYOF);
X if (*regparse == '^') { /* Complement of range. */
X regparse++;
X def = 0;
X } else {
X def = 255;
X }
X bits = regcode;
X for (class = 0; class < 32; class++)
X regc(def);
X if (*regparse == ']' || *regparse == '-')
X goto skipcond; /* allow 1st char to be ] or - */
X while (regparse < regxend && *regparse != ']') {
X skipcond:
X class = UCHARAT(regparse++);
X if (class == '\\') {
X class = UCHARAT(regparse++);
X switch (class) {
X case 'w':
X for (class = 'a'; class <= 'z'; class++)
X regset(bits,def,class);
X for (class = 'A'; class <= 'Z'; class++)
X regset(bits,def,class);
X for (class = '0'; class <= '9'; class++)
X regset(bits,def,class);
X regset(bits,def,'_');
X lastclass = 1234;
X continue;
X case 's':
X regset(bits,def,' ');
X regset(bits,def,'\t');
X regset(bits,def,'\r');
X regset(bits,def,'\f');
X regset(bits,def,'\n');
X lastclass = 1234;
X continue;
X case 'd':
X for (class = '0'; class <= '9'; class++)
X regset(bits,def,class);
X lastclass = 1234;
X continue;
X case 'n':
X class = '\n';
X break;
X case 'r':
X class = '\r';
X break;
X case 't':
X class = '\t';
X break;
X case 'f':
X class = '\f';
X break;
X case 'b':
X class = '\b';
X break;
X case 'e':
X class = '\033';
X break;
X case 'a':
X class = '\007';
X break;
X case 'x':
X class = scanhex(regparse, 2, &numlen);
X regparse += numlen;
X break;
X case 'c':
X class = *regparse++;
X if (islower(class))
X class = toupper(class);
X class ^= 64;
X break;
X case '0': case '1': case '2': case '3': case '4':
X case '5': case '6': case '7': case '8': case '9':
X class = scanoct(--regparse, 3, &numlen);
X regparse += numlen;
X break;
X }
X }
X if (range) {
X if (lastclass > class)
X FAIL("invalid [] range in regexp");
X range = 0;
X }
X else {
X lastclass = class;
X if (*regparse == '-' && regparse+1 < regxend &&
X regparse[1] != ']') {
X regparse++;
X range = 1;
X continue; /* do it next time */
X }
X }
X for ( ; lastclass <= class; lastclass++) {
X regset(bits,def,lastclass);
X if (regfold && isupper(lastclass))
X regset(bits,def,tolower(lastclass));
X }
X lastclass = class;
X }
X if (*regparse != ']')
X FAIL("unmatched [] in regexp");
X regparse++;
X return ret;
X}
X
X/*
X - regnode - emit a node
X */
Xstatic char * /* Location. */
Xregnode(op)
Xchar op;
X{
X register char *ret;
X register char *ptr;
X
X ret = regcode;
X if (ret == ®dummy) {
X#ifdef REGALIGN
X if (!(regsize & 1))
X regsize++;
X#endif
X regsize += 3;
X return(ret);
X }
X
X#ifdef REGALIGN
X#ifndef lint
X if (!((long)ret & 1))
X *ret++ = 127;
X#endif
X#endif
X ptr = ret;
X *ptr++ = op;
X *ptr++ = '\0'; /* Null "next" pointer. */
X *ptr++ = '\0';
X regcode = ptr;
X
X return(ret);
X}
X
X/*
X - reganode - emit a node with an argument
X */
Xstatic char * /* Location. */
Xreganode(op, arg)
Xchar op;
Xunsigned short arg;
X{
X register char *ret;
X register char *ptr;
X
X ret = regcode;
X if (ret == ®dummy) {
X#ifdef REGALIGN
X if (!(regsize & 1))
X regsize++;
X#endif
X regsize += 5;
X return(ret);
X }
X
X#ifdef REGALIGN
X#ifndef lint
X if (!((long)ret & 1))
X *ret++ = 127;
X#endif
X#endif
X ptr = ret;
X *ptr++ = op;
X *ptr++ = '\0'; /* Null "next" pointer. */
X *ptr++ = '\0';
X#ifdef REGALIGN
X *(unsigned short *)(ret+3) = arg;
X#else
X ret[3] = arg >> 8; ret[4] = arg & 0377;
X#endif
X ptr += 2;
X regcode = ptr;
X
X return(ret);
X}
X
X/*
X - regc - emit (if appropriate) a byte of code
X */
Xstatic void
Xregc(b)
Xchar b;
X{
X if (regcode != ®dummy)
X *regcode++ = b;
X else
X regsize++;
X}
X
X/*
X - reginsert - insert an operator in front of already-emitted operand
X *
X * Means relocating the operand.
X */
Xstatic void
Xreginsert(op, opnd)
Xchar op;
Xchar *opnd;
X{
X register char *src;
X register char *dst;
X register char *place;
X register offset = (op == CURLY ? 4 : 0);
X
X if (regcode == ®dummy) {
X#ifdef REGALIGN
X regsize += 4 + offset;
X#else
X regsize += 3 + offset;
X#endif
X return;
X }
X
X src = regcode;
X#ifdef REGALIGN
X regcode += 4 + offset;
X#else
X regcode += 3 + offset;
X#endif
X dst = regcode;
X while (src > opnd)
X *--dst = *--src;
X
X place = opnd; /* Op node, where operand used to be. */
X *place++ = op;
X *place++ = '\0';
X *place++ = '\0';
X while (offset-- > 0)
X *place++ = '\0';
X}
X
X/*
X - regtail - set the next-pointer at the end of a node chain
X */
Xstatic void
Xregtail(p, val)
Xchar *p;
Xchar *val;
X{
X register char *scan;
X register char *temp;
X register int offset;
X
X if (p == ®dummy)
X return;
X
X /* Find last node. */
X scan = p;
X for (;;) {
X temp = regnext(scan);
X if (temp == NULL)
X break;
X scan = temp;
X }
X
X#ifdef REGALIGN
X offset = val - scan;
X#ifndef lint
X *(short*)(scan+1) = offset;
X#else
X offset = offset;
X#endif
X#else
X if (OP(scan) == BACK)
X offset = scan - val;
X else
X offset = val - scan;
X *(scan+1) = (offset>>8)&0377;
X *(scan+2) = offset&0377;
X#endif
X}
X
X/*
X - regoptail - regtail on operand of first argument; nop if operandless
X */
Xstatic void
Xregoptail(p, val)
Xchar *p;
Xchar *val;
X{
X /* "Operandless" and "op != BRANCH" are synonymous in practice. */
X if (p == NULL || p == ®dummy || OP(p) != BRANCH)
X return;
X regtail(NEXTOPER(p), val);
X}
X
X/*
X - regcurly - a little FSA that accepts {\d+,?\d*}
X */
XSTATIC int
Xregcurly(s)
Xregister char *s;
X{
X if (*s++ != '{')
X return FALSE;
X if (!isdigit(*s))
X return FALSE;
X while (isdigit(*s))
X s++;
X if (*s == ',')
X s++;
X while (isdigit(*s))
X s++;
X if (*s != '}')
X return FALSE;
X return TRUE;
X}
X
X#ifdef DEBUGGING
X
X/*
X - regdump - dump a regexp onto stderr in vaguely comprehensible form
X */
Xvoid
Xregdump(r)
Xregexp *r;
X{
X register char *s;
X register char op = EXACTLY; /* Arbitrary non-END op. */
X register char *next;
X
X
X s = r->program + 1;
X while (op != END) { /* While that wasn't END last time... */
X#ifdef REGALIGN
X if (!((long)s & 1))
X s++;
X#endif
X op = OP(s);
X fprintf(stderr,"%2d%s", s-r->program, regprop(s)); /* Where, what. */
X next = regnext(s);
X s += regarglen[op];
X if (next == NULL) /* Next ptr. */
X fprintf(stderr,"(0)");
X else
X fprintf(stderr,"(%d)", (s-r->program)+(next-s));
X s += 3;
X if (op == ANYOF) {
X s += 32;
X }
X if (op == EXACTLY) {
X /* Literal string, where present. */
X s++;
X while (*s != '\0') {
X (void)putchar(*s);
X s++;
X }
X s++;
X }
X (void)putchar('\n');
X }
X
X /* Header fields of interest. */
X if (r->regstart)
X fprintf(stderr,"start `%s' ", r->regstart->str_ptr);
X if (r->regstclass)
X fprintf(stderr,"stclass `%s' ", regprop(r->regstclass));
X if (r->reganch & 1)
X fprintf(stderr,"anchored ");
X if (r->reganch & 2)
X fprintf(stderr,"plus ");
X if (r->regmust != NULL)
X fprintf(stderr,"must have \"%s\" back %d ", r->regmust->str_ptr,
X r->regback);
X fprintf(stderr,"\n");
X}
X
X/*
X - regprop - printable representation of opcode
X */
Xchar *
Xregprop(op)
Xchar *op;
X{
X register char *p;
X
X (void) strcpy(buf, ":");
X
X switch (OP(op)) {
X case BOL:
X p = "BOL";
X break;
X case EOL:
X p = "EOL";
X break;
X case ANY:
X p = "ANY";
X break;
X case ANYOF:
X p = "ANYOF";
X break;
X case BRANCH:
X p = "BRANCH";
X break;
X case EXACTLY:
X p = "EXACTLY";
X break;
X case NOTHING:
X p = "NOTHING";
X break;
X case BACK:
X p = "BACK";
X break;
X case END:
X p = "END";
X break;
X case ALNUM:
X p = "ALNUM";
X break;
X case NALNUM:
X p = "NALNUM";
X break;
X case BOUND:
X p = "BOUND";
X break;
X case NBOUND:
X p = "NBOUND";
X break;
X case SPACE:
X p = "SPACE";
X break;
X case NSPACE:
X p = "NSPACE";
X break;
X case DIGIT:
X p = "DIGIT";
X break;
X case NDIGIT:
X p = "NDIGIT";
X break;
X case CURLY:
X (void)sprintf(buf+strlen(buf), "CURLY {%d,%d}",
X ARG1(op),ARG2(op));
X p = NULL;
X break;
X case REF:
X (void)sprintf(buf+strlen(buf), "REF%d", ARG1(op));
X p = NULL;
X break;
X case OPEN:
X (void)sprintf(buf+strlen(buf), "OPEN%d", ARG1(op));
X p = NULL;
X break;
X case CLOSE:
X (void)sprintf(buf+strlen(buf), "CLOSE%d", ARG1(op));
X p = NULL;
X break;
X case STAR:
X p = "STAR";
X break;
X case PLUS:
X p = "PLUS";
X break;
X default:
X FAIL("corrupted regexp opcode");
X }
X if (p != NULL)
X (void) strcat(buf, p);
X return(buf);
X}
X#endif /* DEBUGGING */
X
Xregfree(r)
Xstruct regexp *r;
X{
X if (r->precomp) {
X Safefree(r->precomp);
X r->precomp = Nullch;
X }
X if (r->subbase) {
X Safefree(r->subbase);
X r->subbase = Nullch;
X }
X if (r->regmust) {
X str_free(r->regmust);
X r->regmust = Nullstr;
X }
X if (r->regstart) {
X str_free(r->regstart);
X r->regstart = Nullstr;
X }
X Safefree(r->startp);
X Safefree(r->endp);
X Safefree(r);
X}
!STUFFY!FUNK!
echo Extracting emacs/perldb.el
sed >emacs/perldb.el <<'!STUFFY!FUNK!' -e 's/X//'
X;; Run perl -d under Emacs
X;; Based on gdb.el, as written by W. Schelter, and modified by rms.
X;; Modified for Perl by Ray Lischner (uunet!mntgfx!lisch), Nov 1990.
X
X;; This file is part of GNU Emacs.
X;; Copyright (C) 1988,1990 Free Software Foundation, Inc.
X
X;; GNU Emacs is distributed in the hope that it will be useful, but
X;; WITHOUT ANY WARRANTY. No author or distributor accepts responsibility
X;; to anyone for the consequences of using it or for whether it serves
X;; any particular purpose or works at all, unless he says so in writing.
X;; Refer to the GNU Emacs General Public License for full details.
X
X;; Everyone is granted permission to copy, modify and redistribute GNU
X;; Emacs, but only under the conditions described in the GNU Emacs
X;; General Public License. A copy of this license is supposed to have
X;; been given to you along with GNU Emacs so you can know your rights and
X;; responsibilities. It should be in a file named COPYING. Among other
X;; things, the copyright notice and this notice must be preserved on all
X;; copies.
X
X;; Description of perl -d interface:
X
X;; A facility is provided for the simultaneous display of the source code
X;; in one window, while using perldb to step through a function in the
X;; other. A small arrow in the source window, indicates the current
X;; line.
X
X;; Starting up:
X
X;; In order to use this facility, invoke the command PERLDB to obtain a
X;; shell window with the appropriate command bindings. You will be asked
X;; for the name of a file to run and additional command line arguments.
X;; Perldb will be invoked on this file, in a window named *perldb-foo*
X;; if the file is foo.
X
X;; M-s steps by one line, and redisplays the source file and line.
X
X;; You may easily create additional commands and bindings to interact
X;; with the display. For example to put the perl debugger command n on \M-n
X;; (def-perldb n "\M-n")
X
X;; This causes the emacs command perldb-next to be defined, and runs
X;; perldb-display-frame after the command.
X
X;; perldb-display-frame is the basic display function. It tries to display
X;; in the other window, the file and line corresponding to the current
X;; position in the perldb window. For example after a perldb-step, it would
X;; display the line corresponding to the position for the last step. Or
X;; if you have done a backtrace in the perldb buffer, and move the cursor
X;; into one of the frames, it would display the position corresponding to
X;; that frame.
X
X;; perldb-display-frame is invoked automatically when a filename-and-line-number
X;; appears in the output.
X
X
X(require 'shell)
X
X(defvar perldb-prompt-pattern "^ DB<[0-9]+> "
X "A regexp to recognize the prompt for perldb.")
X
X(defvar perldb-mode-map nil
X "Keymap for perldb-mode.")
X
X(if perldb-mode-map
X nil
X (setq perldb-mode-map (copy-keymap shell-mode-map))
X (define-key perldb-mode-map "\C-l" 'perldb-refresh))
X
X(define-key ctl-x-map " " 'perldb-break)
X(define-key ctl-x-map "&" 'send-perldb-command)
X
X;;Of course you may use `def-perldb' with any other perldb command, including
X;;user defined ones.
X
X(defmacro def-perldb (name key &optional doc)
X (let* ((fun (intern (concat "perldb-" name))))
X (` (progn
X (defun (, fun) (arg)
X (, (or doc ""))
X (interactive "p")
X (perldb-call (if (not (= 1 arg))
X (concat (, name) arg)
X (, name))))
X (define-key perldb-mode-map (, key) (quote (, fun)))))))
X
X(def-perldb "s" "\M-s" "Step one source line with display")
X(def-perldb "n" "\M-n" "Step one source line (skip functions)")
X(def-perldb "c" "\M-c" "Continue with display")
X(def-perldb "r" "\C-c\C-r" "Return from current subroutine")
X(def-perldb "A" "\C-c\C-a" "Delete all actions")
X
X(defun perldb-mode ()
X "Major mode for interacting with an inferior Perl debugger process.
XThe following commands are available:
X
X\\{perldb-mode-map}
X
X\\[perldb-display-frame] displays in the other window
Xthe last line referred to in the perldb buffer.
X
X\\[perldb-s],\\[perldb-n], and \\[perldb-n] in the perldb window,
Xcall perldb to step, next or continue and then update the other window
Xwith the current file and position.
X
XIf you are in a source file, you may select a point to break
Xat, by doing \\[perldb-break].
X
XCommands:
XMany commands are inherited from shell mode.
XAdditionally we have:
X
X\\[perldb-display-frame] display frames file in other window
X\\[perldb-s] advance one line in program
X\\[perldb-n] advance one line in program (skip over calls).
X\\[send-perldb-command] used for special printing of an arg at the current point.
XC-x SPACE sets break point at current line."
X (interactive)
X (kill-all-local-variables)
X (setq major-mode 'perldb-mode)
X (setq mode-name "Inferior Perl")
X (setq mode-line-process '(": %s"))
X (use-local-map perldb-mode-map)
X (make-local-variable 'last-input-start)
X (setq last-input-start (make-marker))
X (make-local-variable 'last-input-end)
X (setq last-input-end (make-marker))
X (make-local-variable 'perldb-last-frame)
X (setq perldb-last-frame nil)
X (make-local-variable 'perldb-last-frame-displayed-p)
X (setq perldb-last-frame-displayed-p t)
X (make-local-variable 'perldb-delete-prompt-marker)
X (setq perldb-delete-prompt-marker nil)
X (make-local-variable 'perldb-filter-accumulator)
X (setq perldb-filter-accumulator nil)
X (make-local-variable 'shell-prompt-pattern)
X (setq shell-prompt-pattern perldb-prompt-pattern)
X (run-hooks 'shell-mode-hook 'perldb-mode-hook))
X
X(defvar current-perldb-buffer nil)
X
X(defvar perldb-command-name "perl"
X "Pathname for executing perl -d.")
X
X(defun end-of-quoted-arg (argstr start end)
X (let* ((chr (substring argstr start (1+ start)))
X (idx (string-match (concat "[^\\]" chr) argstr (1+ start))))
X (and idx (1+ idx))
X )
X)
X
X(defun parse-args-helper (arglist argstr start end)
X (while (and (< start end) (string-match "[ \t\n\f\r\b]"
X (substring argstr start (1+ start))))
X (setq start (1+ start)))
X (cond
X ((= start end) arglist)
X ((string-match "[\"']" (substring argstr start (1+ start)))
X (let ((next (end-of-quoted-arg argstr start end)))
X (parse-args-helper (cons (substring argstr (1+ start) next) arglist)
X argstr (1+ next) end)))
X (t (let ((next (string-match "[ \t\n\f\b\r]" argstr start)))
X (if next
X (parse-args-helper (cons (substring argstr start next) arglist)
X argstr (1+ next) end)
X (cons (substring argstr start) arglist))))
X )
X )
X
X(defun parse-args (args)
X "Extract arguments from a string ARGS.
XWhite space separates arguments, with single or double quotes
Xused to protect spaces. A list of strings is returned, e.g.,
X(parse-args \"foo bar 'two args'\") => (\"foo\" \"bar\" \"two args\")."
X (nreverse (parse-args-helper '() args 0 (length args)))
X)
X
X(defun perldb (path args)
X "Run perldb on program FILE in buffer *perldb-FILE*.
XThe default directory for the current buffer becomes the initial
Xworking directory, by analogy with gdb . If you wish to change this, use
Xthe Perl command `chdir(DIR)'."
X (interactive "FRun perl -d on file: \nsCommand line arguments: ")
X (setq path (expand-file-name path))
X (let ((file (file-name-nondirectory path))
X (dir default-directory))
X (switch-to-buffer (concat "*perldb-" file "*"))
X (setq default-directory dir)
X (or (bolp) (newline))
X (insert "Current directory is " default-directory "\n")
X (apply 'make-shell
X (concat "perldb-" file) perldb-command-name nil "-d" path "-emacs"
X (parse-args args))
X (perldb-mode)
X (set-process-filter (get-buffer-process (current-buffer)) 'perldb-filter)
X (set-process-sentinel (get-buffer-process (current-buffer)) 'perldb-sentinel)
X (perldb-set-buffer)))
X
X(defun perldb-set-buffer ()
X (cond ((eq major-mode 'perldb-mode)
X (setq current-perldb-buffer (current-buffer)))))
X
X;; This function is responsible for inserting output from Perl
X;; into the buffer.
X;; Aside from inserting the text, it notices and deletes
X;; each filename-and-line-number;
X;; that Perl prints to identify the selected frame.
X;; It records the filename and line number, and maybe displays that file.
X(defun perldb-filter (proc string)
X (let ((inhibit-quit t))
X (if perldb-filter-accumulator
X (perldb-filter-accumulate-marker proc
X (concat perldb-filter-accumulator string))
X (perldb-filter-scan-input proc string))))
X
X(defun perldb-filter-accumulate-marker (proc string)
X (setq perldb-filter-accumulator nil)
X (if (> (length string) 1)
X (if (= (aref string 1) ?\032)
X (let ((end (string-match "\n" string)))
X (if end
X (progn
X (let* ((first-colon (string-match ":" string 2))
X (second-colon
X (string-match ":" string (1+ first-colon))))
X (setq perldb-last-frame
X (cons (substring string 2 first-colon)
X (string-to-int
X (substring string (1+ first-colon)
X second-colon)))))
X (setq perldb-last-frame-displayed-p nil)
X (perldb-filter-scan-input proc
X (substring string (1+ end))))
X (setq perldb-filter-accumulator string)))
X (perldb-filter-insert proc "\032")
X (perldb-filter-scan-input proc (substring string 1)))
X (setq perldb-filter-accumulator string)))
X
X(defun perldb-filter-scan-input (proc string)
X (if (equal string "")
X (setq perldb-filter-accumulator nil)
X (let ((start (string-match "\032" string)))
X (if start
X (progn (perldb-filter-insert proc (substring string 0 start))
X (perldb-filter-accumulate-marker proc
X (substring string start)))
X (perldb-filter-insert proc string)))))
X
X(defun perldb-filter-insert (proc string)
X (let ((moving (= (point) (process-mark proc)))
X (output-after-point (< (point) (process-mark proc)))
X (old-buffer (current-buffer))
X start)
X (set-buffer (process-buffer proc))
X (unwind-protect
X (save-excursion
X ;; Insert the text, moving the process-marker.
X (goto-char (process-mark proc))
X (setq start (point))
X (insert string)
X (set-marker (process-mark proc) (point))
X (perldb-maybe-delete-prompt)
X ;; Check for a filename-and-line number.
X (perldb-display-frame
X ;; Don't display the specified file
X ;; unless (1) point is at or after the position where output appears
X ;; and (2) this buffer is on the screen.
X (or output-after-point
X (not (get-buffer-window (current-buffer))))
X ;; Display a file only when a new filename-and-line-number appears.
X t))
X (set-buffer old-buffer))
X (if moving (goto-char (process-mark proc)))))
X
X(defun perldb-sentinel (proc msg)
X (cond ((null (buffer-name (process-buffer proc)))
X ;; buffer killed
X ;; Stop displaying an arrow in a source file.
X (setq overlay-arrow-position nil)
X (set-process-buffer proc nil))
X ((memq (process-status proc) '(signal exit))
X ;; Stop displaying an arrow in a source file.
X (setq overlay-arrow-position nil)
X ;; Fix the mode line.
X (setq mode-line-process
X (concat ": "
X (symbol-name (process-status proc))))
X (let* ((obuf (current-buffer)))
X ;; save-excursion isn't the right thing if
X ;; process-buffer is current-buffer
X (unwind-protect
X (progn
X ;; Write something in *compilation* and hack its mode line,
X (set-buffer (process-buffer proc))
X ;; Force mode line redisplay soon
X (set-buffer-modified-p (buffer-modified-p))
X (if (eobp)
X (insert ?\n mode-name " " msg)
X (save-excursion
X (goto-char (point-max))
X (insert ?\n mode-name " " msg)))
X ;; If buffer and mode line will show that the process
X ;; is dead, we can delete it now. Otherwise it
X ;; will stay around until M-x list-processes.
X (delete-process proc))
X ;; Restore old buffer, but don't restore old point
X ;; if obuf is the perldb buffer.
X (set-buffer obuf))))))
X
X
X(defun perldb-refresh ()
X "Fix up a possibly garbled display, and redraw the arrow."
X (interactive)
X (redraw-display)
X (perldb-display-frame))
X
X(defun perldb-display-frame (&optional nodisplay noauto)
X "Find, obey and delete the last filename-and-line marker from PERLDB.
XThe marker looks like \\032\\032FILENAME:LINE:CHARPOS\\n.
XObeying it means displaying in another window the specified file and line."
X (interactive)
X (perldb-set-buffer)
X (and perldb-last-frame (not nodisplay)
X (or (not perldb-last-frame-displayed-p) (not noauto))
X (progn (perldb-display-line (car perldb-last-frame) (cdr perldb-last-frame))
X (setq perldb-last-frame-displayed-p t))))
X
X;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen
X;; and that its line LINE is visible.
X;; Put the overlay-arrow on the line LINE in that buffer.
X
X(defun perldb-display-line (true-file line)
X (let* ((buffer (find-file-noselect true-file))
X (window (display-buffer buffer t))
X (pos))
X (save-excursion
X (set-buffer buffer)
X (save-restriction
X (widen)
X (goto-line line)
X (setq pos (point))
X (setq overlay-arrow-string "=>")
X (or overlay-arrow-position
X (setq overlay-arrow-position (make-marker)))
X (set-marker overlay-arrow-position (point) (current-buffer)))
X (cond ((or (< pos (point-min)) (> pos (point-max)))
X (widen)
X (goto-char pos))))
X (set-window-point window overlay-arrow-position)))
X
X(defun perldb-call (command)
X "Invoke perldb COMMAND displaying source in other window."
X (interactive)
X (goto-char (point-max))
X (setq perldb-delete-prompt-marker (point-marker))
X (perldb-set-buffer)
X (send-string (get-buffer-process current-perldb-buffer)
X (concat command "\n")))
X
X(defun perldb-maybe-delete-prompt ()
X (if (and perldb-delete-prompt-marker
X (> (point-max) (marker-position perldb-delete-prompt-marker)))
X (let (start)
X (goto-char perldb-delete-prompt-marker)
X (setq start (point))
X (beginning-of-line)
X (delete-region (point) start)
X (setq perldb-delete-prompt-marker nil))))
X
X(defun perldb-break ()
X "Set PERLDB breakpoint at this source line."
X (interactive)
X (let ((line (save-restriction
X (widen)
X (1+ (count-lines 1 (point))))))
X (send-string (get-buffer-process current-perldb-buffer)
X (concat "b " line "\n"))))
X
X(defun perldb-read-token()
X "Return a string containing the token found in the buffer at point.
XA token can be a number or an identifier. If the token is a name prefaced
Xby `$', `@', or `%', the leading character is included in the token."
X (save-excursion
X (let (begin)
X (or (looking-at "[$@%]")
X (re-search-backward "[^a-zA-Z_0-9]" (point-min) 'move))
X (setq begin (point))
X (or (looking-at "[$@%]") (setq begin (+ begin 1)))
X (forward-char 1)
X (buffer-substring begin
X (if (re-search-forward "[^a-zA-Z_0-9]"
X (point-max) 'move)
X (- (point) 1)
X (point)))
X)))
X
X(defvar perldb-commands nil
X "List of strings or functions used by send-perldb-command.
XIt is for customization by the user.")
X
X(defun send-perldb-command (arg)
X "Issue a Perl debugger command selected by the prefix arg. A numeric
Xarg selects the ARG'th member COMMAND of the list perldb-commands.
XThe token under the cursor is passed to the command. If COMMAND is a
Xstring, (format COMMAND TOKEN) is inserted at the end of the perldb
Xbuffer, otherwise (funcall COMMAND TOKEN) is inserted. If there is
Xno such COMMAND, then the token itself is inserted. For example,
X\"p %s\" is a possible string to be a member of perldb-commands,
Xor \"p $ENV{%s}\"."
X (interactive "P")
X (let (comm token)
X (if arg (setq comm (nth arg perldb-commands)))
X (setq token (perldb-read-token))
X (if (eq (current-buffer) current-perldb-buffer)
X (set-mark (point)))
X (cond (comm
X (setq comm
X (if (stringp comm) (format comm token) (funcall comm token))))
X (t (setq comm token)))
X (switch-to-buffer-other-window current-perldb-buffer)
X (goto-char (dot-max))
X (insert-string comm)))
!STUFFY!FUNK!
echo Extracting eg/scan/scan_ps
sed >eg/scan/scan_ps <<'!STUFFY!FUNK!' -e 's/X//'
X#!/usr/bin/perl -P
X
X# $Header: scan_ps,v 4.0 91/03/20 01:13:29 lwall Locked $
X
X# This looks for looping processes.
X
X#if defined(mc300) || defined(mc500) || defined(mc700)
Xopen(Ps, '/bin/ps -el|') || die "scan_ps: can't run ps";
X
Xwhile (<Ps>) {
X next if /rwhod/;
X print if index(' T', substr($_,62,1)) < 0;
X}
X#else
Xopen(Ps, '/bin/ps auxww|') || die "scan_ps: can't run ps";
X
Xwhile (<Ps>) {
X next if /dataserver/;
X next if /nfsd/;
X next if /update/;
X next if /ypserv/;
X next if /rwhod/;
X next if /routed/;
X next if /pagedaemon/;
X#ifdef vax
X ($user,$pid,$cpu,$mem,$sz,$rss,$tt,$stat,$start,$time) = split;
X#else
X ($user,$pid,$cpu,$mem,$sz,$rss,$tt,$stat,$time) = split;
X#endif
X print if length($time) > 4;
X}
X#endif
!STUFFY!FUNK!
echo " "
echo "End of kit 18 (of 36)"
cat /dev/null >kit18isdone
run=''
config=''
for iskit in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36; do
if test -f kit${iskit}isdone; then
run="$run $iskit"
else
todo="$todo $iskit"
fi
done
case $todo in
'')
echo "You have run all your kits. Please read README and then type Configure."
for combo in *:AA; do
if test -f "$combo"; then
realfile=`basename $combo :AA`
cat $realfile:[A-Z][A-Z] >$realfile
rm -rf $realfile:[A-Z][A-Z]
fi
done
rm -rf kit*isdone
chmod 755 Configure
;;
*) echo "You have run$run."
echo "You still need to run$todo."
;;
esac
: Someone might mail this, so...
exit
exit 0 # Just in case...
--
Kent Landfield INTERNET: kent@sparky.IMD.Sterling.COM
Sterling Software, IMD UUCP: uunet!sparky!kent
Phone: (402) 291-8300 FAX: (402) 291-4362
Please send comp.sources.misc-related mail to kent@uunet.uu.net.