perl 3.0 beta kit [16/23]
Larry Wall
lwall at jato.Jpl.Nasa.Gov
Mon Sep 4 05:00:12 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 16 (of 23). If kit 16 is complete, the line"
echo '"'"End of kit 16 (of 23)"'" will echo at the end.'
echo ""
export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
mkdir lib 2>/dev/null
echo Extracting dolist.c
sed >dolist.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
Xint
Xdo_match(str,arg,gimme,arglast)
XSTR *str;
Xregister ARG *arg;
Xint gimme;
Xint *arglast;
X{
X register STR **st = stack->ary_array;
X register SPAT *spat = arg[2].arg_ptr.arg_spat;
X register char *t;
X register int sp = arglast[0] + 1;
X STR *srchstr = st[sp];
X register char *s = str_get(st[sp]);
X char *strend = s + st[sp]->str_cur;
X STR *tmpstr;
X
X if (!spat) {
X if (gimme == G_ARRAY)
X return --sp;
X str_set(str,Yes);
X STABSET(str);
X st[sp] = str;
X return sp;
X }
X if (!s)
X fatal("panic: do_match");
X if (spat->spat_flags & SPAT_USED) {
X#ifdef DEBUGGING
X if (debug & 8)
X deb("2.SPAT USED\n");
X#endif
X if (gimme == G_ARRAY)
X return --sp;
X str_set(str,No);
X STABSET(str);
X st[sp] = str;
X return sp;
X }
X --sp;
X if (spat->spat_runtime) {
X nointrp = "|)";
X sp = eval(spat->spat_runtime,G_SCALAR,sp);
X st = stack->ary_array;
X t = str_get(tmpstr = st[sp--]);
X nointrp = "";
X#ifdef DEBUGGING
X if (debug & 8)
X deb("2.SPAT /%s/\n",t);
X#endif
X if (spat->spat_regexp)
X regfree(spat->spat_regexp);
X spat->spat_regexp = regcomp(t,t+tmpstr->str_cur,
X spat->spat_flags & SPAT_FOLD,1);
X if (!*spat->spat_regexp->precomp && lastspat)
X spat = lastspat;
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 if (regexec(spat->spat_regexp, s, strend, s, 0,
X srchstr->str_pok & SP_STUDIED ? srchstr : Nullstr,
X gimme == G_ARRAY)) {
X if (spat->spat_regexp->subbase)
X curspat = spat;
X lastspat = spat;
X goto gotcha;
X }
X else {
X if (gimme == G_ARRAY)
X return sp;
X str_sset(str,&str_no);
X STABSET(str);
X st[++sp] = str;
X return sp;
X }
X }
X else {
X#ifdef DEBUGGING
X if (debug & 8) {
X char ch;
X
X if (spat->spat_flags & SPAT_ONCE)
X ch = '?';
X else
X ch = '/';
X deb("2.SPAT %c%s%c\n",ch,spat->spat_regexp->precomp,ch);
X }
X#endif
X if (!*spat->spat_regexp->precomp && lastspat)
X spat = lastspat;
X t = 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 < t)
X s = t;
X }
X else
X s = t;
X }
X else if (spat->spat_short) {
X if (spat->spat_flags & SPAT_SCANFIRST) {
X if (srchstr->str_pok & SP_STUDIED) {
X if (screamfirst[spat->spat_short->str_rare] < 0)
X goto nope;
X else if (!(s = screaminstr(srchstr,spat->spat_short)))
X goto nope;
X else if (spat->spat_flags & SPAT_ALL)
X goto yup;
X }
X#ifndef lint
X else if (!(s = fbminstr((unsigned char*)s,
X (unsigned char*)strend, spat->spat_short)))
X goto nope;
X#endif
X else if (spat->spat_flags & SPAT_ALL)
X goto yup;
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 < t)
X s = t;
X }
X else
X s = t;
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 if (regexec(spat->spat_regexp, s, strend, t, 0,
X srchstr->str_pok & SP_STUDIED ? srchstr : Nullstr,
X gimme == G_ARRAY)) {
X if (spat->spat_regexp->subbase)
X curspat = spat;
X lastspat = spat;
X if (spat->spat_flags & SPAT_ONCE)
X spat->spat_flags |= SPAT_USED;
X goto gotcha;
X }
X else {
X if (gimme == G_ARRAY)
X return sp;
X str_sset(str,&str_no);
X STABSET(str);
X st[++sp] = str;
X return sp;
X }
X }
X /*NOTREACHED*/
X
X gotcha:
X if (gimme == G_ARRAY) {
X int iters, i, len;
X
X iters = spat->spat_regexp->nparens;
X if (sp + iters >= stack->ary_max)
X astore(stack,sp + iters, Nullstr);
X
X for (i = 1; i <= iters; i++) {
X st[++sp] = str_static(&str_no);
X if (s = spat->spat_regexp->startp[i]) {
X len = spat->spat_regexp->endp[i] - s;
X if (len > 0)
X str_nset(st[sp],s,len);
X }
X }
X return sp;
X }
X else {
X str_sset(str,&str_yes);
X STABSET(str);
X st[++sp] = str;
X return sp;
X }
X
Xyup:
X ++spat->spat_short->str_u.str_useful;
X lastspat = spat;
X if (spat->spat_flags & SPAT_ONCE)
X spat->spat_flags |= SPAT_USED;
X if (sawampersand) {
X char *tmps;
X
X tmps = spat->spat_regexp->subbase = nsavestr(t,strend-t);
X tmps = spat->spat_regexp->startp[0] = tmps + (s - t);
X spat->spat_regexp->endp[0] = tmps + spat->spat_short->str_cur;
X curspat = spat;
X }
X str_sset(str,&str_yes);
X STABSET(str);
X st[++sp] = str;
X return sp;
X
Xnope:
X ++spat->spat_short->str_u.str_useful;
X str_sset(str,&str_no);
X STABSET(str);
X st[++sp] = str;
X return sp;
X}
X
Xint
Xdo_split(str,spat,limit,gimme,arglast)
XSTR *str;
Xregister SPAT *spat;
Xregister int limit;
Xint gimme;
Xint *arglast;
X{
X register ARRAY *ary = stack;
X STR **st = ary->ary_array;
X register int sp = arglast[0] + 1;
X register char *s = str_get(st[sp]);
X char *strend = s + st[sp--]->str_cur;
X register STR *dstr;
X register char *m;
X int iters = 0;
X int i;
X char *orig;
X int origlimit = limit;
X
X if (!spat || !s)
X fatal("panic: do_split");
X else if (spat->spat_runtime) {
X nointrp = "|)";
X sp = eval(spat->spat_runtime,G_SCALAR,sp);
X st = stack->ary_array;
X m = str_get(dstr = st[sp--]);
X nointrp = "";
X if (!dstr->str_cur || (*m == ' ' && dstr->str_cur == 1)) {
X str_set(dstr,"\\s+");
X m = dstr->str_ptr;
X spat->spat_flags |= SPAT_SKIPWHITE;
X }
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 (spat->spat_runtime->arg_type == O_ITEM &&
X (spat->spat_runtime[1].arg_type & A_MASK) == A_SINGLE) ) {
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 if (gimme != G_ARRAY) {
X ary = stab_xarray(spat->spat_repl[1].arg_ptr.arg_stab);
X if (ary) {
X ary->ary_fill = -1;
X sp = -1; /* temporarily switch stacks */
X }
X else
X ary = stack;
X }
X orig = s;
X if (spat->spat_flags & SPAT_SKIPWHITE) {
X while (isspace(*s))
X s++;
X }
X if (!limit)
X limit = 10001;
X if (spat->spat_short) {
X i = spat->spat_short->str_cur;
X if (i == 1) {
X i = *spat->spat_short->str_ptr;
X while (--limit) {
X for (m = s; m < strend && *m != i; m++) ;
X if (m >= strend)
X break;
X dstr = str_new(m-s);
X str_nset(dstr,s,m-s);
X (void)astore(ary, ++sp, dstr);
X s = m + 1;
X }
X }
X else {
X#ifndef lint
X while (s < strend && --limit &&
X (m=fbminstr((unsigned char*)s, (unsigned char*)strend,
X spat->spat_short)) )
X#endif
X {
X dstr = str_new(m-s);
X str_nset(dstr,s,m-s);
X (void)astore(ary, ++sp, dstr);
X s = m + i;
X }
X }
X }
X else {
X while (s < strend && --limit &&
X regexec(spat->spat_regexp, s, strend, orig, 1, Nullstr, TRUE) ) {
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 dstr = str_new(m-s);
X str_nset(dstr,s,m-s);
X (void)astore(ary, ++sp, dstr);
X if (spat->spat_regexp->nparens) {
X for (i = 1; i <= spat->spat_regexp->nparens; i++) {
X s = spat->spat_regexp->startp[i];
X m = spat->spat_regexp->endp[i];
X dstr = str_new(m-s);
X str_nset(dstr,s,m-s);
X (void)astore(ary, ++sp, dstr);
X }
X }
X s = spat->spat_regexp->endp[0];
X }
X }
X if (gimme == G_ARRAY)
X iters = sp - arglast[0];
X else
X iters = sp + 1;
X if (iters > 9999)
X fatal("Split loop");
X if (s < strend || origlimit) { /* keep field after final delim? */
X dstr = str_new(0); /* if they interpolate, it's null anyway */
X str_nset(dstr,s,strend-s);
X (void)astore(ary, ++sp, dstr);
X iters++;
X }
X else {
X#ifndef I286
X while (iters > 0 && ary->ary_array[sp]->str_cur == 0)
X iters--,sp--;
X#else
X char *zaps;
X int zapb;
X
X if (iters > 0) {
X zaps = str_get(afetch(ary,sp,FALSE));
X zapb = (int) *zaps;
X }
X
X while (iters > 0 && (!zapb)) {
X iters--,sp--;
X if (iters > 0) {
X zaps = str_get(afetch(ary,iters-1,FALSE));
X zapb = (int) *zaps;
X }
X }
X#endif
X }
X if (gimme == G_ARRAY)
X return sp;
X else {
X ary->ary_fill = sp;
X sp = arglast[0] + 1;
X str_numset(str,(double)iters);
X STABSET(str);
X st[sp] = str;
X return sp;
X }
X}
X
Xint
Xdo_unpack(str,gimme,arglast)
XSTR *str;
Xint gimme;
Xint *arglast;
X{
X STR **st = stack->ary_array;
X register int sp = arglast[0] + 1;
X register char *pat = str_get(st[sp++]);
X register char *s = str_get(st[sp]);
X char *strend = s + st[sp--]->str_cur;
X register char *patend = pat + st[sp]->str_cur;
X int datumtype;
X register int len;
X
X /* These must not be in registers: */
X char achar;
X short ashort;
X int aint;
X long along;
X unsigned char auchar;
X unsigned short aushort;
X unsigned int auint;
X unsigned long aulong;
X char *aptr;
X
X if (gimme != G_ARRAY) {
X str_sset(str,&str_undef);
X STABSET(str);
X st[sp] = str;
X return sp;
X }
X sp--;
X while (pat < patend) {
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 s += len;
X break;
X case 'A':
X case 'a':
X if (s + len > strend)
X len = strend - s;
X str = str_new(len);
X str_nset(str,s,len);
X s += len;
X if (datumtype == 'A') {
X aptr = s; /* borrow register */
X s = str->str_ptr + len - 1;
X while (s >= str->str_ptr && (!*s || isspace(*s)))
X s--;
X *++s = '\0';
X str->str_cur = s - str->str_ptr;
X s = aptr; /* unborrow register */
X }
X (void)astore(stack, ++sp, str);
X break;
X case 'c':
X while (len-- > 0) {
X if (s + sizeof(char) > strend)
X achar = 0;
X else {
X bcopy(s,(char*)&achar,sizeof(char));
X s += sizeof(char);
X }
X str = str_new(0);
X aint = achar;
X if (aint >= 128) /* fake up signed chars */
X aint -= 256;
X str_numset(str,(double)aint);
X (void)astore(stack, ++sp, str);
X }
X break;
X case 'C':
X while (len-- > 0) {
X if (s + sizeof(unsigned char) > strend)
X auchar = 0;
X else {
X bcopy(s,(char*)&auchar,sizeof(unsigned char));
X s += sizeof(unsigned char);
X }
X str = str_new(0);
X str_numset(str,(double)auchar);
X (void)astore(stack, ++sp, str);
X }
X break;
X case 's':
X while (len-- > 0) {
X if (s + sizeof(short) > strend)
X ashort = 0;
X else {
X bcopy(s,(char*)&ashort,sizeof(short));
X s += sizeof(short);
X }
X str = str_new(0);
X str_numset(str,(double)ashort);
X (void)astore(stack, ++sp, str);
X }
X break;
X case 'n':
X case 'S':
X while (len-- > 0) {
X if (s + sizeof(unsigned short) > strend)
X aushort = 0;
X else {
X bcopy(s,(char*)&aushort,sizeof(unsigned short));
X s += sizeof(unsigned short);
X }
X str = str_new(0);
X#ifdef NTOHS
X if (datumtype == 'n')
X aushort = ntohs(aushort);
X#endif
X str_numset(str,(double)aushort);
X (void)astore(stack, ++sp, str);
X }
X break;
X case 'i':
X while (len-- > 0) {
X if (s + sizeof(int) > strend)
X aint = 0;
X else {
X bcopy(s,(char*)&aint,sizeof(int));
X s += sizeof(int);
X }
X str = str_new(0);
X str_numset(str,(double)aint);
X (void)astore(stack, ++sp, str);
X }
X break;
X case 'I':
X while (len-- > 0) {
X if (s + sizeof(unsigned int) > strend)
X auint = 0;
X else {
X bcopy(s,(char*)&auint,sizeof(unsigned int));
X s += sizeof(unsigned int);
X }
X str = str_new(0);
X str_numset(str,(double)auint);
X (void)astore(stack, ++sp, str);
X }
X break;
X case 'l':
X while (len-- > 0) {
X if (s + sizeof(long) > strend)
X along = 0;
X else {
X bcopy(s,(char*)&along,sizeof(long));
X s += sizeof(long);
X }
X str = str_new(0);
X str_numset(str,(double)along);
X (void)astore(stack, ++sp, str);
X }
X break;
X case 'N':
X case 'L':
X while (len-- > 0) {
X if (s + sizeof(unsigned long) > strend)
X aulong = 0;
X else {
X bcopy(s,(char*)&aulong,sizeof(unsigned long));
X s += sizeof(unsigned long);
X }
X str = str_new(0);
X#ifdef NTOHL
X if (datumtype == 'N')
X aulong = ntohl(aulong);
X#endif
X str_numset(str,(double)aulong);
X (void)astore(stack, ++sp, str);
X }
X break;
X case 'p':
X while (len-- > 0) {
X if (s + sizeof(char*) > strend)
X aptr = 0;
X else {
X bcopy(s,(char*)&aptr,sizeof(char*));
X s += sizeof(char*);
X }
X str = str_new(0);
X if (aptr)
X str_set(str,aptr);
X (void)astore(stack, ++sp, str);
X }
X break;
X }
X }
X return sp;
X}
X
Xint
Xdo_slice(stab,numarray,lval,gimme,arglast)
Xregister STAB *stab;
Xint numarray;
Xint lval;
Xint gimme;
Xint *arglast;
X{
X register STR **st = stack->ary_array;
X register int sp = arglast[1];
X register int max = arglast[2];
X register char *tmps;
X register int len;
X register int magic = 0;
X
X if (lval && !numarray) {
X if (stab == envstab)
X magic = 'E';
X else if (stab == sigstab)
X magic = 'S';
X#ifdef SOME_DBM
X else if (stab_hash(stab)->tbl_dbm)
X magic = 'D';
X#endif /* SOME_DBM */
X }
X
X if (gimme == G_ARRAY) {
X if (numarray) {
X while (sp < max) {
X if (st[++sp]) {
X st[sp-1] = afetch(stab_array(stab),(int)str_gnum(st[sp]),
X lval);
X }
X else
X st[sp-1] = Nullstr;
X }
X }
X else {
X while (sp < max) {
X if (st[++sp]) {
X tmps = str_get(st[sp]);
X len = st[sp]->str_cur;
X st[sp-1] = hfetch(stab_hash(stab),tmps,len, lval);
X if (magic)
X str_magic(st[sp-1],stab,magic,tmps,len);
X }
X else
X st[sp-1] = Nullstr;
X }
X }
X sp--;
X }
X else {
X if (numarray) {
X if (st[max])
X st[sp] = afetch(stab_array(stab),(int)str_gnum(st[max]), lval);
X else
X st[sp] = Nullstr;
X }
X else {
X if (st[max]) {
X tmps = str_get(st[max]);
X len = st[max]->str_cur;
X st[sp] = hfetch(stab_hash(stab),tmps,len, lval);
X if (magic)
X str_magic(st[sp],stab,magic,tmps,len);
X }
X else
X st[sp] = Nullstr;
X }
X }
X return sp;
X}
X
Xint
Xdo_grep(arg,str,gimme,arglast)
Xregister ARG *arg;
XSTR *str;
Xint gimme;
Xint *arglast;
X{
X STR **st = stack->ary_array;
X register STR **dst = &st[arglast[1]];
X register STR **src = dst + 1;
X register int sp = arglast[2];
X register int i = sp - arglast[1];
X int oldsave = savestack->ary_fill;
X
X savesptr(&stab_val(defstab));
X if ((arg[1].arg_type & A_MASK) != A_EXPR)
X dehoist(arg,1);
X arg = arg[1].arg_ptr.arg_arg;
X while (i-- > 0) {
X stab_val(defstab) = *src;
X (void)eval(arg,G_SCALAR,sp);
X if (str_true(st[sp+1]))
X *dst++ = *src;
X src++;
X }
X restorelist(oldsave);
X if (gimme != G_ARRAY) {
X str_sset(str,&str_undef);
X STABSET(str);
X st[arglast[0]+1] = str;
X return arglast[0]+1;
X }
X return arglast[0] + (dst - &st[arglast[1]]);
X}
X
Xint
Xdo_reverse(str,gimme,arglast)
XSTR *str;
Xint gimme;
Xint *arglast;
X{
X STR **st = stack->ary_array;
X register STR **up = &st[arglast[1]];
X register STR **down = &st[arglast[2]];
X register int i = arglast[2] - arglast[1];
X
X if (gimme != G_ARRAY) {
X str_sset(str,&str_undef);
X STABSET(str);
X st[arglast[0]+1] = str;
X return arglast[0]+1;
X }
X while (i-- > 0) {
X *up++ = *down;
X *down-- = *up;
X }
X return arglast[2] - 1;
X}
X
Xstatic CMD *sortcmd;
Xstatic STAB *firststab = Nullstab;
Xstatic STAB *secondstab = Nullstab;
X
Xint
Xdo_sort(str,stab,gimme,arglast)
XSTR *str;
XSTAB *stab;
Xint gimme;
Xint *arglast;
X{
X STR **st = stack->ary_array;
X int sp = arglast[1];
X register STR **up;
X register int max = arglast[2] - sp;
X register int i;
X int sortcmp();
X int sortsub();
X STR *oldfirst;
X STR *oldsecond;
X ARRAY *oldstack;
X static ARRAY *sortstack = Null(ARRAY*);
X
X if (gimme != G_ARRAY) {
X str_sset(str,&str_undef);
X STABSET(str);
X st[sp] = str;
X return sp;
X }
X up = &st[sp];
X for (i = 0; i < max; i++) {
X if ((*up = up[1]) && !(*up)->str_pok)
X (void)str_2ptr(*up);
X up++;
X }
X sp--;
X if (max > 1) {
X if (stab_sub(stab) && (sortcmd = stab_sub(stab)->cmd)) {
X int oldtmps_base = tmps_base;
X
X if (!sortstack) {
X sortstack = anew(Nullstab);
X sortstack->ary_flags = 0;
X }
X oldstack = stack;
X stack = sortstack;
X tmps_base = tmps_max;
X if (!firststab) {
X firststab = stabent("a",TRUE);
X secondstab = stabent("b",TRUE);
X }
X oldfirst = stab_val(firststab);
X oldsecond = stab_val(secondstab);
X#ifndef lint
X qsort((char*)(st+sp+1),max,sizeof(STR*),sortsub);
X#else
X qsort(Nullch,max,sizeof(STR*),sortsub);
X#endif
X stab_val(firststab) = oldfirst;
X stab_val(secondstab) = oldsecond;
X tmps_base = oldtmps_base;
X stack = oldstack;
X }
X#ifndef lint
X else
X qsort((char*)(st+sp+1),max,sizeof(STR*),sortcmp);
X#endif
X }
X up = &st[arglast[1]];
X while (max > 0 && !*up)
X max--,up--;
X return sp+max;
X}
X
Xint
Xsortsub(str1,str2)
XSTR **str1;
XSTR **str2;
X{
X if (!*str1)
X return -1;
X if (!*str2)
X return 1;
X stab_val(firststab) = *str1;
X stab_val(secondstab) = *str2;
X cmd_exec(sortcmd,G_SCALAR,-1);
X return (int)str_gnum(*stack->ary_array);
X}
X
Xsortcmp(strp1,strp2)
XSTR **strp1;
XSTR **strp2;
X{
X register STR *str1 = *strp1;
X register STR *str2 = *strp2;
X int retval;
X
X if (!str1)
X return -1;
X if (!str2)
X return 1;
X
X if (str1->str_cur < str2->str_cur) {
X if (retval = bcmp(str1->str_ptr, str2->str_ptr, str1->str_cur))
X return retval;
X else
X return 1;
X }
X else if (retval = bcmp(str1->str_ptr, str2->str_ptr, str2->str_cur))
X return retval;
X else if (str1->str_cur == str2->str_cur)
X return 0;
X else
X return -1;
X}
X
Xint
Xdo_range(gimme,arglast)
Xint gimme;
Xint *arglast;
X{
X STR **st = stack->ary_array;
X register int sp = arglast[0];
X register int i = (int)str_gnum(st[sp+1]);
X register ARRAY *ary = stack;
X register STR *str;
X int max = (int)str_gnum(st[sp+2]);
X
X if (gimme != G_ARRAY)
X fatal("panic: do_range");
X
X while (i <= max) {
X (void)astore(ary, ++sp, str = str_static(&str_no));
X str_numset(str,(double)i++);
X }
X return sp;
X}
X
Xint
Xdo_tms(str,gimme,arglast)
XSTR *str;
Xint gimme;
Xint *arglast;
X{
X STR **st = stack->ary_array;
X register int sp = arglast[0];
X
X if (gimme != G_ARRAY) {
X str_sset(str,&str_undef);
X STABSET(str);
X st[++sp] = str;
X return sp;
X }
X (void)times(×buf);
X
X#ifndef HZ
X#define HZ 60
X#endif
X
X#ifndef lint
X (void)astore(stack,++sp,str_nmake(((double)timesbuf.tms_utime)/HZ));
X (void)astore(stack,++sp,str_nmake(((double)timesbuf.tms_stime)/HZ));
X (void)astore(stack,++sp,str_nmake(((double)timesbuf.tms_cutime)/HZ));
X (void)astore(stack,++sp,str_nmake(((double)timesbuf.tms_cstime)/HZ));
X#else
X (void)astore(stack,++sp,str_nmake(0.0));
X#endif
X return sp;
X}
X
Xint
Xdo_time(str,tmbuf,gimme,arglast)
XSTR *str;
Xstruct tm *tmbuf;
Xint gimme;
Xint *arglast;
X{
X register ARRAY *ary = stack;
X STR **st = ary->ary_array;
X register int sp = arglast[0];
X
X if (!tmbuf || gimme != G_ARRAY) {
X str_sset(str,&str_undef);
X STABSET(str);
X st[++sp] = str;
X return sp;
X }
X (void)astore(ary,++sp,str_nmake((double)tmbuf->tm_sec));
X (void)astore(ary,++sp,str_nmake((double)tmbuf->tm_min));
X (void)astore(ary,++sp,str_nmake((double)tmbuf->tm_hour));
X (void)astore(ary,++sp,str_nmake((double)tmbuf->tm_mday));
X (void)astore(ary,++sp,str_nmake((double)tmbuf->tm_mon));
X (void)astore(ary,++sp,str_nmake((double)tmbuf->tm_year));
X (void)astore(ary,++sp,str_nmake((double)tmbuf->tm_wday));
X (void)astore(ary,++sp,str_nmake((double)tmbuf->tm_yday));
X (void)astore(ary,++sp,str_nmake((double)tmbuf->tm_isdst));
X return sp;
X}
X
Xint
Xdo_kv(str,hash,kv,gimme,arglast)
XSTR *str;
XHASH *hash;
Xint kv;
Xint gimme;
Xint *arglast;
X{
X register ARRAY *ary = stack;
X STR **st = ary->ary_array;
X register int sp = arglast[0];
X int max = 0;
X int i;
X register HENT *entry;
X char *tmps;
X STR *tmpstr;
X int dokeys = (kv == O_KEYS || kv == O_HASH);
X int dovalues = (kv == O_VALUES || kv == O_HASH);
X
X if (gimme != G_ARRAY) {
X str_sset(str,&str_undef);
X STABSET(str);
X st[++sp] = str;
X return sp;
X }
X (void)hiterinit(hash);
X while (entry = hiternext(hash)) {
X if (dokeys) {
X max++;
X tmps = hiterkey(entry,&i);
X (void)astore(ary,++sp,str_make(tmps,i));
X }
X if (dovalues) {
X tmpstr = str_new(0);
X#ifdef DEBUGGING
X if (debug & 8192) {
X sprintf(buf,"%d%%%d=%d\n",entry->hent_hash,
X hash->tbl_max+1,entry->hent_hash & hash->tbl_max);
X str_set(tmpstr,buf);
X }
X else
X#endif
X str_sset(tmpstr,hiterval(hash,entry));
X (void)astore(ary,++sp,tmpstr);
X }
X }
X return sp;
X}
X
Xint
Xdo_each(str,hash,gimme,arglast)
XSTR *str;
XHASH *hash;
Xint gimme;
Xint *arglast;
X{
X STR **st = stack->ary_array;
X register int sp = arglast[0];
X static STR *mystrk = Nullstr;
X HENT *entry = hiternext(hash);
X int i;
X char *tmps;
X
X if (mystrk) {
X str_free(mystrk);
X mystrk = Nullstr;
X }
X
X if (entry) {
X if (gimme == G_ARRAY) {
X tmps = hiterkey(entry, &i);
X st[++sp] = mystrk = str_make(tmps,i);
X }
X st[++sp] = str;
X str_sset(str,hiterval(hash,entry));
X STABSET(str);
X return sp;
X }
X else
X return sp;
X}
!STUFFY!FUNK!
echo Extracting perly.c
sed >perly.c <<'!STUFFY!FUNK!' -e 's/X//'
Xchar rcsid[] = "$Header: perly.c,v 3.0 beta$\nPatch level: ###\n";
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: perly.c,v $
X */
X
X#include "EXTERN.h"
X#include "perl.h"
X#include "perly.h"
X#include "patchlevel.h"
X
X#ifdef IAMSUID
X#ifndef DOSUID
X#define DOSUID
X#endif
X#endif
X
X#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
X#ifdef DOSUID
X#undef DOSUID
X#endif
X#endif
X
Xmain(argc,argv,env)
Xregister int argc;
Xregister char **argv;
Xregister char **env;
X{
X register STR *str;
X register char *s;
X char *index(), *strcpy(), *getenv();
X bool dosearch = FALSE;
X char **origargv = argv;
X#ifdef DOSUID
X char *validarg = "";
X#endif
X int gid = (int)getgid();
X int egid = (int)getegid();
X
X#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
X#ifdef IAMSUID
X#undef IAMSUID
X fatal("suidperl is no longer needed since the kernel can now execute\n\
Xsetuid perl scripts securely.\n");
X#endif
X#endif
X
X uid = (int)getuid();
X euid = (int)geteuid();
X if (do_undump) {
X do_undump = 0;
X loop_ptr = 0; /* start label stack again */
X goto just_doit;
X }
X (void)sprintf(index(rcsid,'#'), "%d\n", PATCHLEVEL);
X linestr = str_new(80);
X str_nset(linestr,"",0);
X str = str_make("",0); /* first used for -I flags */
X curstash = defstash = hnew(0);
X curstname = str_make("main",4);
X stab_xhash(stabent("_main",TRUE)) = defstash;
X incstab = aadd(stabent("INC",TRUE));
X for (argc--,argv++; argc; argc--,argv++) {
X if (argv[0][0] != '-' || !argv[0][1])
X break;
X#ifdef DOSUID
X if (*validarg)
X validarg = " PHOOEY ";
X else
X validarg = argv[0];
X#endif
X s = argv[0]+1;
X reswitch:
X switch (*s) {
X case 'a':
X minus_a = TRUE;
X s++;
X goto reswitch;
X case 'd':
X#ifdef TAINT
X if (euid != uid || egid != gid)
X fatal("No -d allowed in setuid scripts");
X#endif
X perldb = TRUE;
X s++;
X goto reswitch;
X#ifdef DEBUGGING
X case 'D':
X#ifdef TAINT
X if (euid != uid || egid != gid)
X fatal("No -D allowed in setuid scripts");
X#endif
X debug = atoi(s+1);
X#ifdef YYDEBUG
X yydebug = (debug & 1);
X#endif
X break;
X#endif
X case 'e':
X#ifdef TAINT
X if (euid != uid || egid != gid)
X fatal("No -e allowed in setuid scripts");
X#endif
X if (!e_fp) {
X e_tmpname = savestr(TMPPATH);
X (void)mktemp(e_tmpname);
X e_fp = fopen(e_tmpname,"w");
X }
X if (argv[1])
X fputs(argv[1],e_fp);
X (void)putc('\n', e_fp);
X argc--,argv++;
X break;
X case 'i':
X inplace = savestr(s+1);
X argvoutstab = stabent("ARGVOUT",TRUE);
X break;
X case 'I':
X#ifdef TAINT
X if (euid != uid || egid != gid)
X fatal("No -I allowed in setuid scripts");
X#endif
X str_cat(str,"-");
X str_cat(str,s);
X str_cat(str," ");
X if (*++s) {
X (void)apush(stab_array(incstab),str_make(s,0));
X }
X else {
X (void)apush(stab_array(incstab),str_make(argv[1],0));
X str_cat(str,argv[1]);
X argc--,argv++;
X str_cat(str," ");
X }
X break;
X case 'n':
X minus_n = TRUE;
X s++;
X goto reswitch;
X case 'p':
X minus_p = TRUE;
X s++;
X goto reswitch;
X case 'P':
X#ifdef TAINT
X if (euid != uid || egid != gid)
X fatal("No -P allowed in setuid scripts");
X#endif
X preprocess = TRUE;
X s++;
X goto reswitch;
X case 's':
X#ifdef TAINT
X if (euid != uid || egid != gid)
X fatal("No -s allowed in setuid scripts");
X#endif
X doswitches = TRUE;
X s++;
X goto reswitch;
X case 'S':
X dosearch = TRUE;
X s++;
X goto reswitch;
X case 'u':
X do_undump = TRUE;
X s++;
X goto reswitch;
X case 'U':
X unsafe = TRUE;
X s++;
X goto reswitch;
X case 'v':
X fputs(rcsid,stdout);
X fputs("\nCopyright (c) 1989, Larry Wall\n\n\
XPerl may be copied only under the terms of the GNU General Public License,\n\
Xa copy of which can be found with the Perl 3.0 distribution kit.\n",stdout);
X exit(0);
X case 'w':
X dowarn = TRUE;
X s++;
X goto reswitch;
X case '-':
X argc--,argv++;
X goto switch_end;
X case 0:
X break;
X default:
X fatal("Unrecognized switch: -%s",s);
X }
X }
X switch_end:
X if (e_fp) {
X (void)fclose(e_fp);
X argc++,argv--;
X argv[0] = e_tmpname;
X }
X#ifndef PRIVLIB
X#define PRIVLIB "/usr/local/lib/perl"
X#endif
X (void)apush(stab_array(incstab),str_make(PRIVLIB,0));
X
X str_set(&str_no,No);
X str_set(&str_yes,Yes);
X
X /* open script */
X
X if (argv[0] == Nullch)
X argv[0] = "-";
X if (dosearch && !index(argv[0], '/') && (s = getenv("PATH"))) {
X char *xfound = Nullch, *xfailed = Nullch;
X int len;
X
X bufend = s + strlen(s);
X while (*s) {
X s = cpytill(tokenbuf,s,bufend,':',&len);
X if (*s)
X s++;
X if (len)
X (void)strcat(tokenbuf+len,"/");
X (void)strcat(tokenbuf+len,argv[0]);
X#ifdef DEBUGGING
X if (debug & 1)
X fprintf(stderr,"Looking for %s\n",tokenbuf);
X#endif
X if (stat(tokenbuf,&statbuf) < 0) /* not there? */
X continue;
X if ((statbuf.st_mode & S_IFMT) == S_IFREG
X && cando(S_IREAD,TRUE,&statbuf) && cando(S_IEXEC,TRUE,&statbuf)) {
X xfound = tokenbuf; /* bingo! */
X break;
X }
X if (!xfailed)
X xfailed = savestr(tokenbuf);
X }
X if (!xfound)
X fatal("Can't execute %s", xfailed ? xfailed : argv[0] );
X if (xfailed)
X Safefree(xfailed);
X argv[0] = savestr(xfound);
X }
X
X pidstatary = anew(Nullstab); /* for remembering popen pids, status */
X
X filename = savestr(argv[0]);
X origfilename = savestr(filename);
X if (strEQ(filename,"-"))
X argv[0] = "";
X if (preprocess) {
X str_cat(str,"-I");
X str_cat(str,PRIVLIB);
X (void)sprintf(buf, "\
X/bin/sed -e '/^[^#]/b' \
X -e '/^#[ ]*include[ ]/b' \
X -e '/^#[ ]*define[ ]/b' \
X -e '/^#[ ]*if[ ]/b' \
X -e '/^#[ ]*ifdef[ ]/b' \
X -e '/^#[ ]*ifndef[ ]/b' \
X -e '/^#[ ]*else/b' \
X -e '/^#[ ]*endif/b' \
X -e 's/^#.*//' \
X %s | %s -C %s %s",
X argv[0], CPPSTDIN, str_get(str), CPPMINUS);
X#ifdef IAMSUID /* actually, this is caught earlier */
X if (euid != uid && !euid) /* if running suidperl */
X#ifdef SETEUID
X (void)seteuid(uid); /* musn't stay setuid root */
X#else
X#ifdef SETREUID
X (void)setreuid(-1, uid);
X#else
X setuid(uid);
X#endif
X#endif
X#endif /* IAMSUID */
X rsfp = mypopen(buf,"r");
X }
X else if (!*argv[0])
X rsfp = stdin;
X else
X rsfp = fopen(argv[0],"r");
X if (rsfp == Nullfp) {
X extern char *sys_errlist[];
X extern int errno;
X
X#ifdef DOSUID
X#ifndef IAMSUID /* in case script is not readable before setuid */
X if (euid && stat(filename,&statbuf) >= 0 &&
X statbuf.st_mode & (S_ISUID|S_ISGID)) {
X (void)sprintf(buf, "%s/%s", BIN, "suidperl");
X execv(buf, origargv); /* try again */
X fatal("Can't do setuid\n");
X }
X#endif
X#endif
X fatal("Can't open perl script \"%s\": %s\n",
X filename, sys_errlist[errno]);
X }
X str_free(str); /* free -I directories */
X
X /* do we need to emulate setuid on scripts? */
X
X /* This code is for those BSD systems that have setuid #! scripts disabled
X * in the kernel because of a security problem. Merely defining DOSUID
X * in perl will not fix that problem, but if you have disabled setuid
X * scripts in the kernel, this will attempt to emulate setuid and setgid
X * on scripts that have those now-otherwise-useless bits set. The setuid
X * root version must be called suidperl. If regular perl discovers that
X * it has opened a setuid script, it calls suidperl with the same argv
X * that it had. If suidperl finds that the script it has just opened
X * is NOT setuid root, it sets the effective uid back to the uid. We
X * don't just make perl setuid root because that loses the effective
X * uid we had before invoking perl, if it was different from the uid.
X *
X * DOSUID must be defined in both perl and suidperl, and IAMSUID must
X * be defined in suidperl only. suidperl must be setuid root. The
X * Configure script will set this up for you if you want it.
X *
X * There is also the possibility of have a script which is running
X * set-id due to a C wrapper. We want to do the TAINT checks
X * on these set-id scripts, but don't want to have the overhead of
X * them in normal perl, and can't use suidperl because it will lose
X * the effective uid info, so we have an additional non-setuid root
X * version called taintperl that just does the TAINT checks.
X */
X
X#ifdef DOSUID
X if (fstat(fileno(rsfp),&statbuf) < 0) /* normal stat is insecure */
X fatal("Can't stat script \"%s\"",filename);
X if (statbuf.st_mode & (S_ISUID|S_ISGID)) {
X int len;
X
X#ifdef IAMSUID
X#ifndef SETREUID
X /* On this access check to make sure the directories are readable,
X * there is actually a small window that the user could use to make
X * filename point to an accessible directory. So there is a faint
X * chance that someone could execute a setuid script down in a
X * non-accessible directory. I don't know what to do about that.
X * But I don't think it's too important. The manual lies when
X * it says access() is useful in setuid programs.
X */
X if (access(filename,1)) /* as a double check */
X fatal("Permission denied");
X#else
X /* If we can swap euid and uid, then we can determine access rights
X * with a simple stat of the file, and then compare device and
X * inode to make sure we did stat() on the same file we opened.
X * Then we just have to make sure he or she can execute it.
X */
X {
X struct stat tmpstatbuf;
X
X if (setreuid(euid,uid) < 0 || getuid() != euid || geteuid() != uid)
X fatal("Can't swap uid and euid"); /* really paranoid */
X if (stat(filename,&tmpstatbuf) < 0) /* testing full pathname here */
X fatal("Permission denied");
X if (tmpstatbuf.st_dev != statbuf.st_dev ||
X tmpstatbuf.st_ino != statbuf.st_ino) {
X (void)fclose(rsfp);
X if (rsfp = mypopen("/bin/mail root","w")) { /* heh, heh */
X fprintf(rsfp,
X"User %d tried to run dev %d ino %d in place of dev %d ino %d!\n\
X(Filename of set-id script was %s, uid %d gid %d.)\n\nSincerely,\nperl\n",
X uid,tmpstatbuf.st_dev, tmpstatbuf.st_ino,
X statbuf.st_dev, statbuf.st_ino,
X filename, statbuf.st_uid, statbuf.st_gid);
X (void)mypclose(rsfp);
X }
X fatal("Permission denied\n");
X }
X if (setreuid(uid,euid) < 0 || getuid() != uid || geteuid() != euid)
X fatal("Can't reswap uid and euid");
X if (!cando(S_IEXEC,FALSE,&statbuf)) /* can real uid exec? */
X fatal("Permission denied\n");
X }
X#endif /* SETREUID */
X#endif /* IAMSUID */
X
X if ((statbuf.st_mode & S_IFMT) != S_IFREG)
X fatal("Permission denied");
X if ((statbuf.st_mode >> 6) & S_IWRITE)
X fatal("Setuid/gid script is writable by world");
X doswitches = FALSE; /* -s is insecure in suid */
X line++;
X if (fgets(tokenbuf,sizeof tokenbuf, rsfp) == Nullch ||
X strnNE(tokenbuf,"#!",2) ) /* required even on Sys V */
X fatal("No #! line");
X for (s = tokenbuf+2; !isspace(*s); s++) ;
X if (strnNE(s-4,"perl",4)) /* sanity check */
X fatal("Not a perl script");
X while (*s == ' ' || *s == '\t') s++;
X /*
X * #! arg must be what we saw above. They can invoke it by
X * mentioning suidperl explicitly, but they may not add any strange
X * arguments beyond what #! says if they do invoke suidperl that way.
X */
X len = strlen(validarg);
X if (strEQ(validarg," PHOOEY ") ||
X strnNE(s,validarg,len) || !isspace(s[len]))
X fatal("Args must match #! line");
X
X#ifndef IAMSUID
X if (euid != uid && (statbuf.st_mode & S_ISUID) &&
X euid == statbuf.st_uid)
X if (!do_undump)
X fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
XFIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
X#endif /* IAMSUID */
X
X if (euid) { /* oops, we're not the setuid root perl */
X (void)fclose(rsfp);
X#ifndef IAMSUID
X (void)sprintf(buf, "%s/%s", BIN, "suidperl");
X execv(buf, origargv); /* try again */
X#endif
X fatal("Can't do setuid\n");
X }
X
X if (statbuf.st_mode & S_ISGID && statbuf.st_gid != getegid())
X#ifdef SETEGID
X (void)setegid(statbuf.st_gid);
X#else
X#ifdef SETREGID
X (void)setregid((GIDTYPE)-1,statbuf.st_gid);
X#else
X setgid(statbuf.st_gid);
X#endif
X#endif
X if (statbuf.st_mode & S_ISUID) {
X if (statbuf.st_uid != euid)
X#ifdef SETEUID
X (void)seteuid(statbuf.st_uid); /* all that for this */
X#else
X#ifdef SETREUID
X (void)setreuid((UIDTYPE)-1,statbuf.st_uid);
X#else
X setuid(statbuf.st_uid);
X#endif
X#endif
X }
X else if (uid) /* oops, mustn't run as root */
X#ifdef SETEUID
X (void)seteuid((UIDTYPE)uid);
X#else
X#ifdef SETREUID
X (void)setreuid((UIDTYPE)-1,(UIDTYPE)uid);
X#else
X setuid((UIDTYPE)uid);
X#endif
X#endif
X euid = (int)geteuid();
X if (!cando(S_IEXEC,TRUE,&statbuf))
X fatal("Permission denied\n"); /* they can't do this */
X }
X#ifdef IAMSUID
X else if (preprocess)
X fatal("-P not allowed for setuid/setgid script\n");
X else
X fatal("Script is not setuid/setgid in suidperl\n");
X#else
X#ifndef TAINT /* we aren't taintperl or suidperl */
X /* script has a wrapper--can't run suidperl or we lose euid */
X else if (euid != uid || egid != gid) {
X (void)fclose(rsfp);
X (void)sprintf(buf, "%s/%s", BIN, "taintperl");
X execv(buf, origargv); /* try again */
X fatal("Can't run setuid script with taint checks");
X }
X#endif /* TAINT */
X#endif /* IAMSUID */
X#else /* !DOSUID */
X#ifndef TAINT /* we aren't taintperl or suidperl */
X if (euid != uid || egid != gid) { /* (suidperl doesn't exist, in fact) */
X#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
X fstat(fileno(rsfp),&statbuf); /* may be either wrapped or real suid */
X if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
X ||
X (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
X )
X if (!do_undump)
X fatal("YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
XFIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
X#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
X /* not set-id, must be wrapped */
X (void)fclose(rsfp);
X (void)sprintf(buf, "%s/%s", BIN, "taintperl");
X execv(buf, origargv); /* try again */
X fatal("Can't run setuid script with taint checks");
X }
X#endif /* TAINT */
X#endif /* DOSUID */
X
X defstab = stabent("_",TRUE);
X
X if (perldb) {
X debstash = hnew(0);
X stab_xhash(stabent("_DB",TRUE)) = debstash;
X curstash = debstash;
X lineary = stab_xarray(aadd((tmpstab = stabent("line",TRUE))));
X stab_flags(tmpstab) |= SF_MULTI;
X subname = str_make("main",4);
X DBstab = stabent("DB",TRUE);
X stab_flags(DBstab) |= SF_MULTI;
X DBsub = hadd(tmpstab = stabent("sub",TRUE));
X stab_flags(tmpstab) |= SF_MULTI;
X DBsingle = stab_val((tmpstab = stabent("single",TRUE)));
X stab_flags(tmpstab) |= SF_MULTI;
X curstash = defstash;
X }
X
X /* init tokener */
X
X bufend = bufptr = str_get(linestr);
X
X savestack = anew(Nullstab); /* for saving non-local values */
X stack = anew(Nullstab); /* for saving non-local values */
X stack->ary_flags = 0; /* not a real array */
X
X /* now parse the script */
X
X error_count = 0;
X if (yyparse() || error_count)
X fatal("Execution aborted due to compilation errors.\n");
X
X curstash = defstash;
X
X if (dowarn) {
X stab_check('A','Z');
X stab_check('a','z');
X }
X
X preprocess = FALSE;
X if (e_fp) {
X e_fp = Nullfp;
X (void)UNLINK(e_tmpname);
X }
X
X /* initialize everything that won't change if we undump */
X
X if (sigstab = stabent("SIG",allstabs))
X (void)hadd(sigstab);
X
X magicalize("!#?^~=-%0123456789.+&*()<>,\\/[|`':");
X
X amperstab = stabent("&",allstabs);
X leftstab = stabent("`",allstabs);
X rightstab = stabent("'",allstabs);
X sawampersand = (amperstab || leftstab || rightstab);
X if (tmpstab = stabent(":",allstabs))
X str_set(STAB_STR(tmpstab),chopset);
X
X /* these aren't necessarily magical */
X if (tmpstab = stabent(";",allstabs))
X str_set(STAB_STR(tmpstab),"\034");
X#ifdef TAINT
X tainted = 1;
X#endif
X if (tmpstab = stabent("0",allstabs))
X str_set(STAB_STR(tmpstab),origfilename);
X#ifdef TAINT
X tainted = 0;
X#endif
X if (tmpstab = stabent("]",allstabs))
X str_set(STAB_STR(tmpstab),rcsid);
X str_nset(stab_val(stabent("\"", TRUE)), " ", 1);
X
X stdinstab = stabent("STDIN",TRUE);
X stab_io(stdinstab) = stio_new();
X stab_io(stdinstab)->ofp = stab_io(stdinstab)->ifp = stdin;
X stab_io(stabent("stdin",TRUE)) = stab_io(stdinstab);
X
X tmpstab = stabent("STDOUT",TRUE);
X stab_io(tmpstab) = stio_new();
X stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stdout;
X defoutstab = tmpstab;
X curoutstab = tmpstab;
X stab_io(stabent("stdout",TRUE)) = stab_io(tmpstab);
X
X tmpstab = stabent("STDERR",TRUE);
X stab_io(tmpstab) = stio_new();
X stab_io(tmpstab)->ofp = stab_io(tmpstab)->ifp = stderr;
X stab_io(stabent("stderr",TRUE)) = stab_io(tmpstab);
X
X statname = str_new(0); /* last filename we did stat on */
X
X perldb = FALSE; /* don't try to instrument evals */
X
X if (do_undump)
X abort();
X
X just_doit: /* come here if running an undumped a.out */
X argc--,argv++; /* skip name of script */
X if (doswitches) {
X for (; argc > 0 && **argv == '-'; argc--,argv++) {
X if (argv[0][1] == '-') {
X argc--,argv++;
X break;
X }
X str_numset(stab_val(stabent(argv[0]+1,TRUE)),(double)1.0);
X }
X }
X#ifdef TAINT
X tainted = 1;
X#endif
X if (argvstab = stabent("ARGV",allstabs)) {
X (void)aadd(argvstab);
X for (; argc > 0; argc--,argv++) {
X (void)apush(stab_array(argvstab),str_make(argv[0],0));
X }
X }
X#ifdef TAINT
X (void) stabent("ENV",TRUE); /* must test PATH and IFS */
X#endif
X if (envstab = stabent("ENV",allstabs)) {
X (void)hadd(envstab);
X for (; *env; env++) {
X if (!(s = index(*env,'=')))
X continue;
X *s++ = '\0';
X str = str_make(s--,0);
X str_magic(str, envstab, 'E', *env, s - *env);
X (void)hstore(stab_hash(envstab), *env, s - *env, str, 0);
X *s = '=';
X }
X }
X#ifdef TAINT
X tainted = 0;
X#endif
X if (tmpstab = stabent("$",allstabs))
X str_numset(STAB_STR(tmpstab),(double)getpid());
X
X if (setjmp(top_env)) /* sets goto_targ on longjump */
X loop_ptr = 0; /* start label stack again */
X
X#ifdef DEBUGGING
X if (debug & 1024)
X dump_all();
X if (debug)
X fprintf(stderr,"\nEXECUTING...\n\n");
X#endif
X
X /* do it */
X
X (void) cmd_exec(main_root,G_SCALAR,-1);
X
X if (goto_targ)
X fatal("Can't find label \"%s\"--aborting",goto_targ);
X exit(0);
X /* NOTREACHED */
X}
X
Xmagicalize(list)
Xregister char *list;
X{
X register STAB *stab;
X char sym[2];
X
X sym[1] = '\0';
X while (*sym = *list++) {
X if (stab = stabent(sym,allstabs)) {
X stab_flags(stab) = SF_VMAGIC;
X str_magic(stab_val(stab), stab, 0, Nullch, 0);
X }
X }
X}
X
X/* this routine is in perly.c by virtue of being sort of an alternate main() */
X
Xint
Xdo_eval(str,optype,stash,gimme,arglast)
XSTR *str;
Xint optype;
XHASH *stash;
Xint gimme;
Xint *arglast;
X{
X STR **st = stack->ary_array;
X int retval;
X CMD *myroot;
X ARRAY *ar;
X int i;
X char *oldfile = filename;
X line_t oldline = line;
X int oldtmps_base = tmps_base;
X int oldsave = savestack->ary_fill;
X SPAT *oldspat = curspat;
X static char *last_eval = Nullch;
X static CMD *last_root = Nullcmd;
X int sp = arglast[0];
X
X tmps_base = tmps_max;
X if (curstash != stash) {
X (void)savehptr(&curstash);
X curstash = stash;
X }
X str_set(stab_val(stabent("@",TRUE)),"");
X if (optype != O_DOFILE) { /* normal eval */
X filename = "(eval)";
X line = 1;
X str_sset(linestr,str);
X str_cat(linestr,";"); /* be kind to them */
X }
X else {
X if (last_root) {
X Safefree(last_eval);
X cmd_free(last_root);
X last_root = Nullcmd;
X }
X filename = savestr(str_get(str)); /* can't free this easily */
X str_set(linestr,"");
X rsfp = fopen(filename,"r");
X ar = stab_array(incstab);
X if (!rsfp && *filename != '/') {
X for (i = 0; i <= ar->ary_fill; i++) {
X (void)sprintf(buf,"%s/%s",str_get(afetch(ar,i,TRUE)),filename);
X rsfp = fopen(buf,"r");
X if (rsfp) {
X free(filename);
X filename = savestr(buf);
X break;
X }
X }
X }
X if (!rsfp) {
X filename = oldfile;
X tmps_base = oldtmps_base;
X if (gimme != G_ARRAY)
X st[++sp] = &str_undef;
X return sp;
X }
X line = 0;
X }
X in_eval++;
X oldoldbufptr = oldbufptr = bufptr = str_get(linestr);
X bufend = bufptr + linestr->str_cur;
X if (setjmp(eval_env)) {
X retval = 1;
X last_root = Nullcmd;
X }
X else {
X error_count = 0;
X if (rsfp)
X retval = yyparse();
X else if (last_root && *bufptr == *last_eval && strEQ(bufptr,last_eval)){
X retval = 0;
X eval_root = last_root; /* no point in reparsing */
X }
X else if (in_eval == 1) {
X if (last_root) {
X Safefree(last_eval);
X cmd_free(last_root);
X }
X last_eval = savestr(bufptr);
X last_root = Nullcmd;
X retval = yyparse();
X if (!retval)
X last_root = eval_root;
X }
X else
X retval = yyparse();
X }
X myroot = eval_root; /* in case cmd_exec does another eval! */
X if (retval || error_count) {
X str = &str_undef;
X last_root = Nullcmd; /* can't free on error, for some reason */
X if (rsfp) {
X fclose(rsfp);
X rsfp = 0;
X }
X }
X else {
X sp = cmd_exec(eval_root,gimme,sp);
X st = stack->ary_array;
X for (i = arglast[0] + 1; i <= sp; i++)
X st[i] = str_static(st[i]);
X /* if we don't save result, free zaps it */
X if (in_eval != 1 && myroot != last_root)
X cmd_free(myroot);
X }
X in_eval--;
X filename = oldfile;
X line = oldline;
X tmps_base = oldtmps_base;
X curspat = oldspat;
X if (savestack->ary_fill > oldsave) /* let them use local() */
X restorelist(oldsave);
X return sp;
X}
!STUFFY!FUNK!
echo Extracting lib/termcap.pl
sed >lib/termcap.pl <<'!STUFFY!FUNK!' -e 's/X//'
X;# $Header$
X;#
X;# Usage:
X;# do 'ioctl.pl';
X;# ioctl(TTY,$TIOCGETP,$foo);
X;# ($ispeed,$ospeed) = unpack('cc',$foo);
X;# do 'termcap.pl';
X;# do Tgetent('vt100'); # sets $TC{'cm'}, etc.
X;# do Tgoto($TC{'cm'},$row,$col);
X;# do Tputs($TC{'dl'},$affcnt,'FILEHANDLE');
X;#
Xsub Tgetent {
X local($TERM) = @_;
X local($TERMCAP,$_,$entry,$loop,$field);
X
X warn "Tgetent: no ospeed set" unless $ospeed;
X foreach $key (keys(TC)) {
X delete $TC{$key};
X }
X $TERM = $ENV{'TERM'} unless $TERM;
X $TERMCAP = $ENV{'TERMCAP'};
X $TERMCAP = '/etc/termcap' unless $TERMCAP;
X if ($TERMCAP !~ m:^/:) {
X if (index($TERMCAP,"|$TERM|") < $[) {
X $TERMCAP = '/etc/termcap';
X }
X }
X if ($TERMCAP =~ m:^/:) {
X $entry = '';
X do {
X $loop = "
X open(TERMCAP,'<$TERMCAP') || die \"Can't open $TERMCAP\";
X while (<TERMCAP>) {
X next if /^#/;
X next if /^\t/;
X if (/\\|$TERM[:\\|]/) {
X chop;
X while (chop eq '\\\\') {
X \$_ .= <TERMCAP>;
X chop;
X }
X \$_ .= ':';
X last;
X }
X }
X close TERMCAP;
X \$entry .= \$_;
X ";
X eval $loop;
X } while s/:tc=([^:]+):/:/, $TERM = $1;
X $TERMCAP = $entry;
X }
X
X foreach $field (split(/:[\s:\\]*/,$TERMCAP)) {
X if ($field =~ /^\w\w$/) {
X $TC{$field} = 1;
X }
X elsif ($field =~ /^(\w\w)#(.*)/) {
X $TC{$1} = $2 if $TC{$1} eq '';
X }
X elsif ($field =~ /^(\w\w)=(.*)/) {
X $entry = $1;
X $_ = $2;
X s/\\E/\033/g;
X s/\\(\d\d\d)/pack('c',$1 & 0177)/eg;
X s/\\n/\n/g;
X s/\\r/\r/g;
X s/\\t/\t/g;
X s/\\b/\b/g;
X s/\\f/\f/g;
X s/\\\^/\377/g;
X s/\^\?/\177/g;
X s/\^(.)/pack('c',$1 & 031)/eg;
X s/\\(.)/$1/g;
X s/\377/^/g;
X $TC{$entry} = $_ if $TC{$entry} eq '';
X }
X }
X $TC{'pc'} = "\0" if $TC{'pc'} eq '';
X $TC{'bc'} = "\b" if $TC{'bc'} eq '';
X}
X
X at Tputs = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2);
X
Xsub Tputs {
X local($string,$affcnt,$FH) = @_;
X local($ms);
X if ($string =~ /(^[\d.]+)(\*?)(.*)$/) {
X $ms = $1;
X $ms *= $affcnt if $2;
X $string = $3;
X $decr = $Tputs[$ospeed];
X if ($decr > .1) {
X $ms += $decr / 2;
X $string .= $TC{'pc'} x ($ms / $decr);
X }
X }
X print $FH $string if $FH;
X $string;
X}
X
Xsub Tgoto {
X local($string) = shift(@_);
X local($result) = '';
X local($after) = '';
X local($code,$tmp) = @_;
X @_ = ($tmp,$code);
X local($online) = 0;
X while ($string =~ /^([^%]*)%(.)(.*)/) {
X $result .= $1;
X $code = $2;
X $string = $3;
X if ($code eq 'd') {
X $result .= sprintf("%d",shift(@_));
X }
X elsif ($code eq '.') {
X $tmp = shift(@_);
X if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
X if ($online) {
X ++$tmp, $after .= $TC{'up'} if $TC{'up'};
X }
X else {
X ++$tmp, $after .= $TC{'bc'};
X }
X }
X $result .= sprintf("%c",$tmp);
X $online = !$online;
X }
X elsif ($code eq '+') {
X $result .= sprintf("%c",shift(@_)+ord($string));
X $string = substr($string,1,99);
X $online = !$online;
X }
X elsif ($code eq 'r') {
X ($code,$tmp) = @_;
X @_ = ($tmp,$code);
X $online = !$online;
X }
X elsif ($code eq '>') {
X ($code,$tmp,$string) = unpack("CCa99",$string);
X if ($_[$[] > $code) {
X $_[$[] += $tmp;
X }
X }
X elsif ($code eq '2') {
X $result .= sprintf("%02d",shift(@_));
X $online = !$online;
X }
X elsif ($code eq '3') {
X $result .= sprintf("%03d",shift(@_));
X $online = !$online;
X }
X elsif ($code eq 'i') {
X ($code,$tmp) = @_;
X @_ = ($code+1,$tmp+1);
X }
X else {
X return "OOPS";
X }
X }
X $result . $string . $after;
X}
X
X1;
!STUFFY!FUNK!
echo ""
echo "End of kit 16 (of 23)"
cat /dev/null >kit16isdone
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