perl 3.0 beta kit [11/23]
Larry Wall
lwall at jato.Jpl.Nasa.Gov
Mon Sep 4 05:00:04 AEST 1989
#! /bin/sh
# Make a new directory for the perl sources, cd to it, and run kits 1
# thru 23 through sh. When all 23 kits have been run, read README.
echo "This is perl 3.0 kit 11 (of 23). If kit 11 is complete, the line"
echo '"'"End of kit 11 (of 23)"'" will echo at the end.'
echo ""
export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
mkdir t 2>/dev/null
echo Extracting doarg.c
sed >doarg.c <<'!STUFFY!FUNK!' -e 's/X//'
X/* $Header: arg.c,v 2.0.1.6 88/11/18 23:44:15 lwall Locked $
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 * $Log: arg.c,v $
X */
X
X#include "EXTERN.h"
X#include "perl.h"
X
X#include <signal.h>
X
Xextern unsigned char fold[];
X
Xint
Xdo_subst(str,arg,sp)
XSTR *str;
XARG *arg;
Xint sp;
X{
X register SPAT *spat;
X SPAT *rspat;
X register STR *dstr;
X register char *s = str_get(str);
X char *strend = s + str->str_cur;
X register char *m;
X char *c;
X register char *d;
X int clen;
X int iters = 0;
X register int i;
X bool once;
X char *orig;
X int safebase;
X
X rspat = spat = arg[2].arg_ptr.arg_spat;
X if (!spat || !s)
X fatal("panic: do_subst");
X else if (spat->spat_runtime) {
X nointrp = "|)";
X (void)eval(spat->spat_runtime,G_SCALAR,sp);
X m = str_get(dstr = stack->ary_array[sp+1]);
X nointrp = "";
X if (spat->spat_regexp)
X regfree(spat->spat_regexp);
X spat->spat_regexp = regcomp(m,m+dstr->str_cur,
X spat->spat_flags & SPAT_FOLD,1);
X if (spat->spat_flags & SPAT_KEEP) {
X arg_free(spat->spat_runtime); /* it won't change, so */
X spat->spat_runtime = Nullarg; /* no point compiling again */
X }
X }
X#ifdef DEBUGGING
X if (debug & 8) {
X deb("2.SPAT /%s/\n",spat->spat_regexp->precomp);
X }
X#endif
X safebase = ((!spat->spat_regexp || !spat->spat_regexp->nparens) &&
X !sawampersand);
X if (!*spat->spat_regexp->precomp && lastspat)
X spat = lastspat;
X orig = m = s;
X if (hint) {
X if (hint < s || hint > strend)
X fatal("panic: hint in do_match");
X s = hint;
X hint = Nullch;
X if (spat->spat_regexp->regback >= 0) {
X s -= spat->spat_regexp->regback;
X if (s < m)
X s = m;
X }
X else
X s = m;
X }
X else if (spat->spat_short) {
X if (spat->spat_flags & SPAT_SCANFIRST) {
X if (str->str_pok & SP_STUDIED) {
X if (screamfirst[spat->spat_short->str_rare] < 0)
X goto nope;
X else if (!(s = screaminstr(str,spat->spat_short)))
X goto nope;
X }
X#ifndef lint
X else if (!(s = fbminstr((unsigned char*)s, (unsigned char*)strend,
X spat->spat_short)))
X goto nope;
X#endif
X if (s && spat->spat_regexp->regback >= 0) {
X ++spat->spat_short->str_u.str_useful;
X s -= spat->spat_regexp->regback;
X if (s < m)
X s = m;
X }
X else
X s = m;
X }
X else if (!multiline && (*spat->spat_short->str_ptr != *s ||
X bcmp(spat->spat_short->str_ptr, s, spat->spat_slen) ))
X goto nope;
X if (--spat->spat_short->str_u.str_useful < 0) {
X str_free(spat->spat_short);
X spat->spat_short = Nullstr; /* opt is being useless */
X }
X }
X once = ((rspat->spat_flags & SPAT_ONCE) != 0);
X if (rspat->spat_flags & SPAT_CONST) { /* known replacement string? */
X if ((rspat->spat_repl[1].arg_type & A_MASK) == A_SINGLE)
X dstr = rspat->spat_repl[1].arg_ptr.arg_str;
X else { /* constant over loop, anyway */
X (void)eval(rspat->spat_repl,G_SCALAR,sp);
X dstr = stack->ary_array[sp+1];
X }
X c = str_get(dstr);
X clen = dstr->str_cur;
X if (clen <= spat->spat_slen + spat->spat_regexp->regback) {
X /* can do inplace substitution */
X if (regexec(spat->spat_regexp, s, strend, orig, 1,
X str->str_pok & SP_STUDIED ? str : Nullstr, safebase)) {
X if (spat->spat_regexp->subbase) /* oops, no we can't */
X goto long_way;
X d = s;
X lastspat = spat;
X str->str_pok = SP_VALID; /* disable possible screamer */
X if (once) {
X m = spat->spat_regexp->startp[0];
X d = spat->spat_regexp->endp[0];
X s = orig;
X if (m - s > strend - d) { /* faster to shorten from end */
X if (clen) {
X (void)bcopy(c, m, clen);
X m += clen;
X }
X i = strend - d;
X if (i > 0) {
X (void)bcopy(d, m, i);
X m += i;
X }
X *m = '\0';
X str->str_cur = m - s;
X STABSET(str);
X str_numset(arg->arg_ptr.arg_str, 1.0);
X stack->ary_array[++sp] = arg->arg_ptr.arg_str;
X return sp;
X }
X else if (i = m - s) { /* faster from front */
X d -= clen;
X m = d;
X str_chop(str,d-i);
X s += i;
X while (i--)
X *--d = *--s;
X if (clen)
X (void)bcopy(c, m, clen);
X STABSET(str);
X str_numset(arg->arg_ptr.arg_str, 1.0);
X stack->ary_array[++sp] = arg->arg_ptr.arg_str;
X return sp;
X }
X else if (clen) {
X d -= clen;
X str_chop(str,d);
X (void)bcopy(c,d,clen);
X STABSET(str);
X str_numset(arg->arg_ptr.arg_str, 1.0);
X stack->ary_array[++sp] = arg->arg_ptr.arg_str;
X return sp;
X }
X else {
X str_chop(str,d);
X STABSET(str);
X str_numset(arg->arg_ptr.arg_str, 1.0);
X stack->ary_array[++sp] = arg->arg_ptr.arg_str;
X return sp;
X }
X /* NOTREACHED */
X }
X do {
X if (iters++ > 10000)
X fatal("Substitution loop");
X m = spat->spat_regexp->startp[0];
X if (i = m - s) {
X if (s != d)
X (void)bcopy(s,d,i);
X d += i;
X }
X if (clen) {
X (void)bcopy(c,d,clen);
X d += clen;
X }
X s = spat->spat_regexp->endp[0];
X } while (regexec(spat->spat_regexp, s, strend, orig, 1, Nullstr,
X TRUE));
X if (s != d) {
X i = strend - s;
X str->str_cur = d - str->str_ptr + i;
X (void)bcopy(s,d,i+1); /* include the Null */
X }
X STABSET(str);
X str_numset(arg->arg_ptr.arg_str, (double)iters);
X stack->ary_array[++sp] = arg->arg_ptr.arg_str;
X return sp;
X }
X str_numset(arg->arg_ptr.arg_str, 0.0);
X stack->ary_array[++sp] = arg->arg_ptr.arg_str;
X return sp;
X }
X }
X else
X c = Nullch;
X if (regexec(spat->spat_regexp, s, strend, orig, 1,
X str->str_pok & SP_STUDIED ? str : Nullstr, safebase)) {
X long_way:
X dstr = str_new(str_len(str));
X str_nset(dstr,m,s-m);
X if (spat->spat_regexp->subbase)
X curspat = spat;
X lastspat = spat;
X do {
X if (iters++ > 10000)
X fatal("Substitution loop");
X if (spat->spat_regexp->subbase
X && spat->spat_regexp->subbase != orig) {
X m = s;
X s = orig;
X orig = spat->spat_regexp->subbase;
X s = orig + (m - s);
X strend = s + (strend - m);
X }
X m = spat->spat_regexp->startp[0];
X str_ncat(dstr,s,m-s);
X s = spat->spat_regexp->endp[0];
X if (c) {
X if (clen)
X str_ncat(dstr,c,clen);
X }
X else {
X (void)eval(rspat->spat_repl,G_SCALAR,sp);
X str_scat(dstr,stack->ary_array[sp+1]);
X }
X if (once)
X break;
X } while (regexec(spat->spat_regexp, s, strend, orig, 1, Nullstr,
X safebase));
X str_ncat(dstr,s,strend - s);
X str_replace(str,dstr);
X STABSET(str);
X str_numset(arg->arg_ptr.arg_str, (double)iters);
X stack->ary_array[++sp] = arg->arg_ptr.arg_str;
X return sp;
X }
X str_numset(arg->arg_ptr.arg_str, 0.0);
X stack->ary_array[++sp] = arg->arg_ptr.arg_str;
X return sp;
X
Xnope:
X ++spat->spat_short->str_u.str_useful;
X str_numset(arg->arg_ptr.arg_str, 0.0);
X stack->ary_array[++sp] = arg->arg_ptr.arg_str;
X return sp;
X}
X
Xint
Xdo_trans(str,arg)
XSTR *str;
Xregister ARG *arg;
X{
X register char *tbl;
X register char *s;
X register int matches = 0;
X register int ch;
X register char *send;
X
X tbl = arg[2].arg_ptr.arg_cval;
X s = str_get(str);
X send = s + str->str_cur;
X if (!tbl || !s)
X fatal("panic: do_trans");
X#ifdef DEBUGGING
X if (debug & 8) {
X deb("2.TBL\n");
X }
X#endif
X while (s < send) {
X if (ch = tbl[*s & 0377]) {
X matches++;
X *s = ch;
X }
X s++;
X }
X STABSET(str);
X return matches;
X}
X
Xvoid
Xdo_join(str,arglast)
Xregister STR *str;
Xint *arglast;
X{
X register STR **st = stack->ary_array;
X register int sp = arglast[1];
X register int items = arglast[2] - sp;
X register char *delim = str_get(st[sp]);
X int delimlen = st[sp]->str_cur;
X
X st += ++sp;
X if (items-- > 0)
X str_sset(str,*st++);
X else
X str_set(str,"");
X for (; items > 0; items--,st++) {
X str_ncat(str,delim,delimlen);
X str_scat(str,*st);
X }
X STABSET(str);
X}
X
Xvoid
Xdo_pack(str,arglast)
Xregister STR *str;
Xint *arglast;
X{
X register STR **st = stack->ary_array;
X register int sp = arglast[1];
X register int items;
X register char *pat = str_get(st[sp]);
X register char *patend = pat + st[sp]->str_cur;
X register int len;
X int datumtype;
X STR *fromstr;
X static char *null10 = "\0\0\0\0\0\0\0\0\0\0";
X static char *space10 = " ";
X
X /* These must not be in registers: */
X char achar;
X short ashort;
X int aint;
X long along;
X char *aptr;
X
X items = arglast[2] - sp;
X st += ++sp;
X str_nset(str,"",0);
X while (pat < patend) {
X#define NEXTFROM (items-- > 0 ? *st++ : &str_no)
X datumtype = *pat++;
X if (isdigit(*pat)) {
X len = atoi(pat);
X while (isdigit(*pat))
X pat++;
X }
X else
X len = 1;
X switch(datumtype) {
X default:
X break;
X case 'x':
X while (len >= 10) {
X str_ncat(str,null10,10);
X len -= 10;
X }
X str_ncat(str,null10,len);
X break;
X case 'A':
X case 'a':
X fromstr = NEXTFROM;
X aptr = str_get(fromstr);
X if (fromstr->str_cur > len)
X str_ncat(str,aptr,len);
X else
X str_ncat(str,aptr,fromstr->str_cur);
X len -= fromstr->str_cur;
X if (datumtype == 'A') {
X while (len >= 10) {
X str_ncat(str,space10,10);
X len -= 10;
X }
X str_ncat(str,space10,len);
X }
X else {
X while (len >= 10) {
X str_ncat(str,null10,10);
X len -= 10;
X }
X str_ncat(str,null10,len);
X }
X break;
X case 'C':
X case 'c':
X while (len-- > 0) {
X fromstr = NEXTFROM;
X achar = (char)str_gnum(fromstr);
X str_ncat(str,&achar,sizeof(char));
X }
X break;
X case 'n':
X while (len-- > 0) {
X fromstr = NEXTFROM;
X ashort = (short)str_gnum(fromstr);
X#ifdef HTONS
X ashort = htons(ashort);
X#endif
X str_ncat(str,(char*)&ashort,sizeof(short));
X }
X break;
X case 'S':
X case 's':
X while (len-- > 0) {
X fromstr = NEXTFROM;
X ashort = (short)str_gnum(fromstr);
X str_ncat(str,(char*)&ashort,sizeof(short));
X }
X break;
X case 'I':
X case 'i':
X while (len-- > 0) {
X fromstr = NEXTFROM;
X aint = (int)str_gnum(fromstr);
X str_ncat(str,(char*)&aint,sizeof(int));
X }
X break;
X case 'N':
X while (len-- > 0) {
X fromstr = NEXTFROM;
X along = (long)str_gnum(fromstr);
X#ifdef HTONL
X along = htonl(along);
X#endif
X str_ncat(str,(char*)&along,sizeof(long));
X }
X break;
X case 'L':
X case 'l':
X while (len-- > 0) {
X fromstr = NEXTFROM;
X along = (long)str_gnum(fromstr);
X str_ncat(str,(char*)&along,sizeof(long));
X }
X break;
X case 'p':
X while (len-- > 0) {
X fromstr = NEXTFROM;
X aptr = str_get(fromstr);
X str_ncat(str,(char*)&aptr,sizeof(char*));
X }
X break;
X }
X }
X STABSET(str);
X}
X#undef NEXTFROM
X
Xvoid
Xdo_sprintf(str,len,sarg)
Xregister STR *str;
Xregister int len;
Xregister STR **sarg;
X{
X register char *s;
X register char *t;
X bool dolong;
X char ch;
X static STR *sargnull = &str_no;
X register char *send;
X
X str_set(str,"");
X len--; /* don't count pattern string */
X s = str_get(*sarg);
X send = s + (*sarg)->str_cur;
X sarg++;
X for ( ; s < send; len--) {
X if (len <= 0 || !*sarg) {
X sarg = &sargnull;
X len = 0;
X }
X dolong = FALSE;
X for (t = s; t < send && *t != '%'; t++) ;
X if (t >= send)
X break; /* not enough % patterns, oh well */
X for (t++; *sarg && t < send && t != s; t++) {
X switch (*t) {
X default:
X ch = *(++t);
X *t = '\0';
X (void)sprintf(buf,s);
X s = t;
X *(t--) = ch;
X len++;
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 case '.': case '#': case '-': case '+':
X break;
X case 'l':
X dolong = TRUE;
X break;
X case 'D': case 'X': case 'O':
X dolong = TRUE;
X /* FALL THROUGH */
X case 'c':
X *buf = (int)str_gnum(*(sarg++));
X str_ncat(str,buf,1); /* force even if null */
X *buf = '\0';
X s = t+1;
X break;
X case 'd': case 'x': case 'o': case 'u':
X ch = *(++t);
X *t = '\0';
X if (dolong)
X (void)sprintf(buf,s,(long)str_gnum(*(sarg++)));
X else
X (void)sprintf(buf,s,(int)str_gnum(*(sarg++)));
X s = t;
X *(t--) = ch;
X break;
X case 'E': case 'e': case 'f': case 'G': case 'g':
X ch = *(++t);
X *t = '\0';
X (void)sprintf(buf,s,str_gnum(*(sarg++)));
X s = t;
X *(t--) = ch;
X break;
X case 's':
X ch = *(++t);
X *t = '\0';
X if (strEQ(t-2,"%s")) { /* some printfs fail on >128 chars */
X *buf = '\0';
X str_ncat(str,s,t - s - 2);
X str_scat(str,*(sarg++)); /* so handle simple case */
X }
X else
X (void)sprintf(buf,s,str_get(*(sarg++)));
X s = t;
X *(t--) = ch;
X break;
X }
X }
X if (s < t && t >= send) {
X str_cat(str,s);
X s = t;
X break;
X }
X str_cat(str,buf);
X }
X if (*s) {
X (void)sprintf(buf,s,0,0,0,0);
X str_cat(str,buf);
X }
X STABSET(str);
X}
X
XSTR *
Xdo_push(ary,arglast)
Xregister ARRAY *ary;
Xint *arglast;
X{
X register STR **st = stack->ary_array;
X register int sp = arglast[1];
X register int items = arglast[2] - sp;
X register STR *str = &str_undef;
X
X for (st += ++sp; items > 0; items--,st++) {
X str = str_new(0);
X if (*st)
X str_sset(str,*st);
X (void)apush(ary,str);
X }
X return str;
X}
X
Xint
Xdo_unshift(ary,arglast)
Xregister ARRAY *ary;
Xint *arglast;
X{
X register STR **st = stack->ary_array;
X register int sp = arglast[1];
X register int items = arglast[2] - sp;
X register STR *str;
X register int i;
X
X aunshift(ary,items);
X i = 0;
X for (st += ++sp; i < items; i++,st++) {
X str = str_new(0);
X str_sset(str,*st);
X (void)astore(ary,i,str);
X }
X}
X
Xint
Xdo_subr(arg,gimme,arglast)
Xregister ARG *arg;
Xint gimme;
Xint *arglast;
X{
X register STR **st = stack->ary_array;
X register int sp = arglast[1];
X register int items = arglast[2] - sp;
X register SUBR *sub;
X ARRAY *savearray;
X STAB *stab;
X char *oldfile = filename;
X int oldsave = savestack->ary_fill;
X int oldtmps_base = tmps_base;
X
X if ((arg[1].arg_type & A_MASK) == A_WORD)
X stab = arg[1].arg_ptr.arg_stab;
X else {
X STR *tmpstr = stab_val(arg[1].arg_ptr.arg_stab);
X
X if (tmpstr)
X stab = stabent(str_get(tmpstr),TRUE);
X else
X stab = Nullstab;
X }
X if (!stab) {
X if (dowarn)
X warn("Undefined subroutine called");
X goto retundef;
X }
X sub = stab_sub(stab);
X if (!sub) {
X if (dowarn)
X warn("Undefined subroutine \"%s\" called", stab_name(stab));
X goto retundef;
X }
X if ((arg[2].arg_type & A_MASK) != A_NULL) {
X savearray = stab_xarray(defstab);
X stab_xarray(defstab) = afake(defstab, items, &st[sp+1]);
X }
X savelong(&sub->depth);
X sub->depth++;
X if (sub->depth >= 2) { /* save temporaries on recursion? */
X if (sub->depth == 100 && dowarn)
X warn("Deep recursion on subroutine \"%s\"",stab_name(stab));
X savelist(sub->tosave->ary_array,sub->tosave->ary_fill);
X }
X filename = sub->filename;
X tmps_base = tmps_max;
X sp = cmd_exec(sub->cmd,gimme,--sp); /* so do it already */
X st = stack->ary_array;
X
X if ((arg[2].arg_type & A_MASK) != A_NULL) {
X Safefree(stab_xarray(defstab)); /* put back old $_[] */
X stab_xarray(defstab) = savearray;
X }
X filename = oldfile;
X tmps_base = oldtmps_base;
X if (savestack->ary_fill > oldsave) {
X for (items = arglast[0] + 1; items <= sp; items++)
X st[items] = str_static(st[items]);
X /* in case restore wipes old str */
X restorelist(oldsave);
X }
X return sp;
X
Xretundef:
X st[sp] = &str_undef;
X return sp;
X}
X
Xint
Xdo_dbsubr(arg,gimme,arglast)
Xregister ARG *arg;
Xint gimme;
Xint *arglast;
X{
X register STR **st = stack->ary_array;
X register int sp = arglast[1];
X register int items = arglast[2] - sp;
X register SUBR *sub;
X ARRAY *savearray;
X STR *str;
X STAB *stab;
X char *oldfile = filename;
X int oldsave = savestack->ary_fill;
X int oldtmps_base = tmps_base;
X
X if ((arg[1].arg_type & A_MASK) == A_WORD)
X stab = arg[1].arg_ptr.arg_stab;
X else {
X STR *tmpstr = stab_val(arg[1].arg_ptr.arg_stab);
X
X if (tmpstr)
X stab = stabent(str_get(tmpstr),TRUE);
X else
X stab = Nullstab;
X }
X if (!stab) {
X if (dowarn)
X warn("Undefined subroutine called");
X goto retundef;
X }
X sub = stab_sub(stab);
X if (!sub) {
X if (dowarn)
X warn("Undefined subroutine \"%s\" called", stab_name(stab));
X goto retundef;
X }
X/* begin differences */
X str = stab_val(DBsub);
X saveitem(str);
X str_set(str,stab_name(stab));
X sub = stab_sub(DBsub);
X if (!sub)
X fatal("No DBsub routine");
X/* end differences */
X if ((arg[2].arg_type & A_MASK) != A_NULL) {
X savearray = stab_xarray(defstab);
X stab_xarray(defstab) = afake(defstab, items, &st[sp+1]);
X }
X savelong(&sub->depth);
X sub->depth++;
X if (sub->depth >= 2) { /* save temporaries on recursion? */
X if (sub->depth == 100 && dowarn)
X warn("Deep recursion on subroutine \"%s\"",stab_name(stab));
X savelist(sub->tosave->ary_array,sub->tosave->ary_fill);
X }
X filename = sub->filename;
X tmps_base = tmps_max;
X sp = cmd_exec(sub->cmd,gimme, --sp); /* so do it already */
X st = stack->ary_array;
X
X if ((arg[2].arg_type & A_MASK) != A_NULL) {
X Safefree(stab_xarray(defstab)); /* put back old $_[] */
X stab_xarray(defstab) = savearray;
X }
X filename = oldfile;
X tmps_base = oldtmps_base;
X if (savestack->ary_fill > oldsave) {
X for (items = arglast[0] + 1; items <= sp; items++)
X st[items] = str_static(st[items]);
X /* in case restore wipes old str */
X restorelist(oldsave);
X }
X return sp;
X
Xretundef:
X st[sp] = &str_undef;
X return sp;
X}
X
Xint
Xdo_assign(arg,gimme,arglast)
Xregister ARG *arg;
Xint gimme;
Xint *arglast;
X{
X
X register STR **st = stack->ary_array;
X STR **firstrelem = st + arglast[1] + 1;
X STR **firstlelem = st + arglast[0] + 1;
X STR **lastrelem = st + arglast[2];
X STR **lastlelem = st + arglast[1];
X register STR **relem;
X register STR **lelem;
X
X register STR *str;
X register ARRAY *ary;
X register int makelocal;
X HASH *hash;
X int i;
X
X makelocal = (arg->arg_flags & AF_LOCAL);
X
X /* If there's a common identifier on both sides we have to take
X * special care that assigning the identifier on the left doesn't
X * clobber a value on the right that's used later in the list.
X */
X if (arg->arg_flags & AF_COMMON) {
X for (relem = firstrelem; relem <= lastrelem; relem++) {
X if (str = *relem)
X *relem = str_static(str);
X }
X }
X relem = firstrelem;
X lelem = firstlelem;
X while (lelem <= lastlelem) {
X str = *lelem++;
X if (str->str_state >= SS_HASH) {
X if (str->str_state == SS_ARY) {
X if (makelocal)
X ary = saveary(str->str_u.str_stab);
X else {
X ary = stab_array(str->str_u.str_stab);
X ary->ary_fill = -1;
X }
X i = 0;
X while (relem <= lastrelem) { /* gobble up all the rest */
X str = str_new(0);
X if (*relem)
X str_sset(str,*(relem++));
X else
X relem++;
X (void)astore(ary,i++,str);
X }
X }
X else if (str->str_state == SS_HASH) {
X char *tmps;
X STR *tmpstr;
X
X if (makelocal)
X hash = savehash(str->str_u.str_stab);
X else {
X hash = stab_hash(str->str_u.str_stab);
X hclear(hash);
X }
X while (relem < lastrelem) { /* gobble up all the rest */
X if (*relem)
X str = *(relem++);
X else
X str = &str_no, relem++;
X tmps = str_get(str);
X tmpstr = str_new(0);
X if (*relem)
X str_sset(tmpstr,*(relem++)); /* value */
X else
X relem++;
X (void)hstore(hash,tmps,str->str_cur,tmpstr,0);
X }
X }
X else
X fatal("panic: do_assign");
X }
X else {
X if (makelocal)
X saveitem(str);
X if (relem <= lastrelem)
X str_sset(str, *(relem++));
X else
X str_nset(str, "", 0);
X STABSET(str);
X }
X }
X if (gimme == G_ARRAY) {
X return arglast[1];
X }
X else {
X str_numset(arg->arg_ptr.arg_str,(double)(arglast[2] - arglast[1]));
X st[arglast[0]+1] = arg->arg_ptr.arg_str;
X return arglast[0] + 1;
X }
X}
X
Xint
Xdo_study(str,arg,gimme,arglast)
XSTR *str;
XARG *arg;
Xint gimme;
Xint *arglast;
X{
X register unsigned char *s;
X register int pos = str->str_cur;
X register int ch;
X register int *sfirst;
X register int *snext;
X static int maxscream = -1;
X static STR *lastscream = Nullstr;
X int retval;
X int retarg = arglast[0] + 1;
X
X#ifndef lint
X s = (unsigned char*)(str_get(str));
X#else
X s = Null(unsigned char*);
X#endif
X if (lastscream)
X lastscream->str_pok &= ~SP_STUDIED;
X lastscream = str;
X if (pos <= 0) {
X retval = 0;
X goto ret;
X }
X if (pos > maxscream) {
X if (maxscream < 0) {
X maxscream = pos + 80;
X New(301,screamfirst, 256, int);
X New(302,screamnext, maxscream, int);
X }
X else {
X maxscream = pos + pos / 4;
X Renew(screamnext, maxscream, int);
X }
X }
X
X sfirst = screamfirst;
X snext = screamnext;
X
X if (!sfirst || !snext)
X fatal("do_study: out of memory");
X
X for (ch = 256; ch; --ch)
X *sfirst++ = -1;
X sfirst -= 256;
X
X while (--pos >= 0) {
X ch = s[pos];
X if (sfirst[ch] >= 0)
X snext[pos] = sfirst[ch] - pos;
X else
X snext[pos] = -pos;
X sfirst[ch] = pos;
X
X /* If there were any case insensitive searches, we must assume they
X * all are. This speeds up insensitive searches much more than
X * it slows down sensitive ones.
X */
X if (sawi)
X sfirst[fold[ch]] = pos;
X }
X
X str->str_pok |= SP_STUDIED;
X retval = 1;
X ret:
X str_numset(arg->arg_ptr.arg_str,(double)retval);
X stack->ary_array[retarg] = arg->arg_ptr.arg_str;
X return retarg;
X}
X
Xint
Xdo_defined(str,arg,gimme,arglast)
XSTR *str;
Xregister ARG *arg;
Xint gimme;
Xint *arglast;
X{
X register int type;
X register int retarg = arglast[0] + 1;
X int retval;
X
X if ((arg[1].arg_type & A_MASK) != A_LEXPR)
X fatal("Illegal argument to defined()");
X arg = arg[1].arg_ptr.arg_arg;
X type = arg->arg_type;
X
X if (type == O_ARRAY || type == O_LARRAY)
X retval = stab_xarray(arg[1].arg_ptr.arg_stab) != 0;
X else if (type == O_HASH || type == O_LHASH)
X retval = stab_xhash(arg[1].arg_ptr.arg_stab) != 0;
X else if (type == O_SUBR || type == O_DBSUBR)
X retval = stab_sub(arg[1].arg_ptr.arg_stab) != 0;
X else if (type == O_ASLICE || type == O_LASLICE)
X retval = stab_xarray(arg[1].arg_ptr.arg_stab) != 0;
X else if (type == O_HSLICE || type == O_LHSLICE)
X retval = stab_xhash(arg[1].arg_ptr.arg_stab) != 0;
X else
X retval = FALSE;
X str_numset(str,(double)retval);
X stack->ary_array[retarg] = str;
X return retarg;
X}
X
Xint
Xdo_undef(str,arg,gimme,arglast)
XSTR *str;
Xregister ARG *arg;
Xint gimme;
Xint *arglast;
X{
X register int type;
X register STAB *stab;
X int retarg = arglast[0] + 1;
X
X if ((arg[1].arg_type & A_MASK) != A_LEXPR)
X fatal("Illegal argument to undef()");
X arg = arg[1].arg_ptr.arg_arg;
X type = arg->arg_type;
X
X if (type == O_ARRAY || type == O_LARRAY) {
X stab = arg[1].arg_ptr.arg_stab;
X afree(stab_xarray(stab));
X stab_xarray(stab) = Null(ARRAY*);
X }
X else if (type == O_HASH || type == O_LHASH) {
X stab = arg[1].arg_ptr.arg_stab;
X (void)hfree(stab_xhash(stab));
X stab_xhash(stab) = Null(HASH*);
X }
X else if (type == O_SUBR || type == O_DBSUBR) {
X stab = arg[1].arg_ptr.arg_stab;
X cmd_free(stab_sub(stab)->cmd);
X afree(stab_sub(stab)->tosave);
X Safefree(stab_sub(stab));
X stab_sub(stab) = Null(SUBR*);
X }
X else
X fatal("Can't undefine that kind of object");
X str_numset(str,0.0);
X stack->ary_array[retarg] = str;
X return retarg;
X}
X
Xint
Xdo_vec(lvalue,astr,arglast)
Xint lvalue;
XSTR *astr;
Xint *arglast;
X{
X STR **st = stack->ary_array;
X int sp = arglast[0];
X register STR *str = st[++sp];
X register int offset = (int)str_gnum(st[++sp]);
X register int size = (int)str_gnum(st[++sp]);
X unsigned char *s = (unsigned char*)str_get(str);
X unsigned long retnum;
X int len;
X
X sp = arglast[1];
X offset *= size; /* turn into bit offset */
X len = (offset + size + 7) / 8;
X if (offset < 0 || size < 1)
X retnum = 0;
X else if (!lvalue && len > str->str_cur)
X retnum = 0;
X else {
X if (len > str->str_cur) {
X STR_GROW(str,len);
X (void)bzero(str->str_ptr + str->str_cur, len - str->str_cur);
X str->str_cur = len;
X }
X s = (unsigned char*)str_get(str);
X if (size < 8)
X retnum = (s[offset >> 3] >> (offset & 7)) & ((1 << size) - 1);
X else {
X offset >>= 3;
X if (size == 8)
X retnum = s[offset];
X else if (size == 16)
X retnum = (s[offset] << 8) + s[offset+1];
X else if (size == 32)
X retnum = (s[offset] << 24) + (s[offset + 1] << 16) +
X (s[offset + 2] << 8) + s[offset+3];
X }
X
X if (lvalue) { /* it's an lvalue! */
X struct lstring *lstr = (struct lstring*)astr;
X
X astr->str_magic = str;
X st[sp]->str_rare = 'v';
X lstr->lstr_offset = offset;
X lstr->lstr_len = size;
X }
X }
X
X str_numset(astr,(double)retnum);
X st[sp] = astr;
X return sp;
X}
X
Xvoid
Xdo_vecset(mstr,str)
XSTR *mstr;
XSTR *str;
X{
X struct lstring *lstr = (struct lstring*)str;
X register int offset;
X register int size;
X register unsigned char *s = (unsigned char*)mstr->str_ptr;
X register unsigned long lval = (unsigned long)str_gnum(str);
X int mask;
X
X mstr->str_rare = 0;
X str->str_magic = Nullstr;
X offset = lstr->lstr_offset;
X size = lstr->lstr_len;
X if (size < 8) {
X mask = (1 << size) - 1;
X size = offset & 7;
X lval &= mask;
X offset >>= 3;
X s[offset] &= mask << size;
X s[offset] |= lval << size;
X }
X else {
X if (size == 8)
X s[offset] = lval & 255;
X else if (size == 16) {
X s[offset] = (lval >> 8) & 255;
X s[offset+1] = lval & 255;
X }
X else if (size == 32) {
X s[offset] = (lval >> 24) & 255;
X s[offset+1] = (lval >> 16) & 255;
X s[offset+2] = (lval >> 8) & 255;
X s[offset+3] = lval & 255;
X }
X }
X}
X
Xdo_chop(astr,str)
Xregister STR *astr;
Xregister STR *str;
X{
X register char *tmps;
X register int i;
X ARRAY *ary;
X HASH *hash;
X HENT *entry;
X
X if (!str)
X return;
X if (str->str_state == SS_ARY) {
X ary = stab_array(str->str_u.str_stab);
X for (i = 0; i <= ary->ary_fill; i++)
X do_chop(astr,ary->ary_array[i]);
X return;
X }
X if (str->str_state == SS_HASH) {
X hash = stab_hash(str->str_u.str_stab);
X (void)hiterinit(hash);
X while (entry = hiternext(hash))
X do_chop(astr,hiterval(hash,entry));
X return;
X }
X tmps = str_get(str);
X if (!tmps)
X return;
X tmps += str->str_cur - (str->str_cur != 0);
X str_nset(astr,tmps,1); /* remember last char */
X *tmps = '\0'; /* wipe it out */
X str->str_cur = tmps - str->str_ptr;
X str->str_nok = 0;
X}
X
Xdo_vop(optype,str,left,right)
XSTR *str;
XSTR *left;
XSTR *right;
X{
X register char *s = str_get(str);
X register char *l = str_get(left);
X register char *r = str_get(right);
X register int len;
X
X len = left->str_cur;
X if (len > right->str_cur)
X len = right->str_cur;
X if (str->str_cur > len)
X str->str_cur = len;
X else if (str->str_cur < len) {
X STR_GROW(str,len);
X (void)bzero(str->str_ptr + str->str_cur, len - str->str_cur);
X str->str_cur = len;
X s = str_get(str);
X }
X switch (optype) {
X case O_BIT_AND:
X while (len--)
X *s++ = *l++ & *r++;
X break;
X case O_XOR:
X while (len--)
X *s++ = *l++ ^ *r++;
X goto mop_up;
X case O_BIT_OR:
X while (len--)
X *s++ = *l++ | *r++;
X mop_up:
X len = str->str_cur;
X if (right->str_cur > len)
X str_ncat(str,right->str_ptr+len,right->str_cur - len);
X else if (left->str_cur > len)
X str_ncat(str,left->str_ptr+len,left->str_cur - len);
X break;
X }
X}
X
!STUFFY!FUNK!
echo Extracting regexec.c
sed >regexec.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/* $Header: regexp.c,v 2.0.1.5 88/09/07 17:02:10 lwall Locked $
X *
X * $Log: regexp.c,v $
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 **** 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 "regcomp.h"
X
X#ifndef STATIC
X#define STATIC static
X#endif
X
X#ifdef DEBUGGING
Xint regnarrate = 0;
X#endif
X
X/*
X * regexec and friends
X */
X
X/*
X * Global work variables for regexec().
X */
Xstatic char *regprecomp;
Xstatic char *reginput; /* String-input pointer. */
Xstatic char *regbol; /* Beginning of input, for ^ check. */
Xstatic char *regeol; /* End of input, for $ check. */
Xstatic char **regstartp; /* Pointer to startp array. */
Xstatic char **regendp; /* Ditto for endp. */
Xstatic char *reglastparen; /* Similarly for lastparen. */
Xstatic char *regtill;
X
Xstatic char *regmystartp[10]; /* For remembering backreferences. */
Xstatic char *regmyendp[10];
X
X/*
X * Forwards.
X */
XSTATIC int regtry();
XSTATIC int regmatch();
XSTATIC int regrepeat();
X
Xextern int multiline;
X
X/*
X - regexec - match a regexp against a string
X */
Xint
Xregexec(prog, stringarg, strend, strbeg, minend, screamer, safebase)
Xregister regexp *prog;
Xchar *stringarg;
Xregister char *strend; /* pointer to null at end of string */
Xchar *strbeg; /* real beginning of string */
Xint minend; /* end of match must be at least minend after stringarg */
XSTR *screamer;
Xint safebase; /* no need to remember string in subbase */
X{
X register char *s;
X extern char *index();
X register int i;
X register char *c;
X register char *string = stringarg;
X register int tmp;
X int minlen = 0; /* must match at least this many chars */
X int dontbother = 0; /* how many characters not to try at end */
X int beginning = (string == strbeg); /* is ^ valid at stringarg? */
X
X /* Be paranoid... */
X if (prog == NULL || string == NULL) {
X fatal("NULL regexp parameter");
X return(0);
X }
X
X regprecomp = prog->precomp;
X /* Check validity of program. */
X if (UCHARAT(prog->program) != MAGIC) {
X FAIL("corrupted regexp program");
X }
X
X if (prog->do_folding) {
X safebase = FALSE;
X i = strend - string;
X New(1101,c,i+1,char);
X (void)bcopy(string, c, i+1);
X string = c;
X strend = string + i;
X for (s = string; s < strend; s++)
X if (isupper(*s))
X *s = tolower(*s);
X }
X
X /* If there is a "must appear" string, look for it. */
X s = string;
X if (prog->regmust != Nullstr) {
X if (beginning && screamer) {
X if (screamfirst[prog->regmust->str_rare] >= 0)
X s = screaminstr(screamer,prog->regmust);
X else
X s = Nullch;
X }
X#ifndef lint
X else
X s = fbminstr((unsigned char*)s, (unsigned char*)strend,
X prog->regmust);
X#endif
X if (!s) {
X ++prog->regmust->str_u.str_useful; /* hooray */
X goto phooey; /* not present */
X }
X else if (prog->regback >= 0) {
X s -= prog->regback;
X if (s < string)
X s = string;
X minlen = prog->regback + prog->regmust->str_cur;
X }
X else if (--prog->regmust->str_u.str_useful < 0) { /* boo */
X str_free(prog->regmust);
X prog->regmust = Nullstr; /* disable regmust */
X s = string;
X }
X else {
X s = string;
X minlen = prog->regmust->str_cur;
X }
X }
X
X /* Mark beginning of line for ^ . */
X if (beginning)
X regbol = string;
X else
X regbol = NULL;
X
X /* Mark end of line for $ (and such) */
X regeol = strend;
X
X /* see how far we have to get to not match where we matched before */
X regtill = string+minend;
X
X /* Simplest case: anchored match need be tried only once. */
X /* [unless multiline is set] */
X if (prog->reganch) {
X if (regtry(prog, string))
X goto got_it;
X else if (multiline) {
X if (minlen)
X dontbother = minlen - 1;
X strend -= dontbother;
X /* for multiline we only have to try after newlines */
X if (s > string)
X s--;
X for (; s < strend; s++) {
X if (*s == '\n') {
X if (++s < strend && regtry(prog, s))
X goto got_it;
X }
X }
X }
X goto phooey;
X }
X
X /* Messy cases: unanchored match. */
X if (prog->regstart) {
X /* We know what string it must start with. */
X if (prog->regstart->str_pok == 3) {
X#ifndef lint
X while ((s = fbminstr((unsigned char*)s,
X (unsigned char*)strend, prog->regstart)) != NULL)
X#else
X while (s = Nullch)
X#endif
X {
X if (regtry(prog, s))
X goto got_it;
X s++;
X }
X }
X else {
X c = prog->regstart->str_ptr;
X while ((s = ninstr(s, strend,
X c, c + prog->regstart->str_cur )) != NULL) {
X if (regtry(prog, s))
X goto got_it;
X s++;
X }
X }
X goto phooey;
X }
X if (c = prog->regstclass) {
X if (minlen)
X dontbother = minlen - 1;
X strend -= dontbother; /* don't bother with what can't match */
X /* We know what class it must start with. */
X switch (OP(c)) {
X case ANYOF: case ANYBUT:
X c = OPERAND(c);
X while (s < strend) {
X i = *s;
X if (!(c[i >> 3] & (1 << (i&7))))
X if (regtry(prog, s))
X goto got_it;
X s++;
X }
X break;
X case BOUND:
X if (minlen)
X dontbother++,strend--;
X if (s != string) {
X i = s[-1];
X tmp = (isalpha(i) || isdigit(i) || i == '_');
X }
X else
X tmp = 0; /* assume not alphanumeric */
X while (s < strend) {
X i = *s;
X if (tmp != (isalpha(i) || isdigit(i) || i == '_')) {
X tmp = !tmp;
X if (regtry(prog, s))
X goto got_it;
X }
X s++;
X }
X if (tmp && regtry(prog,s))
X goto got_it;
X break;
X case NBOUND:
X if (minlen)
X dontbother++,strend--;
X if (s != string) {
X i = s[-1];
X tmp = (isalpha(i) || isdigit(i) || i == '_');
X }
X else
X tmp = 0; /* assume not alphanumeric */
X while (s < strend) {
X i = *s;
X if (tmp != (isalpha(i) || isdigit(i) || i == '_'))
X tmp = !tmp;
X else if (regtry(prog, s))
X goto got_it;
X s++;
X }
X if (!tmp && regtry(prog,s))
X goto got_it;
X break;
X case ALNUM:
X while (s < strend) {
X i = *s;
X if (isalpha(i) || isdigit(i) || i == '_')
X if (regtry(prog, s))
X goto got_it;
X s++;
X }
X break;
X case NALNUM:
X while (s < strend) {
X i = *s;
X if (!isalpha(i) && !isdigit(i) && i != '_')
X if (regtry(prog, s))
X goto got_it;
X s++;
X }
X break;
X case SPACE:
X while (s < strend) {
X if (isspace(*s))
X if (regtry(prog, s))
X goto got_it;
X s++;
X }
X break;
X case NSPACE:
X while (s < strend) {
X if (!isspace(*s))
X if (regtry(prog, s))
X goto got_it;
X s++;
X }
X break;
X case DIGIT:
X while (s < strend) {
X if (isdigit(*s))
X if (regtry(prog, s))
X goto got_it;
X s++;
X }
X break;
X case NDIGIT:
X while (s < strend) {
X if (!isdigit(*s))
X if (regtry(prog, s))
X goto got_it;
X s++;
X }
X break;
X }
X }
X else {
X dontbother = minend;
X strend -= dontbother;
X /* We don't know much -- general case. */
X do {
X if (regtry(prog, s))
X goto got_it;
X } while (s++ < strend);
X }
X
X /* Failure. */
X goto phooey;
X
X got_it:
X if ((!safebase && (prog->nparens || sawampersand)) || prog->do_folding){
X strend += dontbother; /* uncheat */
X if (safebase) /* no need for $digit later */
X s = strbeg;
X else if (strbeg != prog->subbase) {
X i = strend - string + (stringarg - strbeg);
X s = nsavestr(strbeg,i); /* so $digit will work later */
X if (prog->subbase)
X Safefree(prog->subbase);
X prog->subbase = s;
X }
X else
X s = prog->subbase;
X s += (stringarg - strbeg);
X for (i = 0; i <= prog->nparens; i++) {
X if (prog->endp[i]) {
X prog->startp[i] = s + (prog->startp[i] - string);
X prog->endp[i] = s + (prog->endp[i] - string);
X }
X }
X if (prog->do_folding)
X Safefree(string);
X }
X return(1);
X
X phooey:
X if (prog->do_folding)
X Safefree(string);
X return(0);
X}
X
X/*
X - regtry - try match at specific point
X */
Xstatic int /* 0 failure, 1 success */
Xregtry(prog, string)
Xregexp *prog;
Xchar *string;
X{
X register int i;
X register char **sp;
X register char **ep;
X
X reginput = string;
X regstartp = prog->startp;
X regendp = prog->endp;
X reglastparen = &prog->lastparen;
X prog->lastparen = 0;
X
X sp = prog->startp;
X ep = prog->endp;
X if (prog->nparens) {
X for (i = NSUBEXP; i > 0; i--) {
X *sp++ = NULL;
X *ep++ = NULL;
X }
X }
X if (regmatch(prog->program + 1) && reginput >= regtill) {
X prog->startp[0] = string;
X prog->endp[0] = reginput;
X return(1);
X } else
X return(0);
X}
X
X/*
X - regmatch - main matching routine
X *
X * Conceptually the strategy is simple: check to see whether the current
X * node matches, call self recursively to see whether the rest matches,
X * and then act accordingly. In practice we make some effort to avoid
X * recursion, in particular by going through "ordinary" nodes (that don't
X * need to know whether the rest of the match failed) by a loop instead of
X * by recursion.
X */
X/* [lwall] I've hoisted the register declarations to the outer block in order to
X * maybe save a little bit of pushing and popping on the stack. It also takes
X * advantage of machines that use a register save mask on subroutine entry.
X */
Xstatic int /* 0 failure, 1 success */
Xregmatch(prog)
Xchar *prog;
X{
X register char *scan; /* Current node. */
X char *next; /* Next node. */
X extern char *index();
X register int nextchar;
X register int n; /* no or next */
X register int ln; /* len or last */
X register char *s; /* operand or save */
X register char *locinput = reginput;
X
X nextchar = *locinput;
X scan = prog;
X#ifdef DEBUGGING
X if (scan != NULL && regnarrate)
X fprintf(stderr, "%s(\n", regprop(scan));
X#endif
X while (scan != NULL) {
X#ifdef DEBUGGING
X if (regnarrate)
X fprintf(stderr, "%s...\n", regprop(scan));
X#endif
X
X#ifdef REGALIGN
X next = scan + NEXT(scan);
X if (next == scan)
X next = NULL;
X#else
X next = regnext(scan);
X#endif
X
X switch (OP(scan)) {
X case BOL:
X if (locinput == regbol ||
X ((nextchar || locinput < regeol) &&
X locinput[-1] == '\n') )
X {
X regtill--;
X break;
X }
X return(0);
X case EOL:
X if ((nextchar || locinput < regeol) && nextchar != '\n')
X return(0);
X regtill--;
X break;
X case ANY:
X if ((nextchar == '\0' && locinput >= regeol) ||
X nextchar == '\n')
X return(0);
X nextchar = *++locinput;
X break;
X case EXACTLY:
X s = OPERAND(scan);
X ln = *s++;
X /* Inline the first character, for speed. */
X if (*s != nextchar)
X return(0);
X if (locinput + ln > regeol)
X return 0;
X if (ln > 1 && bcmp(s, locinput, ln) != 0)
X return(0);
X locinput += ln;
X nextchar = *locinput;
X break;
X case ANYOF:
X case ANYBUT:
X s = OPERAND(scan);
X if (nextchar < 0)
X nextchar = UCHARAT(locinput);
X if (s[nextchar >> 3] & (1 << (nextchar&7)))
X return(0);
X nextchar = *++locinput;
X if (!nextchar && locinput > regeol)
X return 0;
X break;
X case ALNUM:
X if (!nextchar)
X return(0);
X if (!isalpha(nextchar) && !isdigit(nextchar) &&
X nextchar != '_')
X return(0);
X nextchar = *++locinput;
X break;
X case NALNUM:
X if (!nextchar && locinput >= regeol)
X return(0);
X if (isalpha(nextchar) || isdigit(nextchar) ||
X nextchar == '_')
X return(0);
X nextchar = *++locinput;
X break;
X case NBOUND:
X case BOUND:
X if (locinput == regbol) /* was last char in word? */
X ln = 0;
X else
X ln = (isalpha(locinput[-1]) ||
X isdigit(locinput[-1]) ||
X locinput[-1] == '_' );
X n = (isalpha(nextchar) || isdigit(nextchar) ||
X nextchar == '_' ); /* is next char in word? */
X if ((ln == n) == (OP(scan) == BOUND))
X return(0);
X break;
X case SPACE:
X if (!nextchar && locinput >= regeol)
X return(0);
X if (!isspace(nextchar))
X return(0);
X nextchar = *++locinput;
X break;
X case NSPACE:
X if (!nextchar)
X return(0);
X if (isspace(nextchar))
X return(0);
X nextchar = *++locinput;
X break;
X case DIGIT:
X if (!isdigit(nextchar))
X return(0);
X nextchar = *++locinput;
X break;
X case NDIGIT:
X if (!nextchar && locinput >= regeol)
X return(0);
X if (isdigit(nextchar))
X return(0);
X nextchar = *++locinput;
X break;
X case REF:
X case REF+1:
X case REF+2:
X case REF+3:
X case REF+4:
X case REF+5:
X case REF+6:
X case REF+7:
X case REF+8:
X case REF+9:
X n = OP(scan) - REF;
X s = regmystartp[n];
X if (!s)
X return(0);
X if (!regmyendp[n])
X return(0);
X if (s == regmyendp[n])
X break;
X /* Inline the first character, for speed. */
X if (*s != nextchar)
X return(0);
X ln = regmyendp[n] - s;
X if (locinput + ln > regeol)
X return 0;
X if (ln > 1 && bcmp(s, locinput, ln) != 0)
X return(0);
X locinput += ln;
X nextchar = *locinput;
X break;
X
X case NOTHING:
X break;
X case BACK:
X break;
X case OPEN+1:
X case OPEN+2:
X case OPEN+3:
X case OPEN+4:
X case OPEN+5:
X case OPEN+6:
X case OPEN+7:
X case OPEN+8:
X case OPEN+9:
X n = OP(scan) - OPEN;
X reginput = locinput;
X
X regmystartp[n] = locinput; /* for REF */
X if (regmatch(next)) {
X /*
X * Don't set startp if some later
X * invocation of the same parentheses
X * already has.
X */
X if (regstartp[n] == NULL)
X regstartp[n] = locinput;
X return(1);
X } else
X return(0);
X /* NOTREACHED */
X case CLOSE+1:
X case CLOSE+2:
X case CLOSE+3:
X case CLOSE+4:
X case CLOSE+5:
X case CLOSE+6:
X case CLOSE+7:
X case CLOSE+8:
X case CLOSE+9: {
X n = OP(scan) - CLOSE;
X reginput = locinput;
X
X regmyendp[n] = locinput; /* for REF */
X if (regmatch(next)) {
X /*
X * Don't set endp if some later
X * invocation of the same parentheses
X * already has.
X */
X if (regendp[n] == NULL) {
X regendp[n] = locinput;
X if (n > *reglastparen)
X *reglastparen = n;
X }
X return(1);
X } else
X return(0);
X }
X /*NOTREACHED*/
X case BRANCH: {
X if (OP(next) != BRANCH) /* No choice. */
X next = NEXTOPER(scan); /* Avoid recursion. */
X else {
X do {
X reginput = locinput;
X if (regmatch(NEXTOPER(scan)))
X return(1);
X#ifdef REGALIGN
X if (n = NEXT(scan))
X scan += n;
X else
X scan = NULL;
X#else
X scan = regnext(scan);
X#endif
X } while (scan != NULL && OP(scan) == BRANCH);
X return(0);
X /* NOTREACHED */
X }
X }
X break;
X case STAR:
X case PLUS:
X /*
X * Lookahead to avoid useless match attempts
X * when we know what character comes next.
X */
X if (OP(next) == EXACTLY)
X nextchar = *(OPERAND(next)+1);
X else
X nextchar = -1000;
X ln = (OP(scan) == STAR) ? 0 : 1;
X reginput = locinput;
X n = regrepeat(NEXTOPER(scan));
X while (n >= ln) {
X /* If it could work, try it. */
X if (nextchar == -1000 || *reginput == nextchar)
X if (regmatch(next))
X return(1);
X /* Couldn't or didn't -- back up. */
X n--;
X reginput = locinput + n;
X }
X return(0);
X case END:
X reginput = locinput; /* put where regtry can find it */
X return(1); /* Success! */
X default:
X printf("%x %d\n",scan,scan[1]);
X FAIL("regexp memory corruption");
X }
X
X scan = next;
X }
X
X /*
X * We get here only if there's trouble -- normally "case END" is
X * the terminating point.
X */
X FAIL("corrupted regexp pointers");
X /*NOTREACHED*/
X#ifdef lint
X return 0;
X#endif
X}
X
X/*
X - regrepeat - repeatedly match something simple, report how many
X */
X/*
X * [This routine now assumes that it will only match on things of length 1.
X * That was true before, but now we assume scan - reginput is the count,
X * rather than incrementing count on every character.]
X */
Xstatic int
Xregrepeat(p)
Xchar *p;
X{
X register char *scan;
X register char *opnd;
X register int c;
X register char *loceol = regeol;
X
X scan = reginput;
X opnd = OPERAND(p);
X switch (OP(p)) {
X case ANY:
X while (scan < loceol && *scan != '\n')
X scan++;
X break;
X case EXACTLY: /* length of string is 1 */
X opnd++;
X while (scan < loceol && *opnd == *scan)
X scan++;
X break;
X case ANYOF:
X case ANYBUT:
X c = UCHARAT(scan);
X while (scan < loceol && !(opnd[c >> 3] & (1 << (c & 7)))) {
X scan++;
X c = UCHARAT(scan);
X }
X break;
X case ALNUM:
X while (isalpha(*scan) || isdigit(*scan) || *scan == '_')
X scan++;
X break;
X case NALNUM:
X while (scan < loceol && (!isalpha(*scan) && !isdigit(*scan) &&
X *scan != '_'))
X scan++;
X break;
X case SPACE:
X while (scan < loceol && isspace(*scan))
X scan++;
X break;
X case NSPACE:
X while (scan < loceol && !isspace(*scan))
X scan++;
X break;
X case DIGIT:
X while (isdigit(*scan))
X scan++;
X break;
X case NDIGIT:
X while (scan < loceol && !isdigit(*scan))
X scan++;
X break;
X default: /* Oh dear. Called inappropriately. */
X FAIL("internal regexp foulup");
X /* NOTREACHED */
X }
X
X c = scan - reginput;
X reginput = scan;
X
X return(c);
X}
X
X/*
X - regnext - dig the "next" pointer out of a node
X *
X * [Note, when REGALIGN is defined there are two places in regmatch()
X * that bypass this code for speed.]
X */
Xchar *
Xregnext(p)
Xregister char *p;
X{
X register int offset;
X
X if (p == ®dummy)
X return(NULL);
X
X offset = NEXT(p);
X if (offset == 0)
X return(NULL);
X
X#ifdef REGALIGN
X return(p+offset);
X#else
X if (OP(p) == BACK)
X return(p-offset);
X else
X return(p+offset);
X#endif
X}
!STUFFY!FUNK!
echo Extracting t/io.tell
sed >t/io.tell <<'!STUFFY!FUNK!' -e 's/X//'
X#!./perl
X
X# $Header: io.tell,v 2.0 88/06/05 00:13:14 root Exp $
X
Xprint "1..13\n";
X
X$TST = 'tst';
X
Xopen($TST, '../Makefile') || (die "Can't open ../Makefile");
X
Xif (eof(tst)) { print "not ok 1\n"; } else { print "ok 1\n"; }
X
X$firstline = <$TST>;
X$secondpos = tell;
X
X$x = 0;
Xwhile (<tst>) {
X if (eof) {$x++;}
X}
Xif ($x == 1) { print "ok 2\n"; } else { print "not ok 2\n"; }
X
X$lastpos = tell;
X
Xunless (eof) { print "not ok 3\n"; } else { print "ok 3\n"; }
X
Xif (seek($TST,0,0)) { print "ok 4\n"; } else { print "not ok 4\n"; }
X
Xif (eof) { print "not ok 5\n"; } else { print "ok 5\n"; }
X
Xif ($firstline eq <tst>) { print "ok 6\n"; } else { print "not ok 6\n"; }
X
Xif ($secondpos == tell) { print "ok 7\n"; } else { print "not ok 7\n"; }
X
Xif (seek(tst,0,1)) { print "ok 8\n"; } else { print "not ok 8\n"; }
X
Xif (eof($TST)) { print "not ok 9\n"; } else { print "ok 9\n"; }
X
Xif ($secondpos == tell) { print "ok 10\n"; } else { print "not ok 10\n"; }
X
Xif (seek(tst,0,2)) { print "ok 11\n"; } else { print "not ok 11\n"; }
X
Xif ($lastpos == tell) { print "ok 12\n"; } else { print "not ok 12\n"; }
X
Xunless (eof) { print "not ok 13\n"; } else { print "ok 13\n"; }
!STUFFY!FUNK!
echo ""
echo "End of kit 11 (of 23)"
cat /dev/null >kit11isdone
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; 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."
chmod 755 Configure
;;
*) echo "You have run$run."
echo "You still need to run$todo."
;;
esac
: Someone might mail this, so...
exit
More information about the Alt.sources
mailing list