lwall@netlabs.com (Larry Wall) (04/15/91)
Submitted-by: Larry Wall <lwall@netlabs.com>
Posting-number: Volume 18, Issue 24
Archive-name: perl/part06
[There are 36 kits for perl version 4.0.]
#! /bin/sh
# Make a new directory for the perl sources, cd to it, and run kits 1
# thru 36 through sh. When all 36 kits have been run, read README.
echo "This is perl 4.0 kit 6 (of 36). If kit 6 is complete, the line"
echo '"'"End of kit 6 (of 36)"'" will echo at the end.'
echo ""
export PATH || (echo "You didn't use sh, you clunch." ; kill $$)
mkdir 2>/dev/null
echo Extracting eval.c:AA
sed >eval.c:AA <<'!STUFFY!FUNK!' -e 's/X//'
X/* $RCSfile: eval.c,v $$Revision: 4.0.1.1 $$Date: 91/04/11 17:43:48 $
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: eval.c,v $
X * Revision 4.0.1.1 91/04/11 17:43:48 lwall
X * patch1: fixed failed fork to return undef as documented
X * patch1: reduced maximum branch distance in eval.c
X *
X * Revision 4.0 91/03/20 01:16:48 lwall
X * 4.0 baseline.
X *
X */
X
X#include "EXTERN.h"
X#include "perl.h"
X
X#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
X#include <signal.h>
X#endif
X
X#ifdef I_FCNTL
X#include <fcntl.h>
X#endif
X#ifdef I_SYS_FILE
X#include <sys/file.h>
X#endif
X#ifdef I_VFORK
X# include <vfork.h>
X#endif
X
X#ifdef VOIDSIG
Xstatic void (*ihand)();
Xstatic void (*qhand)();
X#else
Xstatic int (*ihand)();
Xstatic int (*qhand)();
X#endif
X
XARG *debarg;
XSTR str_args;
Xstatic STAB *stab2;
Xstatic STIO *stio;
Xstatic struct lstring *lstr;
Xstatic int old_rschar;
Xstatic int old_rslen;
X
Xdouble sin(), cos(), atan2(), pow();
X
Xchar *getlogin();
X
Xint
Xeval(arg,gimme,sp)
Xregister ARG *arg;
Xint gimme;
Xregister int sp;
X{
X register STR *str;
X register int anum;
X register int optype;
X register STR **st;
X int maxarg;
X double value;
X register char *tmps;
X char *tmps2;
X int argflags;
X int argtype;
X union argptr argptr;
X int arglast[8]; /* highest sp for arg--valid only for non-O_LIST args */
X unsigned long tmplong;
X long when;
X FILE *fp;
X STR *tmpstr;
X FCMD *form;
X STAB *stab;
X ARRAY *ary;
X bool assigning = FALSE;
X double exp(), log(), sqrt(), modf();
X char *crypt(), *getenv();
X extern void grow_dlevel();
X
X if (!arg)
X goto say_undef;
X optype = arg->arg_type;
X maxarg = arg->arg_len;
X arglast[0] = sp;
X str = arg->arg_ptr.arg_str;
X if (sp + maxarg > stack->ary_max)
X astore(stack, sp + maxarg, Nullstr);
X st = stack->ary_array;
X
X#ifdef DEBUGGING
X if (debug) {
X if (debug & 8) {
X deb("%s (%lx) %d args:\n",opname[optype],arg,maxarg);
X }
X debname[dlevel] = opname[optype][0];
X debdelim[dlevel] = ':';
X if (++dlevel >= dlmax)
X grow_dlevel();
X }
X#endif
X
X for (anum = 1; anum <= maxarg; anum++) {
X argflags = arg[anum].arg_flags;
X argtype = arg[anum].arg_type;
X argptr = arg[anum].arg_ptr;
X re_eval:
X switch (argtype) {
X default:
X st[++sp] = &str_undef;
X#ifdef DEBUGGING
X tmps = "NULL";
X#endif
X break;
X case A_EXPR:
X#ifdef DEBUGGING
X if (debug & 8) {
X tmps = "EXPR";
X deb("%d.EXPR =>\n",anum);
X }
X#endif
X sp = eval(argptr.arg_arg,
X (argflags & AF_ARYOK) ? G_ARRAY : G_SCALAR, sp);
X if (sp + (maxarg - anum) > stack->ary_max)
X astore(stack, sp + (maxarg - anum), Nullstr);
X st = stack->ary_array; /* possibly reallocated */
X break;
X case A_CMD:
X#ifdef DEBUGGING
X if (debug & 8) {
X tmps = "CMD";
X deb("%d.CMD (%lx) =>\n",anum,argptr.arg_cmd);
X }
X#endif
X sp = cmd_exec(argptr.arg_cmd, gimme, sp);
X if (sp + (maxarg - anum) > stack->ary_max)
X astore(stack, sp + (maxarg - anum), Nullstr);
X st = stack->ary_array; /* possibly reallocated */
X break;
X case A_LARYSTAB:
X ++sp;
X switch (optype) {
X case O_ITEM2: argtype = 2; break;
X case O_ITEM3: argtype = 3; break;
X default: argtype = anum; break;
X }
X str = afetch(stab_array(argptr.arg_stab),
X arg[argtype].arg_len - arybase, TRUE);
X#ifdef DEBUGGING
X if (debug & 8) {
X (void)sprintf(buf,"LARYSTAB $%s[%d]",stab_name(argptr.arg_stab),
X arg[argtype].arg_len);
X tmps = buf;
X }
X#endif
X goto do_crement;
X case A_ARYSTAB:
X switch (optype) {
X case O_ITEM2: argtype = 2; break;
X case O_ITEM3: argtype = 3; break;
X default: argtype = anum; break;
X }
X st[++sp] = afetch(stab_array(argptr.arg_stab),
X arg[argtype].arg_len - arybase, FALSE);
X#ifdef DEBUGGING
X if (debug & 8) {
X (void)sprintf(buf,"ARYSTAB $%s[%d]",stab_name(argptr.arg_stab),
X arg[argtype].arg_len);
X tmps = buf;
X }
X#endif
X break;
X case A_STAR:
X stab = argptr.arg_stab;
X st[++sp] = (STR*)stab;
X if (!stab_xarray(stab))
X aadd(stab);
X if (!stab_xhash(stab))
X hadd(stab);
X if (!stab_io(stab))
X stab_io(stab) = stio_new();
X#ifdef DEBUGGING
X if (debug & 8) {
X (void)sprintf(buf,"STAR *%s",stab_name(argptr.arg_stab));
X tmps = buf;
X }
X#endif
X break;
X case A_LSTAR:
X str = st[++sp] = (STR*)argptr.arg_stab;
X#ifdef DEBUGGING
X if (debug & 8) {
X (void)sprintf(buf,"LSTAR *%s",stab_name(argptr.arg_stab));
X tmps = buf;
X }
X#endif
X break;
X case A_STAB:
X st[++sp] = STAB_STR(argptr.arg_stab);
X#ifdef DEBUGGING
X if (debug & 8) {
X (void)sprintf(buf,"STAB $%s",stab_name(argptr.arg_stab));
X tmps = buf;
X }
X#endif
X break;
X case A_LEXPR:
X#ifdef DEBUGGING
X if (debug & 8) {
X tmps = "LEXPR";
X deb("%d.LEXPR =>\n",anum);
X }
X#endif
X if (argflags & AF_ARYOK) {
X sp = eval(argptr.arg_arg, G_ARRAY, sp);
X if (sp + (maxarg - anum) > stack->ary_max)
X astore(stack, sp + (maxarg - anum), Nullstr);
X st = stack->ary_array; /* possibly reallocated */
X }
X else {
X sp = eval(argptr.arg_arg, G_SCALAR, sp);
X st = stack->ary_array; /* possibly reallocated */
X str = st[sp];
X goto do_crement;
X }
X break;
X case A_LVAL:
X#ifdef DEBUGGING
X if (debug & 8) {
X (void)sprintf(buf,"LVAL $%s",stab_name(argptr.arg_stab));
X tmps = buf;
X }
X#endif
X ++sp;
X str = STAB_STR(argptr.arg_stab);
X if (!str)
X fatal("panic: A_LVAL");
X do_crement:
X assigning = TRUE;
X if (argflags & AF_PRE) {
X if (argflags & AF_UP)
X str_inc(str);
X else
X str_dec(str);
X STABSET(str);
X st[sp] = str;
X str = arg->arg_ptr.arg_str;
X }
X else if (argflags & AF_POST) {
X st[sp] = str_mortal(str);
X if (argflags & AF_UP)
X str_inc(str);
X else
X str_dec(str);
X STABSET(str);
X str = arg->arg_ptr.arg_str;
X }
X else
X st[sp] = str;
X break;
X case A_LARYLEN:
X ++sp;
X stab = argptr.arg_stab;
X str = stab_array(argptr.arg_stab)->ary_magic;
X if (optype != O_SASSIGN || argflags & (AF_PRE|AF_POST))
X str_numset(str,(double)(stab_array(stab)->ary_fill+arybase));
X#ifdef DEBUGGING
X tmps = "LARYLEN";
X#endif
X if (!str)
X fatal("panic: A_LEXPR");
X goto do_crement;
X case A_ARYLEN:
X stab = argptr.arg_stab;
X st[++sp] = stab_array(stab)->ary_magic;
X str_numset(st[sp],(double)(stab_array(stab)->ary_fill+arybase));
X#ifdef DEBUGGING
X tmps = "ARYLEN";
X#endif
X break;
X case A_SINGLE:
X st[++sp] = argptr.arg_str;
X#ifdef DEBUGGING
X tmps = "SINGLE";
X#endif
X break;
X case A_DOUBLE:
X (void) interp(str,argptr.arg_str,sp);
X st = stack->ary_array;
X st[++sp] = str;
X#ifdef DEBUGGING
X tmps = "DOUBLE";
X#endif
X break;
X case A_BACKTICK:
X tmps = str_get(interp(str,argptr.arg_str,sp));
X st = stack->ary_array;
X#ifdef TAINT
X taintproper("Insecure dependency in ``");
X#endif
X fp = mypopen(tmps,"r");
X str_set(str,"");
X if (fp) {
X if (gimme == G_SCALAR) {
X while (str_gets(str,fp,str->str_cur) != Nullch)
X ;
X }
X else {
X for (;;) {
X if (++sp > stack->ary_max) {
X astore(stack, sp, Nullstr);
X st = stack->ary_array;
X }
X str = st[sp] = Str_new(56,80);
X if (str_gets(str,fp,0) == Nullch) {
X sp--;
X break;
X }
X if (str->str_len - str->str_cur > 20) {
X str->str_len = str->str_cur+1;
X Renew(str->str_ptr, str->str_len, char);
X }
X str_2mortal(str);
X }
X }
X statusvalue = mypclose(fp);
X }
X else
X statusvalue = -1;
X
X if (gimme == G_SCALAR)
X st[++sp] = str;
X#ifdef DEBUGGING
X tmps = "BACK";
X#endif
X break;
X case A_WANTARRAY:
X {
X if (curcsv->wantarray == G_ARRAY)
X st[++sp] = &str_yes;
X else
X st[++sp] = &str_no;
X }
X#ifdef DEBUGGING
X tmps = "WANTARRAY";
X#endif
X break;
X case A_INDREAD:
X last_in_stab = stabent(str_get(STAB_STR(argptr.arg_stab)),TRUE);
X old_rschar = rschar;
X old_rslen = rslen;
X goto do_read;
X case A_GLOB:
X argflags |= AF_POST; /* enable newline chopping */
X last_in_stab = argptr.arg_stab;
X old_rschar = rschar;
X old_rslen = rslen;
X rslen = 1;
X#ifdef MSDOS
X rschar = 0;
X#else
X#ifdef CSH
X rschar = 0;
X#else
X rschar = '\n';
X#endif /* !CSH */
X#endif /* !MSDOS */
X goto do_read;
X case A_READ:
X last_in_stab = argptr.arg_stab;
X old_rschar = rschar;
X old_rslen = rslen;
X do_read:
X if (anum > 1) /* assign to scalar */
X gimme = G_SCALAR; /* force context to scalar */
X if (gimme == G_ARRAY)
X str = Str_new(57,0);
X ++sp;
X fp = Nullfp;
X if (stab_io(last_in_stab)) {
X fp = stab_io(last_in_stab)->ifp;
X if (!fp) {
X if (stab_io(last_in_stab)->flags & IOF_ARGV) {
X if (stab_io(last_in_stab)->flags & IOF_START) {
X stab_io(last_in_stab)->flags &= ~IOF_START;
X stab_io(last_in_stab)->lines = 0;
X if (alen(stab_array(last_in_stab)) < 0) {
X tmpstr = str_make("-",1); /* assume stdin */
X (void)apush(stab_array(last_in_stab), tmpstr);
X }
X }
X fp = nextargv(last_in_stab);
X if (!fp) { /* Note: fp != stab_io(last_in_stab)->ifp */
X (void)do_close(last_in_stab,FALSE); /* now it does*/
X stab_io(last_in_stab)->flags |= IOF_START;
X }
X }
X else if (argtype == A_GLOB) {
X (void) interp(str,stab_val(last_in_stab),sp);
X st = stack->ary_array;
X tmpstr = Str_new(55,0);
X#ifdef MSDOS
X str_set(tmpstr, "perlglob ");
X str_scat(tmpstr,str);
X str_cat(tmpstr," |");
X#else
X#ifdef CSH
X str_nset(tmpstr,cshname,cshlen);
X str_cat(tmpstr," -cf 'set nonomatch; glob ");
X str_scat(tmpstr,str);
X str_cat(tmpstr,"'|");
X#else
X str_set(tmpstr, "echo ");
X str_scat(tmpstr,str);
X str_cat(tmpstr,
X "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
X#endif /* !CSH */
X#endif /* !MSDOS */
X (void)do_open(last_in_stab,tmpstr->str_ptr,
X tmpstr->str_cur);
X fp = stab_io(last_in_stab)->ifp;
X str_free(tmpstr);
X }
X }
X }
X if (!fp && dowarn)
X warn("Read on closed filehandle <%s>",stab_name(last_in_stab));
X when = str->str_len; /* remember if already alloced */
X if (!when)
X Str_Grow(str,80); /* try short-buffering it */
X keepgoing:
X if (!fp)
X st[sp] = &str_undef;
X else if (!str_gets(str,fp, optype == O_RCAT ? str->str_cur : 0)) {
X clearerr(fp);
X if (stab_io(last_in_stab)->flags & IOF_ARGV) {
X fp = nextargv(last_in_stab);
X if (fp)
X goto keepgoing;
X (void)do_close(last_in_stab,FALSE);
X stab_io(last_in_stab)->flags |= IOF_START;
X }
X else if (argflags & AF_POST) {
X (void)do_close(last_in_stab,FALSE);
X }
X st[sp] = &str_undef;
X rschar = old_rschar;
X rslen = old_rslen;
X if (gimme == G_ARRAY) {
X --sp;
X str_2mortal(str);
X goto array_return;
X }
X break;
X }
X else {
X stab_io(last_in_stab)->lines++;
X st[sp] = str;
X#ifdef TAINT
X str->str_tainted = 1; /* Anything from the outside world...*/
X#endif
X if (argflags & AF_POST) {
X if (str->str_cur > 0)
X str->str_cur--;
X if (str->str_ptr[str->str_cur] == rschar)
X str->str_ptr[str->str_cur] = '\0';
X else
X str->str_cur++;
X for (tmps = str->str_ptr; *tmps; tmps++)
X if (!isalpha(*tmps) && !isdigit(*tmps) &&
X index("$&*(){}[]'\";\\|?<>~`",*tmps))
X break;
X if (*tmps && stat(str->str_ptr,&statbuf) < 0)
X goto keepgoing; /* unmatched wildcard? */
X }
X if (gimme == G_ARRAY) {
X if (str->str_len - str->str_cur > 20) {
X str->str_len = str->str_cur+1;
X Renew(str->str_ptr, str->str_len, char);
X }
X str_2mortal(str);
X if (++sp > stack->ary_max) {
X astore(stack, sp, Nullstr);
X st = stack->ary_array;
X }
X str = Str_new(58,80);
X goto keepgoing;
X }
X else if (!when && str->str_len - str->str_cur > 80) {
X /* try to reclaim a bit of scalar space on 1st alloc */
X if (str->str_cur < 60)
X str->str_len = 80;
X else
X str->str_len = str->str_cur+40; /* allow some slop */
X Renew(str->str_ptr, str->str_len, char);
X }
X }
X rschar = old_rschar;
X rslen = old_rslen;
X#ifdef DEBUGGING
X tmps = "READ";
X#endif
X break;
X }
X#ifdef DEBUGGING
X if (debug & 8)
X deb("%d.%s = '%s'\n",anum,tmps,str_peek(st[sp]));
X#endif
X if (anum < 8)
X arglast[anum] = sp;
X }
X
X st += arglast[0];
X#ifdef SMALLSWITCHES
X if (optype < O_CHOWN)
X#endif
X switch (optype) {
X case O_RCAT:
X STABSET(str);
X break;
X case O_ITEM:
X if (gimme == G_ARRAY)
X goto array_return;
X /* FALL THROUGH */
X case O_SCALAR:
X STR_SSET(str,st[1]);
X STABSET(str);
X break;
X case O_ITEM2:
X if (gimme == G_ARRAY)
X goto array_return;
X --anum;
X STR_SSET(str,st[arglast[anum]-arglast[0]]);
X STABSET(str);
X break;
X case O_ITEM3:
X if (gimme == G_ARRAY)
X goto array_return;
X --anum;
X STR_SSET(str,st[arglast[anum]-arglast[0]]);
X STABSET(str);
X break;
X case O_CONCAT:
X STR_SSET(str,st[1]);
X str_scat(str,st[2]);
X STABSET(str);
X break;
X case O_REPEAT:
X if (gimme == G_ARRAY && arg[1].arg_flags & AF_ARYOK) {
X sp = do_repeatary(arglast);
X goto array_return;
X }
X STR_SSET(str,st[arglast[1] - arglast[0]]);
X anum = (int)str_gnum(st[arglast[2] - arglast[0]]);
X if (anum >= 1) {
X tmpstr = Str_new(50, 0);
X tmps = str_get(str);
X str_nset(tmpstr,tmps,str->str_cur);
X tmps = str_get(tmpstr); /* force to be string */
X STR_GROW(str, (anum * str->str_cur) + 1);
X repeatcpy(str->str_ptr, tmps, tmpstr->str_cur, anum);
X str->str_cur *= anum;
X str->str_ptr[str->str_cur] = '\0';
X str->str_nok = 0;
X str_free(tmpstr);
X }
X else
X str_sset(str,&str_no);
X STABSET(str);
X break;
X case O_MATCH:
X sp = do_match(str,arg,
X gimme,arglast);
X if (gimme == G_ARRAY)
X goto array_return;
X STABSET(str);
X break;
X case O_NMATCH:
X sp = do_match(str,arg,
X G_SCALAR,arglast);
X str_sset(str, str_true(str) ? &str_no : &str_yes);
X STABSET(str);
X break;
X case O_SUBST:
X sp = do_subst(str,arg,arglast[0]);
X goto array_return;
X case O_NSUBST:
X sp = do_subst(str,arg,arglast[0]);
X str = arg->arg_ptr.arg_str;
X str_set(str, str_true(str) ? No : Yes);
X goto array_return;
X case O_ASSIGN:
X if (arg[1].arg_flags & AF_ARYOK) {
X if (arg->arg_len == 1) {
X arg->arg_type = O_LOCAL;
X goto local;
X }
X else {
X arg->arg_type = O_AASSIGN;
X goto aassign;
X }
X }
X else {
X arg->arg_type = O_SASSIGN;
X goto sassign;
X }
X case O_LOCAL:
X local:
X arglast[2] = arglast[1]; /* push a null array */
X /* FALL THROUGH */
X case O_AASSIGN:
X aassign:
X sp = do_assign(arg,
X gimme,arglast);
X goto array_return;
X case O_SASSIGN:
X sassign:
X STR_SSET(str, st[2]);
X STABSET(str);
X break;
X case O_CHOP:
X st -= arglast[0];
X str = arg->arg_ptr.arg_str;
X for (sp = arglast[0] + 1; sp <= arglast[1]; sp++)
X do_chop(str,st[sp]);
X st += arglast[0];
X break;
X case O_DEFINED:
X if (arg[1].arg_type & A_DONT) {
X sp = do_defined(str,arg,
X gimme,arglast);
X goto array_return;
X }
X else if (str->str_pok || str->str_nok)
X goto say_yes;
X goto say_no;
X case O_UNDEF:
X if (arg[1].arg_type & A_DONT) {
X sp = do_undef(str,arg,
X gimme,arglast);
X goto array_return;
X }
X else if (str != stab_val(defstab)) {
X if (str->str_len) {
X if (str->str_state == SS_INCR)
X Str_Grow(str,0);
X Safefree(str->str_ptr);
X str->str_ptr = Nullch;
X str->str_len = 0;
X }
X str->str_pok = str->str_nok = 0;
X STABSET(str);
X }
X goto say_undef;
X case O_STUDY:
X sp = do_study(str,arg,
X gimme,arglast);
X goto array_return;
X case O_POW:
X value = str_gnum(st[1]);
X value = pow(value,str_gnum(st[2]));
X goto donumset;
X case O_MULTIPLY:
X value = str_gnum(st[1]);
X value *= str_gnum(st[2]);
X goto donumset;
X case O_DIVIDE:
X if ((value = str_gnum(st[2])) == 0.0)
X fatal("Illegal division by zero");
X#ifdef cray
X /* insure that 20./5. == 4. */
X {
X double x;
X int k;
X x = str_gnum(st[1]);
X if ((double)(int)x == x &&
X (double)(int)value == value &&
X (k = (int)x/(int)value)*(int)value == (int)x) {
X value = k;
X } else {
X value = x/value;
X }
X }
X#else
X value = str_gnum(st[1]) / value;
X#endif
X goto donumset;
X case O_MODULO:
X tmplong = (long) str_gnum(st[2]);
X if (tmplong == 0L)
X fatal("Illegal modulus zero");
X when = (long)str_gnum(st[1]);
X#ifndef lint
X if (when >= 0)
X value = (double)(when % tmplong);
X else
X value = (double)(tmplong - ((-when - 1) % tmplong)) - 1;
X#endif
X goto donumset;
X case O_ADD:
X value = str_gnum(st[1]);
X value += str_gnum(st[2]);
X goto donumset;
X case O_SUBTRACT:
X value = str_gnum(st[1]);
X value -= str_gnum(st[2]);
X goto donumset;
X case O_LEFT_SHIFT:
X value = str_gnum(st[1]);
X anum = (int)str_gnum(st[2]);
X#ifndef lint
X value = (double)(U_L(value) << anum);
X#endif
X goto donumset;
X case O_RIGHT_SHIFT:
X value = str_gnum(st[1]);
X anum = (int)str_gnum(st[2]);
X#ifndef lint
X value = (double)(U_L(value) >> anum);
X#endif
X goto donumset;
X case O_LT:
X value = str_gnum(st[1]);
X value = (value < str_gnum(st[2])) ? 1.0 : 0.0;
X goto donumset;
X case O_GT:
X value = str_gnum(st[1]);
X value = (value > str_gnum(st[2])) ? 1.0 : 0.0;
X goto donumset;
X case O_LE:
X value = str_gnum(st[1]);
X value = (value <= str_gnum(st[2])) ? 1.0 : 0.0;
X goto donumset;
X case O_GE:
X value = str_gnum(st[1]);
X value = (value >= str_gnum(st[2])) ? 1.0 : 0.0;
X goto donumset;
X case O_EQ:
X if (dowarn) {
X if ((!st[1]->str_nok && !looks_like_number(st[1])) ||
X (!st[2]->str_nok && !looks_like_number(st[2])) )
X warn("Possible use of == on string value");
X }
X value = str_gnum(st[1]);
X value = (value == str_gnum(st[2])) ? 1.0 : 0.0;
X goto donumset;
X case O_NE:
X value = str_gnum(st[1]);
X value = (value != str_gnum(st[2])) ? 1.0 : 0.0;
X goto donumset;
X case O_NCMP:
X value = str_gnum(st[1]);
X value -= str_gnum(st[2]);
X if (value > 0.0)
X value = 1.0;
X else if (value < 0.0)
X value = -1.0;
X goto donumset;
X case O_BIT_AND:
X if (!sawvec || st[1]->str_nok || st[2]->str_nok) {
X value = str_gnum(st[1]);
X#ifndef lint
X value = (double)(U_L(value) & U_L(str_gnum(st[2])));
X#endif
X goto donumset;
X }
X else
X do_vop(optype,str,st[1],st[2]);
X break;
X case O_XOR:
X if (!sawvec || st[1]->str_nok || st[2]->str_nok) {
X value = str_gnum(st[1]);
X#ifndef lint
X value = (double)(U_L(value) ^ U_L(str_gnum(st[2])));
X#endif
X goto donumset;
X }
X else
X do_vop(optype,str,st[1],st[2]);
X break;
X case O_BIT_OR:
X if (!sawvec || st[1]->str_nok || st[2]->str_nok) {
X value = str_gnum(st[1]);
X#ifndef lint
X value = (double)(U_L(value) | U_L(str_gnum(st[2])));
X#endif
X goto donumset;
X }
X else
X do_vop(optype,str,st[1],st[2]);
X break;
X/* use register in evaluating str_true() */
X case O_AND:
X if (str_true(st[1])) {
X anum = 2;
X optype = O_ITEM2;
X argflags = arg[anum].arg_flags;
X if (gimme == G_ARRAY)
X argflags |= AF_ARYOK;
X argtype = arg[anum].arg_type & A_MASK;
X argptr = arg[anum].arg_ptr;
X maxarg = anum = 1;
X sp = arglast[0];
X st -= sp;
X goto re_eval;
X }
X else {
X if (assigning) {
X str_sset(str, st[1]);
X STABSET(str);
X }
X else
X str = st[1];
X break;
X }
X case O_OR:
X if (str_true(st[1])) {
X if (assigning) {
X str_sset(str, st[1]);
X STABSET(str);
X }
X else
X str = st[1];
X break;
X }
X else {
X anum = 2;
X optype = O_ITEM2;
X argflags = arg[anum].arg_flags;
X if (gimme == G_ARRAY)
X argflags |= AF_ARYOK;
X argtype = arg[anum].arg_type & A_MASK;
X argptr = arg[anum].arg_ptr;
X maxarg = anum = 1;
X sp = arglast[0];
X st -= sp;
X goto re_eval;
X }
X case O_COND_EXPR:
X anum = (str_true(st[1]) ? 2 : 3);
X optype = (anum == 2 ? O_ITEM2 : O_ITEM3);
X argflags = arg[anum].arg_flags;
X if (gimme == G_ARRAY)
X argflags |= AF_ARYOK;
X argtype = arg[anum].arg_type & A_MASK;
X argptr = arg[anum].arg_ptr;
X maxarg = anum = 1;
X sp = arglast[0];
X st -= sp;
X goto re_eval;
X case O_COMMA:
X if (gimme == G_ARRAY)
X goto array_return;
X str = st[2];
X break;
X case O_NEGATE:
X value = -str_gnum(st[1]);
X goto donumset;
X case O_NOT:
X value = (double) !str_true(st[1]);
X goto donumset;
X case O_COMPLEMENT:
X if (!sawvec || st[1]->str_nok) {
X#ifndef lint
X value = (double) ~U_L(str_gnum(st[1]));
X#endif
X goto donumset;
X }
X else {
X STR_SSET(str,st[1]);
X tmps = str_get(str);
X for (anum = str->str_cur; anum; anum--, tmps++)
X *tmps = ~*tmps;
X }
X break;
X case O_SELECT:
X stab_fullname(str,defoutstab);
X if (maxarg > 0) {
X if ((arg[1].arg_type & A_MASK) == A_WORD)
X defoutstab = arg[1].arg_ptr.arg_stab;
X else
X defoutstab = stabent(str_get(st[1]),TRUE);
X if (!stab_io(defoutstab))
X stab_io(defoutstab) = stio_new();
X curoutstab = defoutstab;
X }
X STABSET(str);
X break;
X case O_WRITE:
X if (maxarg == 0)
X stab = defoutstab;
X else if ((arg[1].arg_type & A_MASK) == A_WORD) {
X if (!(stab = arg[1].arg_ptr.arg_stab))
X stab = defoutstab;
X }
X else
X stab = stabent(str_get(st[1]),TRUE);
X if (!stab_io(stab)) {
X str_set(str, No);
X STABSET(str);
X break;
X }
X curoutstab = stab;
X fp = stab_io(stab)->ofp;
X debarg = arg;
X if (stab_io(stab)->fmt_stab)
X form = stab_form(stab_io(stab)->fmt_stab);
X else
X form = stab_form(stab);
X if (!form || !fp) {
X if (dowarn) {
X if (form)
X warn("No format for filehandle");
X else {
X if (stab_io(stab)->ifp)
X warn("Filehandle only opened for input");
X else
X warn("Write on closed filehandle");
X }
X }
X str_set(str, No);
X STABSET(str);
X break;
X }
X format(&outrec,form,sp);
X do_write(&outrec,stab_io(stab),sp);
X if (stab_io(stab)->flags & IOF_FLUSH)
X (void)fflush(fp);
X str_set(str, Yes);
X STABSET(str);
X break;
X case O_DBMOPEN:
X#ifdef SOME_DBM
X anum = arg[1].arg_type & A_MASK;
X if (anum == A_WORD || anum == A_STAB)
X stab = arg[1].arg_ptr.arg_stab;
X else
X stab = stabent(str_get(st[1]),TRUE);
X if (st[3]->str_nok || st[3]->str_pok)
X anum = (int)str_gnum(st[3]);
X else
X anum = -1;
X value = (double)hdbmopen(stab_hash(stab),str_get(st[2]),anum);
X goto donumset;
X#else
X fatal("No dbm or ndbm on this machine");
X#endif
X case O_DBMCLOSE:
X#ifdef SOME_DBM
X if ((arg[1].arg_type & A_MASK) == A_WORD)
X stab = arg[1].arg_ptr.arg_stab;
X else
X stab = stabent(str_get(st[1]),TRUE);
X hdbmclose(stab_hash(stab));
X goto say_yes;
X#else
X fatal("No dbm or ndbm on this machine");
X#endif
X case O_OPEN:
X if ((arg[1].arg_type & A_MASK) == A_WORD)
X stab = arg[1].arg_ptr.arg_stab;
X else
X stab = stabent(str_get(st[1]),TRUE);
X tmps = str_get(st[2]);
X if (do_open(stab,tmps,st[2]->str_cur)) {
X value = (double)forkprocess;
X stab_io(stab)->lines = 0;
X goto donumset;
X }
X else if (forkprocess == 0) /* we are a new child */
X goto say_zero;
X else
X goto say_undef;
X /* break; */
X case O_TRANS:
X value = (double) do_trans(str,arg);
X str = arg->arg_ptr.arg_str;
X goto donumset;
X case O_NTRANS:
X str_set(arg->arg_ptr.arg_str, do_trans(str,arg) == 0 ? Yes : No);
X str = arg->arg_ptr.arg_str;
X break;
X case O_CLOSE:
X if (maxarg == 0)
X stab = defoutstab;
X else if ((arg[1].arg_type & A_MASK) == A_WORD)
X stab = arg[1].arg_ptr.arg_stab;
X else
X stab = stabent(str_get(st[1]),TRUE);
X str_set(str, do_close(stab,TRUE) ? Yes : No );
X STABSET(str);
X break;
X case O_EACH:
X sp = do_each(str,stab_hash(arg[1].arg_ptr.arg_stab),
X gimme,arglast);
X goto array_return;
X case O_VALUES:
X case O_KEYS:
X sp = do_kv(str,stab_hash(arg[1].arg_ptr.arg_stab), optype,
X gimme,arglast);
X goto array_return;
X case O_LARRAY:
X str->str_nok = str->str_pok = 0;
X str->str_u.str_stab = arg[1].arg_ptr.arg_stab;
X str->str_state = SS_ARY;
X break;
X case O_ARRAY:
X ary = stab_array(arg[1].arg_ptr.arg_stab);
X maxarg = ary->ary_fill + 1;
X if (gimme == G_ARRAY) { /* array wanted */
X sp = arglast[0];
X st -= sp;
X if (maxarg > 0 && sp + maxarg > stack->ary_max) {
X astore(stack,sp + maxarg, Nullstr);
X st = stack->ary_array;
X }
X st += sp;
X Copy(ary->ary_array, &st[1], maxarg, STR*);
X sp += maxarg;
X goto array_return;
X }
X else {
X value = (double)maxarg;
X goto donumset;
X }
X case O_AELEM:
X anum = ((int)str_gnum(st[2])) - arybase;
X str = afetch(stab_array(arg[1].arg_ptr.arg_stab),anum,FALSE);
X break;
X case O_DELETE:
X tmpstab = arg[1].arg_ptr.arg_stab;
X tmps = str_get(st[2]);
X str = hdelete(stab_hash(tmpstab),tmps,st[2]->str_cur);
X if (tmpstab == envstab)
X setenv(tmps,Nullch);
X if (!str)
X goto say_undef;
X break;
X case O_LHASH:
X str->str_nok = str->str_pok = 0;
X str->str_u.str_stab = arg[1].arg_ptr.arg_stab;
X str->str_state = SS_HASH;
X break;
X case O_HASH:
X if (gimme == G_ARRAY) { /* array wanted */
X sp = do_kv(str,stab_hash(arg[1].arg_ptr.arg_stab), optype,
X gimme,arglast);
X goto array_return;
X }
X else {
X tmpstab = arg[1].arg_ptr.arg_stab;
X if (!stab_hash(tmpstab)->tbl_fill)
X goto say_zero;
X sprintf(buf,"%d/%d",stab_hash(tmpstab)->tbl_fill,
X stab_hash(tmpstab)->tbl_max+1);
X str_set(str,buf);
X }
X break;
X case O_HELEM:
X tmpstab = arg[1].arg_ptr.arg_stab;
X tmps = str_get(st[2]);
X str = hfetch(stab_hash(tmpstab),tmps,st[2]->str_cur,FALSE);
X break;
X case O_LAELEM:
X anum = ((int)str_gnum(st[2])) - arybase;
X str = afetch(stab_array(arg[1].arg_ptr.arg_stab),anum,TRUE);
X if (!str || str == &str_undef)
X fatal("Assignment to non-creatable value, subscript %d",anum);
X break;
X case O_LHELEM:
X tmpstab = arg[1].arg_ptr.arg_stab;
X tmps = str_get(st[2]);
X anum = st[2]->str_cur;
X str = hfetch(stab_hash(tmpstab),tmps,anum,TRUE);
X if (!str || str == &str_undef)
X fatal("Assignment to non-creatable value, subscript \"%s\"",tmps);
X if (tmpstab == envstab) /* heavy wizardry going on here */
X str_magic(str, tmpstab, 'E', tmps, anum); /* str is now magic */
X /* he threw the brick up into the air */
X else if (tmpstab == sigstab)
X str_magic(str, tmpstab, 'S', tmps, anum);
X#ifdef SOME_DBM
X else if (stab_hash(tmpstab)->tbl_dbm)
X str_magic(str, tmpstab, 'D', tmps, anum);
X#endif
X else if (perldb && tmpstab == DBline)
X str_magic(str, tmpstab, 'L', tmps, anum);
X break;
X case O_LSLICE:
X anum = 2;
X argtype = FALSE;
X goto do_slice_already;
X case O_ASLICE:
X anum = 1;
X argtype = FALSE;
X goto do_slice_already;
X case O_HSLICE:
X anum = 0;
X argtype = FALSE;
X goto do_slice_already;
X case O_LASLICE:
X anum = 1;
X argtype = TRUE;
X goto do_slice_already;
X case O_LHSLICE:
X anum = 0;
X argtype = TRUE;
X do_slice_already:
X sp = do_slice(arg[1].arg_ptr.arg_stab,str,anum,argtype,
X gimme,arglast);
X goto array_return;
X case O_SPLICE:
X sp = do_splice(stab_array(arg[1].arg_ptr.arg_stab),gimme,arglast);
X goto array_return;
X case O_PUSH:
X if (arglast[2] - arglast[1] != 1)
X str = do_push(stab_array(arg[1].arg_ptr.arg_stab),arglast);
X else {
X str = Str_new(51,0); /* must copy the STR */
X str_sset(str,st[2]);
X (void)apush(stab_array(arg[1].arg_ptr.arg_stab),str);
X }
X break;
X case O_POP:
X str = apop(ary = stab_array(arg[1].arg_ptr.arg_stab));
X goto staticalization;
X case O_SHIFT:
X str = ashift(ary = stab_array(arg[1].arg_ptr.arg_stab));
X staticalization:
X if (!str)
X goto say_undef;
X if (ary->ary_flags & ARF_REAL)
X (void)str_2mortal(str);
X break;
X case O_UNPACK:
X sp = do_unpack(str,gimme,arglast);
X goto array_return;
X case O_SPLIT:
X value = str_gnum(st[3]);
X sp = do_split(str, arg[2].arg_ptr.arg_spat, (int)value,
X gimme,arglast);
X goto array_return;
X case O_LENGTH:
X if (maxarg < 1)
X value = (double)str_len(stab_val(defstab));
X else
X value = (double)str_len(st[1]);
X goto donumset;
X case O_SPRINTF:
X do_sprintf(str, sp-arglast[0], st+1);
X break;
X case O_SUBSTR:
X anum = ((int)str_gnum(st[2])) - arybase; /* anum=where to start*/
X tmps = str_get(st[1]); /* force conversion to string */
X if (argtype = (str == st[1]))
X str = arg->arg_ptr.arg_str;
X if (anum < 0)
X anum += st[1]->str_cur + arybase;
X if (anum < 0 || anum > st[1]->str_cur)
X str_nset(str,"",0);
X else {
X optype = maxarg < 3 ? st[1]->str_cur : (int)str_gnum(st[3]);
X if (optype < 0)
X optype = 0;
X tmps += anum;
X anum = st[1]->str_cur - anum; /* anum=how many bytes left*/
X if (anum > optype)
X anum = optype;
X str_nset(str, tmps, anum);
X if (argtype) { /* it's an lvalue! */
X lstr = (struct lstring*)str;
X str->str_magic = st[1];
X st[1]->str_rare = 's';
X lstr->lstr_offset = tmps - str_get(st[1]);
X lstr->lstr_len = anum;
X }
X }
X break;
X case O_PACK:
X (void)do_pack(str,arglast);
X break;
X case O_GREP:
X sp = do_grep(arg,str,gimme,arglast);
X goto array_return;
X case O_JOIN:
X do_join(str,arglast);
X break;
X case O_SLT:
X tmps = str_get(st[1]);
X value = (double) (str_cmp(st[1],st[2]) < 0);
X goto donumset;
X case O_SGT:
X tmps = str_get(st[1]);
X value = (double) (str_cmp(st[1],st[2]) > 0);
X goto donumset;
X case O_SLE:
X tmps = str_get(st[1]);
X value = (double) (str_cmp(st[1],st[2]) <= 0);
X goto donumset;
X case O_SGE:
X tmps = str_get(st[1]);
X value = (double) (str_cmp(st[1],st[2]) >= 0);
X goto donumset;
X case O_SEQ:
X tmps = str_get(st[1]);
X value = (double) str_eq(st[1],st[2]);
X goto donumset;
X case O_SNE:
X tmps = str_get(st[1]);
X value = (double) !str_eq(st[1],st[2]);
X goto donumset;
X case O_SCMP:
X tmps = str_get(st[1]);
X value = (double) str_cmp(st[1],st[2]);
X goto donumset;
X case O_SUBR:
X sp = do_subr(arg,gimme,arglast);
X st = stack->ary_array + arglast[0]; /* maybe realloced */
X goto array_return;
X case O_DBSUBR:
X sp = do_subr(arg,gimme,arglast);
X st = stack->ary_array + arglast[0]; /* maybe realloced */
X goto array_return;
X case O_CALLER:
X sp = do_caller(arg,maxarg,gimme,arglast);
X st = stack->ary_array + arglast[0]; /* maybe realloced */
X goto array_return;
X case O_SORT:
X if ((arg[1].arg_type & A_MASK) == A_WORD)
X stab = arg[1].arg_ptr.arg_stab;
X else
X stab = stabent(str_get(st[1]),TRUE);
X sp = do_sort(str,stab,
X gimme,arglast);
X goto array_return;
X case O_REVERSE:
X if (gimme == G_ARRAY)
X sp = do_reverse(arglast);
X else
X sp = do_sreverse(str, arglast);
X goto array_return;
X case O_WARN:
X if (arglast[2] - arglast[1] != 1) {
X do_join(str,arglast);
X tmps = str_get(str);
X }
X else {
X str = st[2];
X tmps = str_get(st[2]);
X }
X if (!tmps || !*tmps)
X tmps = "Warning: something's wrong";
X warn("%s",tmps);
X goto say_yes;
X case O_DIE:
X if (arglast[2] - arglast[1] != 1) {
X do_join(str,arglast);
X tmps = str_get(str);
X }
X else {
X str = st[2];
X tmps = str_get(st[2]);
X }
X if (!tmps || !*tmps)
X tmps = "Died";
X fatal("%s",tmps);
X goto say_zero;
X case O_PRTF:
X case O_PRINT:
X if ((arg[1].arg_type & A_MASK) == A_WORD)
X stab = arg[1].arg_ptr.arg_stab;
X else
X stab = stabent(str_get(st[1]),TRUE);
X if (!stab)
X stab = defoutstab;
X if (!stab_io(stab)) {
X if (dowarn)
X warn("Filehandle never opened");
X goto say_zero;
X }
X if (!(fp = stab_io(stab)->ofp)) {
X if (dowarn) {
X if (stab_io(stab)->ifp)
X warn("Filehandle opened only for input");
X else
X warn("Print on closed filehandle");
X }
X goto say_zero;
X }
X else {
X if (optype == O_PRTF || arglast[2] - arglast[1] != 1)
X value = (double)do_aprint(arg,fp,arglast);
X else {
X value = (double)do_print(st[2],fp);
X if (orslen && optype == O_PRINT)
X if (fwrite(ors, 1, orslen, fp) == 0)
X goto say_zero;
X }
X if (stab_io(stab)->flags & IOF_FLUSH)
X if (fflush(fp) == EOF)
X goto say_zero;
X }
X goto donumset;
X case O_CHDIR:
X if (maxarg < 1)
X tmps = Nullch;
X else
X tmps = str_get(st[1]);
X if (!tmps || !*tmps) {
X tmpstr = hfetch(stab_hash(envstab),"HOME",4,FALSE);
X tmps = str_get(tmpstr);
X }
X if (!tmps || !*tmps) {
X tmpstr = hfetch(stab_hash(envstab),"LOGDIR",6,FALSE);
X tmps = str_get(tmpstr);
X }
X#ifdef TAINT
X taintproper("Insecure dependency in chdir");
X#endif
X value = (double)(chdir(tmps) >= 0);
X goto donumset;
X case O_EXIT:
X if (maxarg < 1)
X anum = 0;
X else
X anum = (int)str_gnum(st[1]);
X exit(anum);
X goto say_zero;
X case O_RESET:
X if (maxarg < 1)
X tmps = "";
X else
X tmps = str_get(st[1]);
X str_reset(tmps,curcmd->c_stash);
X value = 1.0;
X goto donumset;
X case O_LIST:
X if (gimme == G_ARRAY)
X goto array_return;
X if (maxarg > 0)
X str = st[sp - arglast[0]]; /* unwanted list, return last item */
X else
X str = &str_undef;
X break;
X case O_EOF:
X if (maxarg <= 0)
X stab = last_in_stab;
X else if ((arg[1].arg_type & A_MASK) == A_WORD)
X stab = arg[1].arg_ptr.arg_stab;
X else
X stab = stabent(str_get(st[1]),TRUE);
X str_set(str, do_eof(stab) ? Yes : No);
X STABSET(str);
X break;
X case O_GETC:
X if (maxarg <= 0)
X stab = stdinstab;
X else if ((arg[1].arg_type & A_MASK) == A_WORD)
X stab = arg[1].arg_ptr.arg_stab;
X else
X stab = stabent(str_get(st[1]),TRUE);
X if (!stab)
X stab = argvstab;
X if (!stab || do_eof(stab)) /* make sure we have fp with something */
X goto say_undef;
X else {
X#ifdef TAINT
X tainted = 1;
X#endif
X str_set(str," ");
X *str->str_ptr = getc(stab_io(stab)->ifp); /* should never be EOF */
X }
X STABSET(str);
X break;
X case O_TELL:
X if (maxarg <= 0)
X stab = last_in_stab;
X else if ((arg[1].arg_type & A_MASK) == A_WORD)
X stab = arg[1].arg_ptr.arg_stab;
X else
X stab = stabent(str_get(st[1]),TRUE);
X#ifndef lint
X value = (double)do_tell(stab);
X#else
X (void)do_tell(stab);
X#endif
X goto donumset;
X case O_RECV:
X case O_READ:
X case O_SYSREAD:
X if ((arg[1].arg_type & A_MASK) == A_WORD)
X stab = arg[1].arg_ptr.arg_stab;
X else
X stab = stabent(str_get(st[1]),TRUE);
X tmps = str_get(st[2]);
X anum = (int)str_gnum(st[3]);
X errno = 0;
X maxarg = sp - arglast[0];
X if (maxarg > 4)
X warn("Too many args on read");
X if (maxarg == 4)
X maxarg = (int)str_gnum(st[4]);
X else
X maxarg = 0;
X if (!stab_io(stab) || !stab_io(stab)->ifp)
X goto say_undef;
X#ifdef HAS_SOCKET
X if (optype == O_RECV) {
X argtype = sizeof buf;
X STR_GROW(st[2], anum+1), (tmps = str_get(st[2])); /* sneaky */
X anum = recvfrom(fileno(stab_io(stab)->ifp), tmps, anum, maxarg,
X buf, &argtype);
X if (anum >= 0) {
X st[2]->str_cur = anum;
X st[2]->str_ptr[anum] = '\0';
X str_nset(str,buf,argtype);
X }
X else
X str_sset(str,&str_undef);
X break;
X }
X#else
X if (optype == O_RECV)
X goto badsock;
X#endif
X STR_GROW(st[2], anum+maxarg+1), (tmps = str_get(st[2])); /* sneaky */
X#ifdef HAS_SOCKET
X if (stab_io(stab)->type == 's') {
X argtype = sizeof buf;
X anum = recvfrom(fileno(stab_io(stab)->ifp), tmps+maxarg, anum, 0,
X buf, &argtype);
X }
X else
X#endif
X if (optype == O_SYSREAD) {
X anum = read(fileno(stab_io(stab)->ifp), tmps+maxarg, anum);
X }
X else
X anum = fread(tmps+maxarg, 1, anum, stab_io(stab)->ifp);
X if (anum < 0)
X goto say_undef;
X st[2]->str_cur = anum+maxarg;
X st[2]->str_ptr[anum+maxarg] = '\0';
X value = (double)anum;
X goto donumset;
X case O_SYSWRITE:
X case O_SEND:
X if ((arg[1].arg_type & A_MASK) == A_WORD)
X stab = arg[1].arg_ptr.arg_stab;
X else
X stab = stabent(str_get(st[1]),TRUE);
X tmps = str_get(st[2]);
X anum = (int)str_gnum(st[3]);
X errno = 0;
X stio = stab_io(stab);
X maxarg = sp - arglast[0];
X if (!stio || !stio->ifp) {
X anum = -1;
X if (dowarn) {
X if (optype == O_SYSWRITE)
X warn("Syswrite on closed filehandle");
X else
X warn("Send on closed socket");
X }
X }
X else if (optype == O_SYSWRITE) {
X if (maxarg > 4)
X warn("Too many args on syswrite");
X if (maxarg == 4)
X optype = (int)str_gnum(st[4]);
X else
X optype = 0;
X anum = write(fileno(stab_io(stab)->ifp), tmps+optype, anum);
X }
X#ifdef HAS_SOCKET
X else if (maxarg >= 4) {
X if (maxarg > 4)
X warn("Too many args on send");
X tmps2 = str_get(st[4]);
X anum = sendto(fileno(stab_io(stab)->ifp), tmps, st[2]->str_cur,
X anum, tmps2, st[4]->str_cur);
X }
X else
X anum = send(fileno(stab_io(stab)->ifp), tmps, st[2]->str_cur, anum);
X#else
X else
X goto badsock;
X#endif
X if (anum < 0)
X goto say_undef;
X value = (double)anum;
X goto donumset;
X case O_SEEK:
X if ((arg[1].arg_type & A_MASK) == A_WORD)
X stab = arg[1].arg_ptr.arg_stab;
X else
X stab = stabent(str_get(st[1]),TRUE);
X value = str_gnum(st[2]);
X str_set(str, do_seek(stab,
X (long)value, (int)str_gnum(st[3]) ) ? Yes : No);
X STABSET(str);
X break;
X case O_RETURN:
X tmps = "_SUB_"; /* just fake up a "last _SUB_" */
X optype = O_LAST;
X if (curcsv && curcsv->wantarray == G_ARRAY) {
X lastretstr = Nullstr;
X lastspbase = arglast[1];
X lastsize = arglast[2] - arglast[1];
X }
X else
X lastretstr = str_mortal(st[arglast[2] - arglast[0]]);
X goto dopop;
X case O_REDO:
X case O_NEXT:
X case O_LAST:
X if (maxarg > 0) {
X tmps = str_get(arg[1].arg_ptr.arg_str);
X dopop:
X while (loop_ptr >= 0 && (!loop_stack[loop_ptr].loop_label ||
X strNE(tmps,loop_stack[loop_ptr].loop_label) )) {
X#ifdef DEBUGGING
X if (debug & 4) {
X deb("(Skipping label #%d %s)\n",loop_ptr,
X loop_stack[loop_ptr].loop_label);
X }
X#endif
X loop_ptr--;
X }
X#ifdef DEBUGGING
X if (debug & 4) {
X deb("(Found label #%d %s)\n",loop_ptr,
X loop_stack[loop_ptr].loop_label);
X }
X#endif
X }
X if (loop_ptr < 0) {
X if (tmps && strEQ(tmps, "_SUB_"))
X fatal("Can't return outside a subroutine");
X fatal("Bad label: %s", maxarg > 0 ? tmps : "<null>");
X }
X if (!lastretstr && optype == O_LAST && lastsize) {
X st -= arglast[0];
X st += lastspbase + 1;
X optype = loop_stack[loop_ptr].loop_sp - lastspbase; /* negative */
X if (optype) {
X for (anum = lastsize; anum > 0; anum--,st++)
X st[optype] = str_mortal(st[0]);
X }
X longjmp(loop_stack[loop_ptr].loop_env, O_LAST);
X }
X longjmp(loop_stack[loop_ptr].loop_env, optype);
X case O_DUMP:
X case O_GOTO:/* shudder */
X goto_targ = str_get(arg[1].arg_ptr.arg_str);
X if (!*goto_targ)
X goto_targ = Nullch; /* just restart from top */
X if (optype == O_DUMP) {
X do_undump = 1;
X my_unexec();
X }
X longjmp(top_env, 1);
X case O_INDEX:
X tmps = str_get(st[1]);
X if (maxarg < 3)
X anum = 0;
X else {
X anum = (int) str_gnum(st[3]) - arybase;
X if (anum < 0)
X anum = 0;
X else if (anum > st[1]->str_cur)
X anum = st[1]->str_cur;
X }
X#ifndef lint
X if (!(tmps2 = fbminstr((unsigned char*)tmps + anum,
X (unsigned char*)tmps + st[1]->str_cur, st[2])))
X#else
X if (tmps2 = fbminstr(Null(unsigned char*),Null(unsigned char*),Nullstr))
X#endif
X value = (double)(-1 + arybase);
X else
X value = (double)(tmps2 - tmps + arybase);
X goto donumset;
X case O_RINDEX:
X tmps = str_get(st[1]);
X tmps2 = str_get(st[2]);
X if (maxarg < 3)
X anum = st[1]->str_cur;
X else {
X anum = (int) str_gnum(st[3]) - arybase + st[2]->str_cur;
X if (anum < 0)
X anum = 0;
X else if (anum > st[1]->str_cur)
X anum = st[1]->str_cur;
X }
X#ifndef lint
X if (!(tmps2 = rninstr(tmps, tmps + anum,
X tmps2, tmps2 + st[2]->str_cur)))
X#else
X if (tmps2 = rninstr(Nullch,Nullch,Nullch,Nullch))
X#endif
X value = (double)(-1 + arybase);
X else
X value = (double)(tmps2 - tmps + arybase);
X goto donumset;
X case O_TIME:
X#ifndef lint
X value = (double) time(Null(long*));
X#endif
X goto donumset;
X case O_TMS:
X sp = do_tms(str,gimme,arglast);
X goto array_return;
X case O_LOCALTIME:
X if (maxarg < 1)
X (void)time(&when);
X else
X when = (long)str_gnum(st[1]);
X sp = do_time(str,localtime(&when),
X gimme,arglast);
X goto array_return;
X case O_GMTIME:
X if (maxarg < 1)
X (void)time(&when);
X else
X when = (long)str_gnum(st[1]);
X sp = do_time(str,gmtime(&when),
X gimme,arglast);
X goto array_return;
X case O_TRUNCATE:
X sp = do_truncate(str,arg,
X gimme,arglast);
X goto array_return;
X case O_LSTAT:
X case O_STAT:
X sp = do_stat(str,arg,
X gimme,arglast);
X goto array_return;
X case O_CRYPT:
X#ifdef HAS_CRYPT
X tmps = str_get(st[1]);
X#ifdef FCRYPT
X str_set(str,fcrypt(tmps,str_get(st[2])));
X#else
X str_set(str,crypt(tmps,str_get(st[2])));
X#endif
X#else
X fatal(
X "The crypt() function is unimplemented due to excessive paranoia.");
X#endif
X break;
X case O_ATAN2:
X value = str_gnum(st[1]);
X value = atan2(value,str_gnum(st[2]));
X goto donumset;
X case O_SIN:
X if (maxarg < 1)
X value = str_gnum(stab_val(defstab));
X else
X value = str_gnum(st[1]);
X value = sin(value);
X goto donumset;
X case O_COS:
X if (maxarg < 1)
X value = str_gnum(stab_val(defstab));
X else
X value = str_gnum(st[1]);
X value = cos(value);
X goto donumset;
X case O_RAND:
X if (maxarg < 1)
X value = 1.0;
X else
X value = str_gnum(st[1]);
X if (value == 0.0)
X value = 1.0;
X#if RANDBITS == 31
X value = rand() * value / 2147483648.0;
X#else
X#if RANDBITS == 16
X value = rand() * value / 65536.0;
X#else
X#if RANDBITS == 15
X value = rand() * value / 32768.0;
X#else
X value = rand() * value / (double)(((unsigned long)1) << RANDBITS);
X#endif
X#endif
X#endif
X goto donumset;
X case O_SRAND:
X if (maxarg < 1) {
X (void)time(&when);
X anum = when;
X }
X else
X anum = (int)str_gnum(st[1]);
X (void)srand(anum);
X goto say_yes;
X case O_EXP:
X if (maxarg < 1)
X value = str_gnum(stab_val(defstab));
X else
X value = str_gnum(st[1]);
X value = exp(value);
X goto donumset;
X case O_LOG:
X if (maxarg < 1)
X value = str_gnum(stab_val(defstab));
X else
X value = str_gnum(st[1]);
X if (value <= 0.0)
X fatal("Can't take log of %g\n", value);
X value = log(value);
X goto donumset;
X case O_SQRT:
X if (maxarg < 1)
X value = str_gnum(stab_val(defstab));
X else
X value = str_gnum(st[1]);
X if (value < 0.0)
X fatal("Can't take sqrt of %g\n", value);
X value = sqrt(value);
X goto donumset;
X case O_INT:
X if (maxarg < 1)
X value = str_gnum(stab_val(defstab));
X else
X value = str_gnum(st[1]);
X if (value >= 0.0)
X (void)modf(value,&value);
X else {
X (void)modf(-value,&value);
X value = -value;
X }
X goto donumset;
X case O_ORD:
X if (maxarg < 1)
X tmps = str_get(stab_val(defstab));
X else
X tmps = str_get(st[1]);
X#ifndef I286
X value = (double) (*tmps & 255);
X#else
X anum = (int) *tmps;
X value = (double) (anum & 255);
X#endif
X goto donumset;
X case O_ALARM:
X#ifdef HAS_ALARM
X if (maxarg < 1)
X tmps = str_get(stab_val(defstab));
X else
X tmps = str_get(st[1]);
X if (!tmps)
X tmps = "0";
X anum = alarm((unsigned int)atoi(tmps));
X if (anum < 0)
X goto say_undef;
X value = (double)anum;
X goto donumset;
X#else
X fatal("Unsupported function alarm");
X break;
X#endif
X case O_SLEEP:
X if (maxarg < 1)
X tmps = Nullch;
X else
X tmps = str_get(st[1]);
X (void)time(&when);
X if (!tmps || !*tmps)
X sleep((32767<<16)+32767);
X else
X sleep((unsigned int)atoi(tmps));
X#ifndef lint
X value = (double)when;
X (void)time(&when);
X value = ((double)when) - value;
X#endif
X goto donumset;
X case O_RANGE:
X sp = do_range(gimme,arglast);
X goto array_return;
X case O_F_OR_R:
X if (gimme == G_ARRAY) { /* it's a range */
X /* can we optimize to constant array? */
X if ((arg[1].arg_type & A_MASK) == A_SINGLE &&
X (arg[2].arg_type & A_MASK) == A_SINGLE) {
X st[2] = arg[2].arg_ptr.arg_str;
X sp = do_range(gimme,arglast);
X st = stack->ary_array;
X maxarg = sp - arglast[0];
X str_free(arg[1].arg_ptr.arg_str);
X arg[1].arg_ptr.arg_str = Nullstr;
X str_free(arg[2].arg_ptr.arg_str);
X arg[2].arg_ptr.arg_str = Nullstr;
X arg->arg_type = O_ARRAY;
X arg[1].arg_type = A_STAB|A_DONT;
X arg->arg_len = 1;
X stab = arg[1].arg_ptr.arg_stab = aadd(genstab());
X ary = stab_array(stab);
X afill(ary,maxarg - 1);
X anum = maxarg;
X st += arglast[0]+1;
X while (maxarg-- > 0)
X ary->ary_array[maxarg] = str_smake(st[maxarg]);
X st -= arglast[0]+1;
X goto array_return;
X }
X arg->arg_type = optype = O_RANGE;
X maxarg = arg->arg_len = 2;
X anum = 2;
X arg[anum].arg_flags &= ~AF_ARYOK;
X argflags = arg[anum].arg_flags;
X argtype = arg[anum].arg_type & A_MASK;
X arg[anum].arg_type = argtype;
X argptr = arg[anum].arg_ptr;
X sp = arglast[0];
X st -= sp;
X sp++;
X goto re_eval;
X }
X arg->arg_type = O_FLIP;
X /* FALL THROUGH */
X case O_FLIP:
X if ((arg[1].arg_type & A_MASK) == A_SINGLE ?
X last_in_stab && (int)str_gnum(st[1]) == stab_io(last_in_stab)->lines
X :
X str_true(st[1]) ) {
X str_numset(str,0.0);
X anum = 2;
X arg->arg_type = optype = O_FLOP;
X arg[2].arg_type &= ~A_DONT;
X arg[1].arg_type |= A_DONT;
X argflags = arg[2].arg_flags;
X argtype = arg[2].arg_type & A_MASK;
X argptr = arg[2].arg_ptr;
X sp = arglast[0];
X st -= sp++;
X goto re_eval;
X }
X str_set(str,"");
X break;
X case O_FLOP:
X str_inc(str);
X if ((arg[2].arg_type & A_MASK) == A_SINGLE ?
X last_in_stab && (int)str_gnum(st[2]) == stab_io(last_in_stab)->lines
X :
X str_true(st[2]) ) {
X arg->arg_type = O_FLIP;
X arg[1].arg_type &= ~A_DONT;
X arg[2].arg_type |= A_DONT;
X str_cat(str,"E0");
X }
X break;
X case O_FORK:
X#ifdef HAS_FORK
X anum = fork();
X if (anum < 0)
X goto say_undef;
X if (!anum) {
X if (tmpstab = stabent("$",allstabs))
X str_numset(STAB_STR(tmpstab),(double)getpid());
X hclear(pidstatus); /* no kids, so don't wait for 'em */
X }
X value = (double)anum;
X goto donumset;
X#else
X fatal("Unsupported function fork");
X break;
X#endif
X case O_WAIT:
X#ifdef HAS_WAIT
X#ifndef lint
X anum = wait(&argflags);
X if (anum > 0)
X pidgone(anum,argflags);
X value = (double)anum;
X#endif
X statusvalue = (unsigned short)argflags;
X goto donumset;
X#else
X fatal("Unsupported function wait");
X break;
X#endif
X case O_WAITPID:
X#ifdef HAS_WAIT
X#ifndef lint
X anum = (int)str_gnum(st[1]);
X optype = (int)str_gnum(st[2]);
X anum = wait4pid(anum, &argflags,optype);
X value = (double)anum;
X#endif
X statusvalue = (unsigned short)argflags;
X goto donumset;
X#else
X fatal("Unsupported function wait");
X break;
X#endif
X case O_SYSTEM:
X#ifdef HAS_FORK
X#ifdef TAINT
X if (arglast[2] - arglast[1] == 1) {
X taintenv();
X tainted |= st[2]->str_tainted;
X taintproper("Insecure dependency in system");
X }
X#endif
X while ((anum = vfork()) == -1) {
X if (errno != EAGAIN) {
X value = -1.0;
X goto donumset;
X }
X sleep(5);
X }
X if (anum > 0) {
X#ifndef lint
X ihand = signal(SIGINT, SIG_IGN);
X qhand = signal(SIGQUIT, SIG_IGN);
X argtype = wait4pid(anum, &argflags, 0);
X#else
X ihand = qhand = 0;
X#endif
X (void)signal(SIGINT, ihand);
X (void)signal(SIGQUIT, qhand);
X statusvalue = (unsigned short)argflags;
X if (argtype < 0)
X value = -1.0;
X else {
X value = (double)((unsigned int)argflags & 0xffff);
X }
X do_execfree(); /* free any memory child malloced on vfork */
X goto donumset;
X }
X if ((arg[1].arg_type & A_MASK) == A_STAB)
X value = (double)do_aexec(st[1],arglast);
X else if (arglast[2] - arglast[1] != 1)
X value = (double)do_aexec(Nullstr,arglast);
X else {
X value = (double)do_exec(str_get(str_mortal(st[2])));
X }
X _exit(-1);
X#else /* ! FORK */
X if ((arg[1].arg_type & A_MASK) == A_STAB)
X value = (double)do_aspawn(st[1],arglast);
X else if (arglast[2] - arglast[1] != 1)
X value = (double)do_aspawn(Nullstr,arglast);
X else {
X value = (double)do_spawn(str_get(str_mortal(st[2])));
X }
X goto donumset;
X#endif /* FORK */
X case O_EXEC_OP:
X if ((arg[1].arg_type & A_MASK) == A_STAB)
X value = (double)do_aexec(st[1],arglast);
X else if (arglast[2] - arglast[1] != 1)
X value = (double)do_aexec(Nullstr,arglast);
X else {
X value = (double)do_exec(str_get(str_mortal(st[2])));
X }
X goto donumset;
X case O_HEX:
X if (maxarg < 1)
X tmps = str_get(stab_val(defstab));
X else
X tmps = str_get(st[1]);
X value = (double)scanhex(tmps, 99, &argtype);
X goto donumset;
X
X case O_OCT:
X if (maxarg < 1)
X tmps = str_get(stab_val(defstab));
X else
X tmps = str_get(st[1]);
X while (*tmps && isascii(*tmps) && (isspace(*tmps) || *tmps == '0'))
X tmps++;
X if (*tmps == 'x')
X value = (double)scanhex(++tmps, 99, &argtype);
X else
X value = (double)scanoct(tmps, 99, &argtype);
X goto donumset;
X
X/* These common exits are hidden here in the middle of the switches for the
X/* benefit of those machines with limited branch addressing. Sigh. */
X
Xarray_return:
X#ifdef DEBUGGING
X if (debug) {
X dlevel--;
X if (debug & 8) {
!STUFFY!FUNK!
echo " "
echo "End of kit 6 (of 36)"
cat /dev/null >kit6isdone
run=''
config=''
for iskit in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36; do
if test -f kit${iskit}isdone; then
run="$run $iskit"
else
todo="$todo $iskit"
fi
done
case $todo in
'')
echo "You have run all your kits. Please read README and then type Configure."
for combo in *:AA; do
if test -f "$combo"; then
realfile=`basename $combo :AA`
cat $realfile:[A-Z][A-Z] >$realfile
rm -rf $realfile:[A-Z][A-Z]
fi
done
rm -rf kit*isdone
chmod 755 Configure
;;
*) echo "You have run$run."
echo "You still need to run$todo."
;;
esac
: Someone might mail this, so...
exit
exit 0 # Just in case...
--
Kent Landfield INTERNET: kent@sparky.IMD.Sterling.COM
Sterling Software, IMD UUCP: uunet!sparky!kent
Phone: (402) 291-8300 FAX: (402) 291-4362
Please send comp.sources.misc-related mail to kent@uunet.uu.net.