From pa.dec.com!decwrl!uunet!sparky!kent Mon Apr 15 18:30:50 PDT 1991 Article: 2190 of comp.sources.misc Path: pa.dec.com!decwrl!uunet!sparky!kent From: lwall@netlabs.com (Larry Wall) Newsgroups: comp.sources.misc Subject: v18i024: perl - The perl programming language, Part06/36 Message-ID: <1991Apr15.015344.6777@sparky.IMD.Sterling.COM> Date: 15 Apr 91 01:53:44 GMT Sender: kent@sparky.IMD.Sterling.COM (Kent Landfield) Organization: NetLabs, Inc. Lines: 2052 Approved: kent@sparky.imd.sterling.com X-Checksum-Snefru: 8df5aaf0 b41671c9 a7fde89c a0c9781f Submitted-by: Larry Wall 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 X#endif X X#ifdef I_FCNTL X#include X#endif X#ifdef I_SYS_FILE X#include X#endif X#ifdef I_VFORK X# include 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 : ""); 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.