summaryrefslogtreecommitdiff
path: root/eval.c.save
diff options
context:
space:
mode:
Diffstat (limited to 'eval.c.save')
-rw-r--r--eval.c.save3048
1 files changed, 0 insertions, 3048 deletions
diff --git a/eval.c.save b/eval.c.save
deleted file mode 100644
index 964bc0301f..0000000000
--- a/eval.c.save
+++ /dev/null
@@ -1,3048 +0,0 @@
-/* $RCSfile: eval.c,v $$Revision: 4.1 $$Date: 92/08/07 18:20:29 $
- *
- * Copyright (c) 1991, Larry Wall
- *
- * You may distribute under the terms of either the GNU General Public
- * License or the Artistic License, as specified in the README file.
- *
- * $Log: eval.c,v $
- * Revision 4.1 92/08/07 18:20:29 lwall
- *
- * Revision 4.0.1.4 92/06/08 13:20:20 lwall
- * patch20: added explicit time_t support
- * patch20: fixed confusion between a *var's real name and its effective name
- * patch20: added Atari ST portability
- * patch20: new warning for use of x with non-numeric right operand
- * patch20: modulus with highest bit in left operand set didn't always work
- * patch20: dbmclose(%array) didn't work
- * patch20: added ... as variant on ..
- * patch20: O_PIPE conflicted with Atari
- *
- * Revision 4.0.1.3 91/11/05 17:15:21 lwall
- * patch11: prepared for ctype implementations that don't define isascii()
- * patch11: various portability fixes
- * patch11: added sort {} LIST
- * patch11: added eval {}
- * patch11: sysread() in socket was substituting recv()
- * patch11: a last statement outside any block caused occasional core dumps
- * patch11: missing arguments caused core dump in -D8 code
- * patch11: eval 'stuff' now optimized to eval {stuff}
- *
- * Revision 4.0.1.2 91/06/07 11:07:23 lwall
- * patch4: new copyright notice
- * patch4: length($`), length($&), length($') now optimized to avoid string copy
- * patch4: assignment wasn't correctly de-tainting the assigned variable.
- * patch4: default top-of-form format is now FILEHANDLE_TOP
- * patch4: added $^P variable to control calling of perldb routines
- * patch4: taintchecks could improperly modify parent in vfork()
- * patch4: many, many itty-bitty portability fixes
- *
- * Revision 4.0.1.1 91/04/11 17:43:48 lwall
- * patch1: fixed failed fork to return undef as documented
- * patch1: reduced maximum branch distance in eval.c
- *
- * Revision 4.0 91/03/20 01:16:48 lwall
- * 4.0 baseline.
- *
- */
-
-#include "EXTERN.h"
-#include "perl.h"
-
-extern int (*ppaddr[])();
-extern int mark[];
-
-#if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
-#include <signal.h>
-#endif
-
-#ifdef I_FCNTL
-#include <fcntl.h>
-#endif
-#ifdef MSDOS
-/* I_FCNTL *MUST* not be defined for MS-DOS and OS/2
- but fcntl.h is required for O_BINARY */
-#include <fcntl.h>
-#endif
-#ifdef I_SYS_FILE
-#include <sys/file.h>
-#endif
-#ifdef I_VFORK
-# include <vfork.h>
-#endif
-
-double sin(), cos(), atan2(), pow();
-
-char *getlogin();
-
-int
-eval(arg,gimme,sp)
-register ARG *arg;
-int gimme;
-register int sp;
-{
- register STR *str;
- register int anum;
- register int optype;
- register STR **st;
- int maxarg;
- double value;
- register char *tmps;
- char *tmps2;
- int argflags;
- int argtype;
- union argptr argptr;
- int arglast[8]; /* highest sp for arg--valid only for non-O_LIST args */
- unsigned long tmpulong;
- long tmplong;
- time_t when;
- STRLEN tmplen;
- FILE *fp;
- STR *tmpstr;
- FCMD *form;
- STAB *stab;
- STAB *stab2;
- STIO *stio;
- ARRAY *ary;
- int old_rslen;
- int old_rschar;
- VOIDRET (*ihand)(); /* place to save signal during system() */
- VOIDRET (*qhand)(); /* place to save signal during system() */
- bool assigning = FALSE;
- int mymarkbase = savestack->ary_fill;
-
- if (!arg)
- goto say_undef;
- optype = arg->arg_type;
- maxarg = arg->arg_len;
- arglast[0] = sp;
- str = arg->arg_ptr.arg_str;
- if (sp + maxarg > stack->ary_max)
- astore(stack, sp + maxarg, Nullstr);
- st = stack->ary_array;
-
-#ifdef DEBUGGING
- if (debug) {
- if (debug & 8) {
- deb("%s (%lx) %d args:\n",opname[optype],arg,maxarg);
- }
- debname[dlevel] = opname[optype][0];
- debdelim[dlevel] = ':';
- if (++dlevel >= dlmax)
- grow_dlevel();
- }
-#endif
-
- if (mark[optype]) {
- saveint(&markbase);
- markbase = mymarkbase;
- saveint(&stack_mark);
- stack_mark = sp;
- }
- for (anum = 1; anum <= maxarg; anum++) {
- argflags = arg[anum].arg_flags;
- argtype = arg[anum].arg_type;
- argptr = arg[anum].arg_ptr;
- re_eval:
- switch (argtype) {
- default:
- if (!ppaddr[optype] || optype == O_SUBR || optype == O_DBSUBR) {
- st[++sp] = &str_undef;
- }
-#ifdef DEBUGGING
- tmps = "NULL";
-#endif
- break;
- case A_EXPR:
-#ifdef DEBUGGING
- if (debug & 8) {
- tmps = "EXPR";
- deb("%d.EXPR =>\n",anum);
- }
-#endif
- sp = eval(argptr.arg_arg,
- (argflags & AF_ARYOK) ? G_ARRAY : G_SCALAR, sp);
- if (sp + (maxarg - anum) > stack->ary_max)
- astore(stack, sp + (maxarg - anum), Nullstr);
- st = stack->ary_array; /* possibly reallocated */
- break;
- case A_CMD:
-#ifdef DEBUGGING
- if (debug & 8) {
- tmps = "CMD";
- deb("%d.CMD (%lx) =>\n",anum,argptr.arg_cmd);
- }
-#endif
- sp = cmd_exec(argptr.arg_cmd, gimme, sp);
- if (sp + (maxarg - anum) > stack->ary_max)
- astore(stack, sp + (maxarg - anum), Nullstr);
- st = stack->ary_array; /* possibly reallocated */
- break;
- case A_LARYSTAB:
- ++sp;
- switch (optype) {
- case O_ITEM2: argtype = 2; break;
- case O_ITEM3: argtype = 3; break;
- default: argtype = anum; break;
- }
- str = afetch(stab_array(argptr.arg_stab),
- arg[argtype].arg_len - arybase, TRUE);
-#ifdef DEBUGGING
- if (debug & 8) {
- (void)sprintf(buf,"LARYSTAB $%s[%d]",stab_name(argptr.arg_stab),
- arg[argtype].arg_len);
- tmps = buf;
- }
-#endif
- goto do_crement;
- case A_ARYSTAB:
- switch (optype) {
- case O_ITEM2: argtype = 2; break;
- case O_ITEM3: argtype = 3; break;
- default: argtype = anum; break;
- }
- st[++sp] = afetch(stab_array(argptr.arg_stab),
- arg[argtype].arg_len - arybase, FALSE);
-#ifdef DEBUGGING
- if (debug & 8) {
- (void)sprintf(buf,"ARYSTAB $%s[%d]",stab_name(argptr.arg_stab),
- arg[argtype].arg_len);
- tmps = buf;
- }
-#endif
- break;
- case A_STAR:
- stab = argptr.arg_stab;
- st[++sp] = (STR*)stab;
- if (!stab_xarray(stab))
- aadd(stab);
- if (!stab_xhash(stab))
- hadd(stab);
- if (!stab_io(stab))
- stab_io(stab) = stio_new();
-#ifdef DEBUGGING
- if (debug & 8) {
- (void)sprintf(buf,"STAR *%s -> *%s",
- stab_name(argptr.arg_stab), stab_ename(argptr.arg_stab));
- tmps = buf;
- }
-#endif
- break;
- case A_LSTAR:
- str = st[++sp] = (STR*)argptr.arg_stab;
-#ifdef DEBUGGING
- if (debug & 8) {
- (void)sprintf(buf,"LSTAR *%s -> *%s",
- stab_name(argptr.arg_stab), stab_ename(argptr.arg_stab));
- tmps = buf;
- }
-#endif
- break;
- case A_STAB:
- st[++sp] = STAB_STR(argptr.arg_stab);
-#ifdef DEBUGGING
- if (debug & 8) {
- (void)sprintf(buf,"STAB $%s",stab_name(argptr.arg_stab));
- tmps = buf;
- }
-#endif
- break;
- case A_LENSTAB:
- str_numset(str, (double)STAB_LEN(argptr.arg_stab));
- st[++sp] = str;
-#ifdef DEBUGGING
- if (debug & 8) {
- (void)sprintf(buf,"LENSTAB $%s",stab_name(argptr.arg_stab));
- tmps = buf;
- }
-#endif
- break;
- case A_LEXPR:
-#ifdef DEBUGGING
- if (debug & 8) {
- tmps = "LEXPR";
- deb("%d.LEXPR =>\n",anum);
- }
-#endif
- if (argflags & AF_ARYOK) {
- sp = eval(argptr.arg_arg, G_ARRAY, sp);
- if (sp + (maxarg - anum) > stack->ary_max)
- astore(stack, sp + (maxarg - anum), Nullstr);
- st = stack->ary_array; /* possibly reallocated */
- }
- else {
- sp = eval(argptr.arg_arg, G_SCALAR, sp);
- st = stack->ary_array; /* possibly reallocated */
- str = st[sp];
- goto do_crement;
- }
- break;
- case A_LVAL:
-#ifdef DEBUGGING
- if (debug & 8) {
- (void)sprintf(buf,"LVAL $%s",stab_name(argptr.arg_stab));
- tmps = buf;
- }
-#endif
- ++sp;
- str = STAB_STR(argptr.arg_stab);
- if (!str)
- fatal("panic: A_LVAL");
- do_crement:
- assigning = TRUE;
- if (argflags & AF_PRE) {
- if (argflags & AF_UP)
- str_inc(str);
- else
- str_dec(str);
- STABSET(str);
- st[sp] = str;
- str = arg->arg_ptr.arg_str;
- }
- else if (argflags & AF_POST) {
- st[sp] = str_mortal(str);
- if (argflags & AF_UP)
- str_inc(str);
- else
- str_dec(str);
- STABSET(str);
- str = arg->arg_ptr.arg_str;
- }
- else
- st[sp] = str;
- break;
- case A_LARYLEN:
- ++sp;
- stab = argptr.arg_stab;
- str = stab_array(argptr.arg_stab)->ary_magic;
- if (optype != O_SASSIGN || argflags & (AF_PRE|AF_POST))
- str_numset(str,(double)(stab_array(stab)->ary_fill+arybase));
-#ifdef DEBUGGING
- tmps = "LARYLEN";
-#endif
- if (!str)
- fatal("panic: A_LEXPR");
- goto do_crement;
- case A_ARYLEN:
- stab = argptr.arg_stab;
- st[++sp] = stab_array(stab)->ary_magic;
- str_numset(st[sp],(double)(stab_array(stab)->ary_fill+arybase));
-#ifdef DEBUGGING
- tmps = "ARYLEN";
-#endif
- break;
- case A_SINGLE:
- st[++sp] = argptr.arg_str;
-#ifdef DEBUGGING
- tmps = "SINGLE";
-#endif
- break;
- case A_DOUBLE:
- (void) interp(str,argptr.arg_str,sp);
- st = stack->ary_array;
- st[++sp] = str;
-#ifdef DEBUGGING
- tmps = "DOUBLE";
-#endif
- break;
- case A_BACKTICK:
- tmps = str_get(interp(str,argptr.arg_str,sp));
- st = stack->ary_array;
-#ifdef TAINT
- TAINT_PROPER("``");
-#endif
- fp = mypopen(tmps,"r");
- str_set(str,"");
- if (fp) {
- if (gimme == G_SCALAR) {
- while (str_gets(str,fp,str->str_cur) != Nullch)
- /*SUPPRESS 530*/
- ;
- }
- else {
- for (;;) {
- if (++sp > stack->ary_max) {
- astore(stack, sp, Nullstr);
- st = stack->ary_array;
- }
- str = st[sp] = Str_new(56,80);
- if (str_gets(str,fp,0) == Nullch) {
- sp--;
- break;
- }
- if (str->str_len - str->str_cur > 20) {
- str->str_len = str->str_cur+1;
- Renew(str->str_ptr, str->str_len, char);
- }
- str_2mortal(str);
- }
- }
- statusvalue = mypclose(fp);
- }
- else
- statusvalue = -1;
-
- if (gimme == G_SCALAR)
- st[++sp] = str;
-#ifdef DEBUGGING
- tmps = "BACK";
-#endif
- break;
- case A_WANTARRAY:
- {
- if (curcsv->wantarray == G_ARRAY)
- st[++sp] = &str_yes;
- else
- st[++sp] = &str_no;
- }
-#ifdef DEBUGGING
- tmps = "WANTARRAY";
-#endif
- break;
- case A_INDREAD:
- last_in_stab = stabent(str_get(STAB_STR(argptr.arg_stab)),TRUE);
- old_rschar = rschar;
- old_rslen = rslen;
- goto do_read;
- case A_GLOB:
- argflags |= AF_POST; /* enable newline chopping */
- last_in_stab = argptr.arg_stab;
- old_rschar = rschar;
- old_rslen = rslen;
- rslen = 1;
-#ifdef DOSISH
- rschar = 0;
-#else
-#ifdef CSH
- rschar = 0;
-#else
- rschar = '\n';
-#endif /* !CSH */
-#endif /* !MSDOS */
- goto do_read;
- case A_READ:
- last_in_stab = argptr.arg_stab;
- old_rschar = rschar;
- old_rslen = rslen;
- do_read:
- if (anum > 1) /* assign to scalar */
- gimme = G_SCALAR; /* force context to scalar */
- if (gimme == G_ARRAY)
- str = Str_new(57,0);
- ++sp;
- fp = Nullfp;
- if (stab_io(last_in_stab)) {
- fp = stab_io(last_in_stab)->ifp;
- if (!fp) {
- if (stab_io(last_in_stab)->flags & IOF_ARGV) {
- if (stab_io(last_in_stab)->flags & IOF_START) {
- stab_io(last_in_stab)->flags &= ~IOF_START;
- stab_io(last_in_stab)->lines = 0;
- if (alen(stab_array(last_in_stab)) < 0) {
- tmpstr = str_make("-",1); /* assume stdin */
- (void)apush(stab_array(last_in_stab), tmpstr);
- }
- }
- fp = nextargv(last_in_stab);
- if (!fp) { /* Note: fp != stab_io(last_in_stab)->ifp */
- (void)do_close(last_in_stab,FALSE); /* now it does*/
- stab_io(last_in_stab)->flags |= IOF_START;
- }
- }
- else if (argtype == A_GLOB) {
- (void) interp(str,stab_val(last_in_stab),sp);
- st = stack->ary_array;
- tmpstr = Str_new(55,0);
-#ifdef DOSISH
- str_set(tmpstr, "perlglob ");
- str_scat(tmpstr,str);
- str_cat(tmpstr," |");
-#else
-#ifdef CSH
- str_nset(tmpstr,cshname,cshlen);
- str_cat(tmpstr," -cf 'set nonomatch; glob ");
- str_scat(tmpstr,str);
- str_cat(tmpstr,"'|");
-#else
- str_set(tmpstr, "echo ");
- str_scat(tmpstr,str);
- str_cat(tmpstr,
- "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
-#endif /* !CSH */
-#endif /* !MSDOS */
- (void)do_open(last_in_stab,tmpstr->str_ptr,
- tmpstr->str_cur);
- fp = stab_io(last_in_stab)->ifp;
- str_free(tmpstr);
- }
- }
- }
- if (!fp && dowarn)
- warn("Read on closed filehandle <%s>",stab_ename(last_in_stab));
- tmplen = str->str_len; /* remember if already alloced */
- if (!tmplen)
- Str_Grow(str,80); /* try short-buffering it */
- keepgoing:
- if (!fp)
- st[sp] = &str_undef;
- else if (!str_gets(str,fp, optype == O_RCAT ? str->str_cur : 0)) {
- clearerr(fp);
- if (stab_io(last_in_stab)->flags & IOF_ARGV) {
- fp = nextargv(last_in_stab);
- if (fp)
- goto keepgoing;
- (void)do_close(last_in_stab,FALSE);
- stab_io(last_in_stab)->flags |= IOF_START;
- }
- else if (argflags & AF_POST) {
- (void)do_close(last_in_stab,FALSE);
- }
- st[sp] = &str_undef;
- rschar = old_rschar;
- rslen = old_rslen;
- if (gimme == G_ARRAY) {
- --sp;
- str_2mortal(str);
- goto array_return;
- }
- break;
- }
- else {
- stab_io(last_in_stab)->lines++;
- st[sp] = str;
-#ifdef TAINT
- str->str_tainted = 1; /* Anything from the outside world...*/
-#endif
- if (argflags & AF_POST) {
- if (str->str_cur > 0)
- str->str_cur--;
- if (str->str_ptr[str->str_cur] == rschar)
- str->str_ptr[str->str_cur] = '\0';
- else
- str->str_cur++;
- for (tmps = str->str_ptr; *tmps; tmps++)
- if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
- index("$&*(){}[]'\";\\|?<>~`",*tmps))
- break;
- if (*tmps && stat(str->str_ptr,&statbuf) < 0)
- goto keepgoing; /* unmatched wildcard? */
- }
- if (gimme == G_ARRAY) {
- if (str->str_len - str->str_cur > 20) {
- str->str_len = str->str_cur+1;
- Renew(str->str_ptr, str->str_len, char);
- }
- str_2mortal(str);
- if (++sp > stack->ary_max) {
- astore(stack, sp, Nullstr);
- st = stack->ary_array;
- }
- str = Str_new(58,80);
- goto keepgoing;
- }
- else if (!tmplen && str->str_len - str->str_cur > 80) {
- /* try to reclaim a bit of scalar space on 1st alloc */
- if (str->str_cur < 60)
- str->str_len = 80;
- else
- str->str_len = str->str_cur+40; /* allow some slop */
- Renew(str->str_ptr, str->str_len, char);
- }
- }
- rschar = old_rschar;
- rslen = old_rslen;
-#ifdef DEBUGGING
- tmps = "READ";
-#endif
- break;
- }
-#ifdef DEBUGGING
- if (debug & 8) {
- if (strEQ(tmps, "NULL"))
- deb("%d.%s\n",anum,tmps);
- else
- deb("%d.%s = '%s'\n",anum,tmps,str_peek(st[sp]));
- }
-#endif
- if (anum < 8)
- arglast[anum] = sp;
- }
-
- if (ppaddr[optype]) {
- int status;
-
- /* pretend like we've been maintaining stack_* all along */
- stack_ary = stack->ary_array;
- stack_sp = stack_ary + sp;
- if (mark[optype] && stack_mark != arglast[0])
- warn("Inconsistent stack mark %d != %d", stack_mark, arglast[0]);
- stack_max = stack_ary + stack->ary_max;
-
- status = (*ppaddr[optype])(str, arg, gimme);
-
- if (savestack->ary_fill > mymarkbase) {
- warn("Inconsistent stack base");
- restorelist(mymarkbase);
- }
- sp = stack_sp - stack_ary;
- if (sp < arglast[0])
- warn("TOO MANY POPS");
- st += arglast[0];
- goto array_return;
- }
-
- st += arglast[0];
-
-#ifdef SMALLSWITCHES
- if (optype < O_CHOWN)
-#endif
- switch (optype) {
- case O_RCAT:
- STABSET(str);
- break;
- case O_ITEM:
- if (gimme == G_ARRAY)
- goto array_return;
- /* FALL THROUGH */
- case O_SCALAR:
- STR_SSET(str,st[1]);
- STABSET(str);
- break;
- case O_ITEM2:
- if (gimme == G_ARRAY)
- goto array_return;
- --anum;
- STR_SSET(str,st[arglast[anum]-arglast[0]]);
- STABSET(str);
- break;
- case O_ITEM3:
- if (gimme == G_ARRAY)
- goto array_return;
- --anum;
- STR_SSET(str,st[arglast[anum]-arglast[0]]);
- STABSET(str);
- break;
- case O_CONCAT:
- STR_SSET(str,st[1]);
- str_scat(str,st[2]);
- STABSET(str);
- break;
- case O_REPEAT:
- if (gimme == G_ARRAY && arg[1].arg_flags & AF_ARYOK) {
- sp = do_repeatary(arglast);
- goto array_return;
- }
- STR_SSET(str,st[1]);
- anum = (int)str_gnum(st[2]);
- if (anum >= 1) {
- tmpstr = Str_new(50, 0);
- tmps = str_get(str);
- str_nset(tmpstr,tmps,str->str_cur);
- tmps = str_get(tmpstr); /* force to be string */
- STR_GROW(str, (anum * str->str_cur) + 1);
- repeatcpy(str->str_ptr, tmps, tmpstr->str_cur, anum);
- str->str_cur *= anum;
- str->str_ptr[str->str_cur] = '\0';
- str->str_nok = 0;
- str_free(tmpstr);
- }
- else {
- if (dowarn && st[2]->str_pok && !looks_like_number(st[2]))
- warn("Right operand of x is not numeric");
- str_sset(str,&str_no);
- }
- STABSET(str);
- break;
- case O_MATCH:
- sp = do_match(str,arg,
- gimme,arglast);
- if (gimme == G_ARRAY)
- goto array_return;
- STABSET(str);
- break;
- case O_NMATCH:
- sp = do_match(str,arg,
- G_SCALAR,arglast);
- str_sset(str, str_true(str) ? &str_no : &str_yes);
- STABSET(str);
- break;
- case O_SUBST:
- sp = do_subst(str,arg,arglast[0]);
- goto array_return;
- case O_NSUBST:
- sp = do_subst(str,arg,arglast[0]);
- str = arg->arg_ptr.arg_str;
- str_set(str, str_true(str) ? No : Yes);
- goto array_return;
- case O_ASSIGN:
- if (arg[1].arg_flags & AF_ARYOK) {
- if (arg->arg_len == 1) {
- arg->arg_type = O_LOCAL;
- goto local;
- }
- else {
- arg->arg_type = O_AASSIGN;
- goto aassign;
- }
- }
- else {
- arg->arg_type = O_SASSIGN;
- goto sassign;
- }
- case O_LOCAL:
- local:
- arglast[2] = arglast[1]; /* push a null array */
- /* FALL THROUGH */
- case O_AASSIGN:
- aassign:
- sp = do_assign(arg,
- gimme,arglast);
- goto array_return;
- case O_SASSIGN:
- sassign:
-#ifdef TAINT
- if (tainted && !st[2]->str_tainted)
- tainted = 0;
-#endif
- STR_SSET(str, st[2]);
- STABSET(str);
- break;
- case O_CHOP:
- st -= arglast[0];
- str = arg->arg_ptr.arg_str;
- for (sp = arglast[0] + 1; sp <= arglast[1]; sp++)
- do_chop(str,st[sp]);
- st += arglast[0];
- break;
- case O_DEFINED:
- if (arg[1].arg_type & A_DONT) {
- sp = do_defined(str,arg,
- gimme,arglast);
- goto array_return;
- }
- else if (str->str_pok || str->str_nok)
- goto say_yes;
- goto say_no;
- case O_UNDEF:
- if (arg[1].arg_type & A_DONT) {
- sp = do_undef(str,arg,
- gimme,arglast);
- goto array_return;
- }
- else if (str != stab_val(defstab)) {
- if (str->str_len) {
- if (str->str_state == SS_INCR)
- Str_Grow(str,0);
- Safefree(str->str_ptr);
- str->str_ptr = Nullch;
- str->str_len = 0;
- }
- str->str_pok = str->str_nok = 0;
- STABSET(str);
- }
- goto say_undef;
- case O_STUDY:
- sp = do_study(str,arg,
- gimme,arglast);
- goto array_return;
- case O_POW:
- value = str_gnum(st[1]);
- value = pow(value,str_gnum(st[2]));
- goto donumset;
- case O_MULTIPLY:
- value = str_gnum(st[1]);
- value *= str_gnum(st[2]);
- goto donumset;
- case O_DIVIDE:
- if ((value = str_gnum(st[2])) == 0.0)
- fatal("Illegal division by zero");
-#ifdef SLOPPYDIVIDE
- /* insure that 20./5. == 4. */
- {
- double x;
- int k;
- x = str_gnum(st[1]);
- if ((double)(int)x == x &&
- (double)(int)value == value &&
- (k = (int)x/(int)value)*(int)value == (int)x) {
- value = k;
- } else {
- value = x/value;
- }
- }
-#else
- value = str_gnum(st[1]) / value;
-#endif
- goto donumset;
- case O_MODULO:
- tmpulong = (unsigned long) str_gnum(st[2]);
- if (tmpulong == 0L)
- fatal("Illegal modulus zero");
-#ifndef lint
- value = str_gnum(st[1]);
- if (value >= 0.0)
- value = (double)(((unsigned long)value) % tmpulong);
- else {
- tmplong = (long)value;
- value = (double)(tmpulong - ((-tmplong - 1) % tmpulong)) - 1;
- }
-#endif
- goto donumset;
- case O_ADD:
- value = str_gnum(st[1]);
- value += str_gnum(st[2]);
- goto donumset;
- case O_SUBTRACT:
- value = str_gnum(st[1]);
- value -= str_gnum(st[2]);
- goto donumset;
- case O_LEFT_SHIFT:
- value = str_gnum(st[1]);
- anum = (int)str_gnum(st[2]);
-#ifndef lint
- value = (double)(U_L(value) << anum);
-#endif
- goto donumset;
- case O_RIGHT_SHIFT:
- value = str_gnum(st[1]);
- anum = (int)str_gnum(st[2]);
-#ifndef lint
- value = (double)(U_L(value) >> anum);
-#endif
- goto donumset;
- case O_LT:
- value = str_gnum(st[1]);
- value = (value < str_gnum(st[2])) ? 1.0 : 0.0;
- goto donumset;
- case O_GT:
- value = str_gnum(st[1]);
- value = (value > str_gnum(st[2])) ? 1.0 : 0.0;
- goto donumset;
- case O_LE:
- value = str_gnum(st[1]);
- value = (value <= str_gnum(st[2])) ? 1.0 : 0.0;
- goto donumset;
- case O_GE:
- value = str_gnum(st[1]);
- value = (value >= str_gnum(st[2])) ? 1.0 : 0.0;
- goto donumset;
- case O_EQ:
- if (dowarn) {
- if ((!st[1]->str_nok && !looks_like_number(st[1])) ||
- (!st[2]->str_nok && !looks_like_number(st[2])) )
- warn("Possible use of == on string value");
- }
- value = str_gnum(st[1]);
- value = (value == str_gnum(st[2])) ? 1.0 : 0.0;
- goto donumset;
- case O_NE:
- value = str_gnum(st[1]);
- value = (value != str_gnum(st[2])) ? 1.0 : 0.0;
- goto donumset;
- case O_NCMP:
- value = str_gnum(st[1]);
- value -= str_gnum(st[2]);
- if (value > 0.0)
- value = 1.0;
- else if (value < 0.0)
- value = -1.0;
- goto donumset;
- case O_BIT_AND:
- if (!sawvec || st[1]->str_nok || st[2]->str_nok) {
- value = str_gnum(st[1]);
-#ifndef lint
- value = (double)(U_L(value) & U_L(str_gnum(st[2])));
-#endif
- goto donumset;
- }
- else
- do_vop(optype,str,st[1],st[2]);
- break;
- case O_XOR:
- if (!sawvec || st[1]->str_nok || st[2]->str_nok) {
- value = str_gnum(st[1]);
-#ifndef lint
- value = (double)(U_L(value) ^ U_L(str_gnum(st[2])));
-#endif
- goto donumset;
- }
- else
- do_vop(optype,str,st[1],st[2]);
- break;
- case O_BIT_OR:
- if (!sawvec || st[1]->str_nok || st[2]->str_nok) {
- value = str_gnum(st[1]);
-#ifndef lint
- value = (double)(U_L(value) | U_L(str_gnum(st[2])));
-#endif
- goto donumset;
- }
- else
- do_vop(optype,str,st[1],st[2]);
- break;
-/* use register in evaluating str_true() */
- case O_AND:
- if (str_true(st[1])) {
- anum = 2;
- optype = O_ITEM2;
- argflags = arg[anum].arg_flags;
- if (gimme == G_ARRAY)
- argflags |= AF_ARYOK;
- argtype = arg[anum].arg_type & A_MASK;
- argptr = arg[anum].arg_ptr;
- maxarg = anum = 1;
- sp = arglast[0];
- st -= sp;
- goto re_eval;
- }
- else {
- if (assigning) {
- str_sset(str, st[1]);
- STABSET(str);
- }
- else
- str = st[1];
- break;
- }
- case O_OR:
- if (str_true(st[1])) {
- if (assigning) {
- str_sset(str, st[1]);
- STABSET(str);
- }
- else
- str = st[1];
- break;
- }
- else {
- anum = 2;
- optype = O_ITEM2;
- argflags = arg[anum].arg_flags;
- if (gimme == G_ARRAY)
- argflags |= AF_ARYOK;
- argtype = arg[anum].arg_type & A_MASK;
- argptr = arg[anum].arg_ptr;
- maxarg = anum = 1;
- sp = arglast[0];
- st -= sp;
- goto re_eval;
- }
- case O_COND_EXPR:
- anum = (str_true(st[1]) ? 2 : 3);
- optype = (anum == 2 ? O_ITEM2 : O_ITEM3);
- argflags = arg[anum].arg_flags;
- if (gimme == G_ARRAY)
- argflags |= AF_ARYOK;
- argtype = arg[anum].arg_type & A_MASK;
- argptr = arg[anum].arg_ptr;
- maxarg = anum = 1;
- sp = arglast[0];
- st -= sp;
- goto re_eval;
- case O_COMMA:
- if (gimme == G_ARRAY)
- goto array_return;
- str = st[2];
- break;
- case O_NEGATE:
- value = -str_gnum(st[1]);
- goto donumset;
- case O_NOT:
-#ifdef NOTNOT
- { char xxx = str_true(st[1]); value = (double) !xxx; }
-#else
- value = (double) !str_true(st[1]);
-#endif
- goto donumset;
- case O_COMPLEMENT:
- if (!sawvec || st[1]->str_nok) {
-#ifndef lint
- value = (double) ~U_L(str_gnum(st[1]));
-#endif
- goto donumset;
- }
- else {
- STR_SSET(str,st[1]);
- tmps = str_get(str);
- for (anum = str->str_cur; anum; anum--, tmps++)
- *tmps = ~*tmps;
- }
- break;
- case O_SELECT:
- stab_efullname(str,defoutstab);
- if (maxarg > 0) {
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- defoutstab = arg[1].arg_ptr.arg_stab;
- else
- defoutstab = stabent(str_get(st[1]),TRUE);
- if (!stab_io(defoutstab))
- stab_io(defoutstab) = stio_new();
- curoutstab = defoutstab;
- }
- STABSET(str);
- break;
- case O_WRITE:
- if (maxarg == 0)
- stab = defoutstab;
- else if ((arg[1].arg_type & A_MASK) == A_WORD) {
- if (!(stab = arg[1].arg_ptr.arg_stab))
- stab = defoutstab;
- }
- else
- stab = stabent(str_get(st[1]),TRUE);
- if (!stab_io(stab)) {
- str_set(str, No);
- STABSET(str);
- break;
- }
- curoutstab = stab;
- fp = stab_io(stab)->ofp;
- if (stab_io(stab)->fmt_stab)
- form = stab_form(stab_io(stab)->fmt_stab);
- else
- form = stab_form(stab);
- if (!form || !fp) {
- if (dowarn) {
- if (form)
- warn("No format for filehandle");
- else {
- if (stab_io(stab)->ifp)
- warn("Filehandle only opened for input");
- else
- warn("Write on closed filehandle");
- }
- }
- str_set(str, No);
- STABSET(str);
- break;
- }
- format(&outrec,form,sp);
- do_write(&outrec,stab,sp);
- if (stab_io(stab)->flags & IOF_FLUSH)
- (void)fflush(fp);
- str_set(str, Yes);
- STABSET(str);
- break;
- case O_DBMOPEN:
-#ifdef SOME_DBM
- anum = arg[1].arg_type & A_MASK;
- if (anum == A_WORD || anum == A_STAB)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- if (st[3]->str_nok || st[3]->str_pok)
- anum = (int)str_gnum(st[3]);
- else
- anum = -1;
- value = (double)hdbmopen(stab_hash(stab),str_get(st[2]),anum);
- goto donumset;
-#else
- fatal("No dbm or ndbm on this machine");
-#endif
- case O_DBMCLOSE:
-#ifdef SOME_DBM
- anum = arg[1].arg_type & A_MASK;
- if (anum == A_WORD || anum == A_STAB)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- hdbmclose(stab_hash(stab));
- goto say_yes;
-#else
- fatal("No dbm or ndbm on this machine");
-#endif
- case O_OPEN:
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- tmps = str_get(st[2]);
- if (do_open(stab,tmps,st[2]->str_cur)) {
- value = (double)forkprocess;
- stab_io(stab)->lines = 0;
- goto donumset;
- }
- else if (forkprocess == 0) /* we are a new child */
- goto say_zero;
- else
- goto say_undef;
- /* break; */
- case O_TRANS:
- value = (double) do_trans(str,arg);
- str = arg->arg_ptr.arg_str;
- goto donumset;
- case O_NTRANS:
- str_set(arg->arg_ptr.arg_str, do_trans(str,arg) == 0 ? Yes : No);
- str = arg->arg_ptr.arg_str;
- break;
- case O_CLOSE:
- if (maxarg == 0)
- stab = defoutstab;
- else if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- str_set(str, do_close(stab,TRUE) ? Yes : No );
- STABSET(str);
- break;
- case O_EACH:
- sp = do_each(str,stab_hash(arg[1].arg_ptr.arg_stab),
- gimme,arglast);
- goto array_return;
- case O_VALUES:
- case O_KEYS:
- sp = do_kv(str,stab_hash(arg[1].arg_ptr.arg_stab), optype,
- gimme,arglast);
- goto array_return;
- case O_LARRAY:
- str->str_nok = str->str_pok = 0;
- str->str_u.str_stab = arg[1].arg_ptr.arg_stab;
- str->str_state = SS_ARY;
- break;
- case O_ARRAY:
- ary = stab_array(arg[1].arg_ptr.arg_stab);
- maxarg = ary->ary_fill + 1;
- if (gimme == G_ARRAY) { /* array wanted */
- sp = arglast[0];
- st -= sp;
- if (maxarg > 0 && sp + maxarg > stack->ary_max) {
- astore(stack,sp + maxarg, Nullstr);
- st = stack->ary_array;
- }
- st += sp;
- Copy(ary->ary_array, &st[1], maxarg, STR*);
- sp += maxarg;
- goto array_return;
- }
- else {
- value = (double)maxarg;
- goto donumset;
- }
- case O_AELEM:
- anum = ((int)str_gnum(st[2])) - arybase;
- str = afetch(stab_array(arg[1].arg_ptr.arg_stab),anum,FALSE);
- break;
- case O_DELETE:
- tmpstab = arg[1].arg_ptr.arg_stab;
- tmps = str_get(st[2]);
- str = hdelete(stab_hash(tmpstab),tmps,st[2]->str_cur);
- if (tmpstab == envstab)
- my_setenv(tmps,Nullch);
- if (!str)
- goto say_undef;
- break;
- case O_LHASH:
- str->str_nok = str->str_pok = 0;
- str->str_u.str_stab = arg[1].arg_ptr.arg_stab;
- str->str_state = SS_HASH;
- break;
- case O_HASH:
- if (gimme == G_ARRAY) { /* array wanted */
- sp = do_kv(str,stab_hash(arg[1].arg_ptr.arg_stab), optype,
- gimme,arglast);
- goto array_return;
- }
- else {
- tmpstab = arg[1].arg_ptr.arg_stab;
- if (!stab_hash(tmpstab)->tbl_fill)
- goto say_zero;
- sprintf(buf,"%d/%d",stab_hash(tmpstab)->tbl_fill,
- stab_hash(tmpstab)->tbl_max+1);
- str_set(str,buf);
- }
- break;
- case O_HELEM:
- tmpstab = arg[1].arg_ptr.arg_stab;
- tmps = str_get(st[2]);
- str = hfetch(stab_hash(tmpstab),tmps,st[2]->str_cur,FALSE);
- break;
- case O_LAELEM:
- anum = ((int)str_gnum(st[2])) - arybase;
- str = afetch(stab_array(arg[1].arg_ptr.arg_stab),anum,TRUE);
- if (!str || str == &str_undef)
- fatal("Assignment to non-creatable value, subscript %d",anum);
- break;
- case O_LHELEM:
- tmpstab = arg[1].arg_ptr.arg_stab;
- tmps = str_get(st[2]);
- anum = st[2]->str_cur;
- str = hfetch(stab_hash(tmpstab),tmps,anum,TRUE);
- if (!str || str == &str_undef)
- fatal("Assignment to non-creatable value, subscript \"%s\"",tmps);
- if (tmpstab == envstab) /* heavy wizardry going on here */
- str_magic(str, tmpstab, 'E', tmps, anum); /* str is now magic */
- /* he threw the brick up into the air */
- else if (tmpstab == sigstab)
- str_magic(str, tmpstab, 'S', tmps, anum);
-#ifdef SOME_DBM
- else if (stab_hash(tmpstab)->tbl_dbm)
- str_magic(str, tmpstab, 'D', tmps, anum);
-#endif
- else if (tmpstab == DBline)
- str_magic(str, tmpstab, 'L', tmps, anum);
- break;
- case O_LSLICE:
- anum = 2;
- argtype = FALSE;
- goto do_slice_already;
- case O_ASLICE:
- anum = 1;
- argtype = FALSE;
- goto do_slice_already;
- case O_HSLICE:
- anum = 0;
- argtype = FALSE;
- goto do_slice_already;
- case O_LASLICE:
- anum = 1;
- argtype = TRUE;
- goto do_slice_already;
- case O_LHSLICE:
- anum = 0;
- argtype = TRUE;
- do_slice_already:
- sp = do_slice(arg[1].arg_ptr.arg_stab,str,anum,argtype,
- gimme,arglast);
- goto array_return;
- case O_SPLICE:
- sp = do_splice(stab_array(arg[1].arg_ptr.arg_stab),gimme,arglast);
- goto array_return;
- case O_PUSH:
- if (arglast[2] - arglast[1] != 1)
- str = do_push(stab_array(arg[1].arg_ptr.arg_stab),arglast);
- else {
- str = Str_new(51,0); /* must copy the STR */
- str_sset(str,st[2]);
- (void)apush(stab_array(arg[1].arg_ptr.arg_stab),str);
- }
- break;
- case O_POP:
- str = apop(ary = stab_array(arg[1].arg_ptr.arg_stab));
- goto staticalization;
- case O_SHIFT:
- str = ashift(ary = stab_array(arg[1].arg_ptr.arg_stab));
- staticalization:
- if (!str)
- goto say_undef;
- if (ary->ary_flags & ARF_REAL)
- (void)str_2mortal(str);
- break;
- case O_UNPACK:
- sp = do_unpack(str,gimme,arglast);
- goto array_return;
- case O_SPLIT:
- value = str_gnum(st[3]);
- sp = do_split(str, arg[2].arg_ptr.arg_spat, (int)value,
- gimme,arglast);
- goto array_return;
- case O_LENGTH:
- if (maxarg < 1)
- value = (double)str_len(stab_val(defstab));
- else
- value = (double)str_len(st[1]);
- goto donumset;
- case O_SPRINTF:
- do_sprintf(str, sp-arglast[0], st+1);
- break;
- case O_SUBSTR:
- anum = ((int)str_gnum(st[2])) - arybase; /* anum=where to start*/
- tmps = str_get(st[1]); /* force conversion to string */
- /*SUPPRESS 560*/
- if (argtype = (str == st[1]))
- str = arg->arg_ptr.arg_str;
- if (anum < 0)
- anum += st[1]->str_cur + arybase;
- if (anum < 0 || anum > st[1]->str_cur)
- str_nset(str,"",0);
- else {
- optype = maxarg < 3 ? st[1]->str_cur : (int)str_gnum(st[3]);
- if (optype < 0)
- optype = 0;
- tmps += anum;
- anum = st[1]->str_cur - anum; /* anum=how many bytes left*/
- if (anum > optype)
- anum = optype;
- str_nset(str, tmps, anum);
- if (argtype) { /* it's an lvalue! */
- Lstring *lstr = (Lstring*)str;
-
- str->str_magic = st[1];
- st[1]->str_rare = 's';
- lstr->lstr_offset = tmps - str_get(st[1]);
- lstr->lstr_len = anum;
- }
- }
- break;
- case O_PACK:
- /*SUPPRESS 701*/
- (void)do_pack(str,arglast);
- break;
- case O_GREP:
- sp = do_grep(arg,str,gimme,arglast);
- goto array_return;
- case O_JOIN:
- do_join(str,arglast);
- break;
- case O_SLT:
- tmps = str_get(st[1]);
- value = (double) (str_cmp(st[1],st[2]) < 0);
- goto donumset;
- case O_SGT:
- tmps = str_get(st[1]);
- value = (double) (str_cmp(st[1],st[2]) > 0);
- goto donumset;
- case O_SLE:
- tmps = str_get(st[1]);
- value = (double) (str_cmp(st[1],st[2]) <= 0);
- goto donumset;
- case O_SGE:
- tmps = str_get(st[1]);
- value = (double) (str_cmp(st[1],st[2]) >= 0);
- goto donumset;
- case O_SEQ:
- tmps = str_get(st[1]);
- value = (double) str_eq(st[1],st[2]);
- goto donumset;
- case O_SNE:
- tmps = str_get(st[1]);
- value = (double) !str_eq(st[1],st[2]);
- goto donumset;
- case O_SCMP:
- tmps = str_get(st[1]);
- value = (double) str_cmp(st[1],st[2]);
- goto donumset;
- case O_SUBR:
- sp = do_subr(arg,gimme,arglast);
- st = stack->ary_array + arglast[0]; /* maybe realloced */
- goto array_return;
- case O_DBSUBR:
- sp = do_subr(arg,gimme,arglast);
- st = stack->ary_array + arglast[0]; /* maybe realloced */
- goto array_return;
- case O_CALLER:
- sp = do_caller(arg,maxarg,gimme,arglast);
- st = stack->ary_array + arglast[0]; /* maybe realloced */
- goto array_return;
- case O_SORT:
- sp = do_sort(str,arg,
- gimme,arglast);
- goto array_return;
- case O_REVERSE:
- if (gimme == G_ARRAY)
- sp = do_reverse(arglast);
- else
- sp = do_sreverse(str, arglast);
- goto array_return;
- case O_WARN:
- if (arglast[2] - arglast[1] != 1) {
- do_join(str,arglast);
- tmps = str_get(str);
- }
- else {
- str = st[2];
- tmps = str_get(st[2]);
- }
- if (!tmps || !*tmps)
- tmps = "Warning: something's wrong";
- warn("%s",tmps);
- goto say_yes;
- case O_DIE:
- if (arglast[2] - arglast[1] != 1) {
- do_join(str,arglast);
- tmps = str_get(str);
- }
- else {
- str = st[2];
- tmps = str_get(st[2]);
- }
- if (!tmps || !*tmps)
- tmps = "Died";
- fatal("%s",tmps);
- goto say_zero;
- case O_PRTF:
- case O_PRINT:
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- if (!stab)
- stab = defoutstab;
- if (!stab_io(stab)) {
- if (dowarn)
- warn("Filehandle never opened");
- goto say_zero;
- }
- if (!(fp = stab_io(stab)->ofp)) {
- if (dowarn) {
- if (stab_io(stab)->ifp)
- warn("Filehandle opened only for input");
- else
- warn("Print on closed filehandle");
- }
- goto say_zero;
- }
- else {
- if (optype == O_PRTF || arglast[2] - arglast[1] != 1)
- value = (double)do_aprint(arg,fp,arglast);
- else {
- value = (double)do_print(st[2],fp);
- if (orslen && optype == O_PRINT)
- if (fwrite(ors, 1, orslen, fp) == 0)
- goto say_zero;
- }
- if (stab_io(stab)->flags & IOF_FLUSH)
- if (fflush(fp) == EOF)
- goto say_zero;
- }
- goto donumset;
- case O_CHDIR:
- if (maxarg < 1)
- tmps = Nullch;
- else
- tmps = str_get(st[1]);
- if (!tmps || !*tmps) {
- tmpstr = hfetch(stab_hash(envstab),"HOME",4,FALSE);
- tmps = str_get(tmpstr);
- }
- if (!tmps || !*tmps) {
- tmpstr = hfetch(stab_hash(envstab),"LOGDIR",6,FALSE);
- tmps = str_get(tmpstr);
- }
-#ifdef TAINT
- TAINT_PROPER("chdir");
-#endif
- value = (double)(chdir(tmps) >= 0);
- goto donumset;
- case O_EXIT:
- if (maxarg < 1)
- anum = 0;
- else
- anum = (int)str_gnum(st[1]);
- my_exit(anum);
- goto say_zero;
- case O_RESET:
- if (maxarg < 1)
- tmps = "";
- else
- tmps = str_get(st[1]);
- str_reset(tmps,curcmd->c_stash);
- value = 1.0;
- goto donumset;
- case O_LIST:
- if (gimme == G_ARRAY)
- goto array_return;
- if (maxarg > 0)
- str = st[sp - arglast[0]]; /* unwanted list, return last item */
- else
- str = &str_undef;
- break;
- case O_EOF:
- if (maxarg <= 0)
- stab = last_in_stab;
- else if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- str_set(str, do_eof(stab) ? Yes : No);
- STABSET(str);
- break;
- case O_GETC:
- if (maxarg <= 0)
- stab = stdinstab;
- else if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- if (!stab)
- stab = argvstab;
- if (!stab || do_eof(stab)) /* make sure we have fp with something */
- goto say_undef;
- else {
-#ifdef TAINT
- tainted = 1;
-#endif
- str_set(str," ");
- *str->str_ptr = getc(stab_io(stab)->ifp); /* should never be EOF */
- }
- STABSET(str);
- break;
- case O_TELL:
- if (maxarg <= 0)
- stab = last_in_stab;
- else if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
-#ifndef lint
- value = (double)do_tell(stab);
-#else
- (void)do_tell(stab);
-#endif
- goto donumset;
- case O_RECV:
- case O_READ:
- case O_SYSREAD:
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- tmps = str_get(st[2]);
- anum = (int)str_gnum(st[3]);
- errno = 0;
- maxarg = sp - arglast[0];
- if (maxarg > 4)
- warn("Too many args on read");
- if (maxarg == 4)
- maxarg = (int)str_gnum(st[4]);
- else
- maxarg = 0;
- if (!stab_io(stab) || !stab_io(stab)->ifp)
- goto say_undef;
-#ifdef HAS_SOCKET
- if (optype == O_RECV) {
- argtype = sizeof buf;
- STR_GROW(st[2], anum+1), (tmps = str_get(st[2])); /* sneaky */
- anum = recvfrom(fileno(stab_io(stab)->ifp), tmps, anum, maxarg,
- buf, &argtype);
- if (anum >= 0) {
- st[2]->str_cur = anum;
- st[2]->str_ptr[anum] = '\0';
- str_nset(str,buf,argtype);
- }
- else
- str_sset(str,&str_undef);
- break;
- }
-#else
- if (optype == O_RECV)
- goto badsock;
-#endif
- STR_GROW(st[2], anum+maxarg+1), (tmps = str_get(st[2])); /* sneaky */
- if (optype == O_SYSREAD) {
- anum = read(fileno(stab_io(stab)->ifp), tmps+maxarg, anum);
- }
- else
-#ifdef HAS_SOCKET
- if (stab_io(stab)->type == 's') {
- argtype = sizeof buf;
- anum = recvfrom(fileno(stab_io(stab)->ifp), tmps+maxarg, anum, 0,
- buf, &argtype);
- }
- else
-#endif
- anum = fread(tmps+maxarg, 1, anum, stab_io(stab)->ifp);
- if (anum < 0)
- goto say_undef;
- st[2]->str_cur = anum+maxarg;
- st[2]->str_ptr[anum+maxarg] = '\0';
- value = (double)anum;
- goto donumset;
- case O_SYSWRITE:
- case O_SEND:
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- tmps = str_get(st[2]);
- anum = (int)str_gnum(st[3]);
- errno = 0;
- stio = stab_io(stab);
- maxarg = sp - arglast[0];
- if (!stio || !stio->ifp) {
- anum = -1;
- if (dowarn) {
- if (optype == O_SYSWRITE)
- warn("Syswrite on closed filehandle");
- else
- warn("Send on closed socket");
- }
- }
- else if (optype == O_SYSWRITE) {
- if (maxarg > 4)
- warn("Too many args on syswrite");
- if (maxarg == 4)
- optype = (int)str_gnum(st[4]);
- else
- optype = 0;
- anum = write(fileno(stab_io(stab)->ifp), tmps+optype, anum);
- }
-#ifdef HAS_SOCKET
- else if (maxarg >= 4) {
- if (maxarg > 4)
- warn("Too many args on send");
- tmps2 = str_get(st[4]);
- anum = sendto(fileno(stab_io(stab)->ifp), tmps, st[2]->str_cur,
- anum, tmps2, st[4]->str_cur);
- }
- else
- anum = send(fileno(stab_io(stab)->ifp), tmps, st[2]->str_cur, anum);
-#else
- else
- goto badsock;
-#endif
- if (anum < 0)
- goto say_undef;
- value = (double)anum;
- goto donumset;
- case O_SEEK:
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- value = str_gnum(st[2]);
- str_set(str, do_seek(stab,
- (long)value, (int)str_gnum(st[3]) ) ? Yes : No);
- STABSET(str);
- break;
- case O_RETURN:
- tmps = "_SUB_"; /* just fake up a "last _SUB_" */
- optype = O_LAST;
- if (curcsv && curcsv->wantarray == G_ARRAY) {
- lastretstr = Nullstr;
- lastspbase = arglast[1];
- lastsize = arglast[2] - arglast[1];
- }
- else
- lastretstr = str_mortal(st[arglast[2] - arglast[0]]);
- goto dopop;
- case O_REDO:
- case O_NEXT:
- case O_LAST:
- tmps = Nullch;
- if (maxarg > 0) {
- tmps = str_get(arg[1].arg_ptr.arg_str);
- dopop:
- while (loop_ptr >= 0 && (!loop_stack[loop_ptr].loop_label ||
- strNE(tmps,loop_stack[loop_ptr].loop_label) )) {
-#ifdef DEBUGGING
- if (debug & 4) {
- deb("(Skipping label #%d %s)\n",loop_ptr,
- loop_stack[loop_ptr].loop_label);
- }
-#endif
- loop_ptr--;
- }
-#ifdef DEBUGGING
- if (debug & 4) {
- deb("(Found label #%d %s)\n",loop_ptr,
- loop_stack[loop_ptr].loop_label);
- }
-#endif
- }
- if (loop_ptr < 0) {
- if (tmps && strEQ(tmps, "_SUB_"))
- fatal("Can't return outside a subroutine");
- fatal("Bad label: %s", maxarg > 0 ? tmps : "<null>");
- }
- if (!lastretstr && optype == O_LAST && lastsize) {
- st -= arglast[0];
- st += lastspbase + 1;
- optype = loop_stack[loop_ptr].loop_sp - lastspbase; /* negative */
- if (optype) {
- for (anum = lastsize; anum > 0; anum--,st++)
- st[optype] = str_mortal(st[0]);
- }
- longjmp(loop_stack[loop_ptr].loop_env, O_LAST);
- }
- longjmp(loop_stack[loop_ptr].loop_env, optype);
- case O_DUMP:
- case O_GOTO:/* shudder */
- goto_targ = str_get(arg[1].arg_ptr.arg_str);
- if (!*goto_targ)
- goto_targ = Nullch; /* just restart from top */
- if (optype == O_DUMP) {
- do_undump = TRUE;
- my_unexec();
- }
- longjmp(top_env, 1);
- case O_INDEX:
- tmps = str_get(st[1]);
- if (maxarg < 3)
- anum = 0;
- else {
- anum = (int) str_gnum(st[3]) - arybase;
- if (anum < 0)
- anum = 0;
- else if (anum > st[1]->str_cur)
- anum = st[1]->str_cur;
- }
-#ifndef lint
- if (!(tmps2 = fbminstr((unsigned char*)tmps + anum,
- (unsigned char*)tmps + st[1]->str_cur, st[2])))
-#else
- if (tmps2 = fbminstr(Null(unsigned char*),Null(unsigned char*),Nullstr))
-#endif
- value = (double)(-1 + arybase);
- else
- value = (double)(tmps2 - tmps + arybase);
- goto donumset;
- case O_RINDEX:
- tmps = str_get(st[1]);
- tmps2 = str_get(st[2]);
- if (maxarg < 3)
- anum = st[1]->str_cur;
- else {
- anum = (int) str_gnum(st[3]) - arybase + st[2]->str_cur;
- if (anum < 0)
- anum = 0;
- else if (anum > st[1]->str_cur)
- anum = st[1]->str_cur;
- }
-#ifndef lint
- if (!(tmps2 = rninstr(tmps, tmps + anum,
- tmps2, tmps2 + st[2]->str_cur)))
-#else
- if (tmps2 = rninstr(Nullch,Nullch,Nullch,Nullch))
-#endif
- value = (double)(-1 + arybase);
- else
- value = (double)(tmps2 - tmps + arybase);
- goto donumset;
- case O_TIME:
-#ifndef lint
- value = (double) time(Null(long*));
-#endif
- goto donumset;
- case O_TMS:
- sp = do_tms(str,gimme,arglast);
- goto array_return;
- case O_LOCALTIME:
- if (maxarg < 1)
- (void)time(&when);
- else
- when = (time_t)str_gnum(st[1]);
- sp = do_time(str,localtime(&when),
- gimme,arglast);
- goto array_return;
- case O_GMTIME:
- if (maxarg < 1)
- (void)time(&when);
- else
- when = (time_t)str_gnum(st[1]);
- sp = do_time(str,gmtime(&when),
- gimme,arglast);
- goto array_return;
- case O_TRUNCATE:
- sp = do_truncate(str,arg,
- gimme,arglast);
- goto array_return;
- case O_LSTAT:
- case O_STAT:
- sp = do_stat(str,arg,
- gimme,arglast);
- goto array_return;
- case O_CRYPT:
-#ifdef HAS_CRYPT
- tmps = str_get(st[1]);
-#ifdef FCRYPT
- str_set(str,fcrypt(tmps,str_get(st[2])));
-#else
- str_set(str,crypt(tmps,str_get(st[2])));
-#endif
-#else
- fatal(
- "The crypt() function is unimplemented due to excessive paranoia.");
-#endif
- break;
- case O_ATAN2:
- value = str_gnum(st[1]);
- value = atan2(value,str_gnum(st[2]));
- goto donumset;
- case O_SIN:
- if (maxarg < 1)
- value = str_gnum(stab_val(defstab));
- else
- value = str_gnum(st[1]);
- value = sin(value);
- goto donumset;
- case O_COS:
- if (maxarg < 1)
- value = str_gnum(stab_val(defstab));
- else
- value = str_gnum(st[1]);
- value = cos(value);
- goto donumset;
- case O_RAND:
- if (maxarg < 1)
- value = 1.0;
- else
- value = str_gnum(st[1]);
- if (value == 0.0)
- value = 1.0;
-#if RANDBITS == 31
- value = rand() * value / 2147483648.0;
-#else
-#if RANDBITS == 16
- value = rand() * value / 65536.0;
-#else
-#if RANDBITS == 15
- value = rand() * value / 32768.0;
-#else
- value = rand() * value / (double)(((unsigned long)1) << RANDBITS);
-#endif
-#endif
-#endif
- goto donumset;
- case O_SRAND:
- if (maxarg < 1) {
- (void)time(&when);
- anum = when;
- }
- else
- anum = (int)str_gnum(st[1]);
- (void)srand(anum);
- goto say_yes;
- case O_EXP:
- if (maxarg < 1)
- value = str_gnum(stab_val(defstab));
- else
- value = str_gnum(st[1]);
- value = exp(value);
- goto donumset;
- case O_LOG:
- if (maxarg < 1)
- value = str_gnum(stab_val(defstab));
- else
- value = str_gnum(st[1]);
- if (value <= 0.0)
- fatal("Can't take log of %g\n", value);
- value = log(value);
- goto donumset;
- case O_SQRT:
- if (maxarg < 1)
- value = str_gnum(stab_val(defstab));
- else
- value = str_gnum(st[1]);
- if (value < 0.0)
- fatal("Can't take sqrt of %g\n", value);
- value = sqrt(value);
- goto donumset;
- case O_INT:
- if (maxarg < 1)
- value = str_gnum(stab_val(defstab));
- else
- value = str_gnum(st[1]);
- if (value >= 0.0)
- (void)modf(value,&value);
- else {
- (void)modf(-value,&value);
- value = -value;
- }
- goto donumset;
- case O_ORD:
- if (maxarg < 1)
- tmps = str_get(stab_val(defstab));
- else
- tmps = str_get(st[1]);
-#ifndef I286
- value = (double) (*tmps & 255);
-#else
- anum = (int) *tmps;
- value = (double) (anum & 255);
-#endif
- goto donumset;
- case O_ALARM:
-#ifdef HAS_ALARM
- if (maxarg < 1)
- tmps = str_get(stab_val(defstab));
- else
- tmps = str_get(st[1]);
- if (!tmps)
- tmps = "0";
- anum = alarm((unsigned int)atoi(tmps));
- if (anum < 0)
- goto say_undef;
- value = (double)anum;
- goto donumset;
-#else
- fatal("Unsupported function alarm");
- break;
-#endif
- case O_SLEEP:
- if (maxarg < 1)
- tmps = Nullch;
- else
- tmps = str_get(st[1]);
- (void)time(&when);
- if (!tmps || !*tmps)
- sleep((32767<<16)+32767);
- else
- sleep((unsigned int)atoi(tmps));
-#ifndef lint
- value = (double)when;
- (void)time(&when);
- value = ((double)when) - value;
-#endif
- goto donumset;
- case O_RANGE:
- sp = do_range(gimme,arglast);
- goto array_return;
- case O_F_OR_R:
- if (gimme == G_ARRAY) { /* it's a range */
- /* can we optimize to constant array? */
- if ((arg[1].arg_type & A_MASK) == A_SINGLE &&
- (arg[2].arg_type & A_MASK) == A_SINGLE) {
- st[2] = arg[2].arg_ptr.arg_str;
- sp = do_range(gimme,arglast);
- st = stack->ary_array;
- maxarg = sp - arglast[0];
- str_free(arg[1].arg_ptr.arg_str);
- arg[1].arg_ptr.arg_str = Nullstr;
- str_free(arg[2].arg_ptr.arg_str);
- arg[2].arg_ptr.arg_str = Nullstr;
- arg->arg_type = O_ARRAY;
- arg[1].arg_type = A_STAB|A_DONT;
- arg->arg_len = 1;
- stab = arg[1].arg_ptr.arg_stab = aadd(genstab());
- ary = stab_array(stab);
- afill(ary,maxarg - 1);
- anum = maxarg;
- st += arglast[0]+1;
- while (maxarg-- > 0)
- ary->ary_array[maxarg] = str_smake(st[maxarg]);
- st -= arglast[0]+1;
- goto array_return;
- }
- arg->arg_type = optype = O_RANGE;
- maxarg = arg->arg_len = 2;
- anum = 2;
- arg[anum].arg_flags &= ~AF_ARYOK;
- argflags = arg[anum].arg_flags;
- argtype = arg[anum].arg_type & A_MASK;
- arg[anum].arg_type = argtype;
- argptr = arg[anum].arg_ptr;
- sp = arglast[0];
- st -= sp;
- sp++;
- goto re_eval;
- }
- arg->arg_type = O_FLIP;
- /* FALL THROUGH */
- case O_FLIP:
- if ((arg[1].arg_type & A_MASK) == A_SINGLE ?
- last_in_stab && (int)str_gnum(st[1]) == stab_io(last_in_stab)->lines
- :
- str_true(st[1]) ) {
- arg[2].arg_type &= ~A_DONT;
- arg[1].arg_type |= A_DONT;
- arg->arg_type = optype = O_FLOP;
- if (arg->arg_flags & AF_COMMON) {
- str_numset(str,0.0);
- anum = 2;
- argflags = arg[2].arg_flags;
- argtype = arg[2].arg_type & A_MASK;
- argptr = arg[2].arg_ptr;
- sp = arglast[0];
- st -= sp++;
- goto re_eval;
- }
- else {
- str_numset(str,1.0);
- break;
- }
- }
- str_set(str,"");
- break;
- case O_FLOP:
- str_inc(str);
- if ((arg[2].arg_type & A_MASK) == A_SINGLE ?
- last_in_stab && (int)str_gnum(st[2]) == stab_io(last_in_stab)->lines
- :
- str_true(st[2]) ) {
- arg->arg_type = O_FLIP;
- arg[1].arg_type &= ~A_DONT;
- arg[2].arg_type |= A_DONT;
- str_cat(str,"E0");
- }
- break;
- case O_FORK:
-#ifdef HAS_FORK
- anum = fork();
- if (anum < 0)
- goto say_undef;
- if (!anum) {
- /*SUPPRESS 560*/
- if (tmpstab = stabent("$",allstabs))
- str_numset(STAB_STR(tmpstab),(double)getpid());
- hclear(pidstatus, FALSE); /* no kids, so don't wait for 'em */
- }
- value = (double)anum;
- goto donumset;
-#else
- fatal("Unsupported function fork");
- break;
-#endif
- case O_WAIT:
-#ifdef HAS_WAIT
-#ifndef lint
- anum = wait(&argflags);
- if (anum > 0)
- pidgone(anum,argflags);
- value = (double)anum;
-#endif
- statusvalue = (unsigned short)argflags;
- goto donumset;
-#else
- fatal("Unsupported function wait");
- break;
-#endif
- case O_WAITPID:
-#ifdef HAS_WAIT
-#ifndef lint
- anum = (int)str_gnum(st[1]);
- optype = (int)str_gnum(st[2]);
- anum = wait4pid(anum, &argflags,optype);
- value = (double)anum;
-#endif
- statusvalue = (unsigned short)argflags;
- goto donumset;
-#else
- fatal("Unsupported function wait");
- break;
-#endif
- case O_SYSTEM:
-#ifdef HAS_FORK
-#ifdef TAINT
- if (arglast[2] - arglast[1] == 1) {
- taintenv();
- tainted |= st[2]->str_tainted;
- TAINT_PROPER("system");
- }
-#endif
- while ((anum = vfork()) == -1) {
- if (errno != EAGAIN) {
- value = -1.0;
- goto donumset;
- }
- sleep(5);
- }
- if (anum > 0) {
-#ifndef lint
- ihand = signal(SIGINT, SIG_IGN);
- qhand = signal(SIGQUIT, SIG_IGN);
- argtype = wait4pid(anum, &argflags, 0);
-#else
- ihand = qhand = 0;
-#endif
- (void)signal(SIGINT, ihand);
- (void)signal(SIGQUIT, qhand);
- statusvalue = (unsigned short)argflags;
- if (argtype < 0)
- value = -1.0;
- else {
- value = (double)((unsigned int)argflags & 0xffff);
- }
- do_execfree(); /* free any memory child malloced on vfork */
- goto donumset;
- }
- if ((arg[1].arg_type & A_MASK) == A_STAB)
- value = (double)do_aexec(st[1],arglast);
- else if (arglast[2] - arglast[1] != 1)
- value = (double)do_aexec(Nullstr,arglast);
- else {
- value = (double)do_exec(str_get(str_mortal(st[2])));
- }
- _exit(-1);
-#else /* ! FORK */
- if ((arg[1].arg_type & A_MASK) == A_STAB)
- value = (double)do_aspawn(st[1],arglast);
- else if (arglast[2] - arglast[1] != 1)
- value = (double)do_aspawn(Nullstr,arglast);
- else {
- value = (double)do_spawn(str_get(str_mortal(st[2])));
- }
- goto donumset;
-#endif /* FORK */
- case O_EXEC_OP:
- if ((arg[1].arg_type & A_MASK) == A_STAB)
- value = (double)do_aexec(st[1],arglast);
- else if (arglast[2] - arglast[1] != 1)
- value = (double)do_aexec(Nullstr,arglast);
- else {
-#ifdef TAINT
- taintenv();
- tainted |= st[2]->str_tainted;
- TAINT_PROPER("exec");
-#endif
- value = (double)do_exec(str_get(str_mortal(st[2])));
- }
- goto donumset;
- case O_HEX:
- if (maxarg < 1)
- tmps = str_get(stab_val(defstab));
- else
- tmps = str_get(st[1]);
- value = (double)scanhex(tmps, 99, &argtype);
- goto donumset;
-
- case O_OCT:
- if (maxarg < 1)
- tmps = str_get(stab_val(defstab));
- else
- tmps = str_get(st[1]);
- while (*tmps && (isSPACE(*tmps) || *tmps == '0'))
- tmps++;
- if (*tmps == 'x')
- value = (double)scanhex(++tmps, 99, &argtype);
- else
- value = (double)scanoct(tmps, 99, &argtype);
- goto donumset;
-
-/* These common exits are hidden here in the middle of the switches for the
- benefit of those machines with limited branch addressing. Sigh. */
-
-array_return:
-#ifdef DEBUGGING
- if (debug) {
- dlevel--;
- if (debug & 8) {
- anum = sp - arglast[0];
- switch (anum) {
- case 0:
- deb("%s RETURNS ()\n",opname[optype]);
- break;
- case 1:
- deb("%s RETURNS (\"%s\")\n",opname[optype],
- st[1] ? str_get(st[1]) : "");
- break;
- default:
- tmps = st[1] ? str_get(st[1]) : "";
- deb("%s RETURNS %d ARGS (\"%s\",%s\"%s\")\n",opname[optype],
- anum,tmps,anum==2?"":"...,",
- st[anum] ? str_get(st[anum]) : "");
- break;
- }
- }
- }
-#endif
- stack_ary = stack->ary_array;
- stack_max = stack_ary + stack->ary_max;
- stack_sp = stack_ary + sp;
- return sp;
-
-say_yes:
- str = &str_yes;
- goto normal_return;
-
-say_no:
- str = &str_no;
- goto normal_return;
-
-say_undef:
- str = &str_undef;
- goto normal_return;
-
-say_zero:
- value = 0.0;
- /* FALL THROUGH */
-
-donumset:
- str_numset(str,value);
- STABSET(str);
- st[1] = str;
-#ifdef DEBUGGING
- if (debug) {
- dlevel--;
- if (debug & 8)
- deb("%s RETURNS \"%f\"\n",opname[optype],value);
- }
-#endif
- stack_ary = stack->ary_array;
- stack_max = stack_ary + stack->ary_max;
- stack_sp = stack_ary + arglast[0] + 1;
- return arglast[0] + 1;
-#ifdef SMALLSWITCHES
- }
- else
- switch (optype) {
-#endif
- case O_CHOWN:
-#ifdef HAS_CHOWN
- value = (double)apply(optype,arglast);
- goto donumset;
-#else
- fatal("Unsupported function chown");
- break;
-#endif
- case O_KILL:
-#ifdef HAS_KILL
- value = (double)apply(optype,arglast);
- goto donumset;
-#else
- fatal("Unsupported function kill");
- break;
-#endif
- case O_UNLINK:
- case O_CHMOD:
- case O_UTIME:
- value = (double)apply(optype,arglast);
- goto donumset;
- case O_UMASK:
-#ifdef HAS_UMASK
- if (maxarg < 1) {
- anum = umask(0);
- (void)umask(anum);
- }
- else
- anum = umask((int)str_gnum(st[1]));
- value = (double)anum;
-#ifdef TAINT
- TAINT_PROPER("umask");
-#endif
- goto donumset;
-#else
- fatal("Unsupported function umask");
- break;
-#endif
-#if defined(HAS_MSG) || defined(HAS_SEM) || defined(HAS_SHM)
- case O_MSGGET:
- case O_SHMGET:
- case O_SEMGET:
- if ((anum = do_ipcget(optype, arglast)) == -1)
- goto say_undef;
- value = (double)anum;
- goto donumset;
- case O_MSGCTL:
- case O_SHMCTL:
- case O_SEMCTL:
- anum = do_ipcctl(optype, arglast);
- if (anum == -1)
- goto say_undef;
- if (anum != 0) {
- value = (double)anum;
- goto donumset;
- }
- str_set(str,"0 but true");
- STABSET(str);
- break;
- case O_MSGSND:
- value = (double)(do_msgsnd(arglast) >= 0);
- goto donumset;
- case O_MSGRCV:
- value = (double)(do_msgrcv(arglast) >= 0);
- goto donumset;
- case O_SEMOP:
- value = (double)(do_semop(arglast) >= 0);
- goto donumset;
- case O_SHMREAD:
- case O_SHMWRITE:
- value = (double)(do_shmio(optype, arglast) >= 0);
- goto donumset;
-#else /* not SYSVIPC */
- case O_MSGGET:
- case O_MSGCTL:
- case O_MSGSND:
- case O_MSGRCV:
- case O_SEMGET:
- case O_SEMCTL:
- case O_SEMOP:
- case O_SHMGET:
- case O_SHMCTL:
- case O_SHMREAD:
- case O_SHMWRITE:
- fatal("System V IPC is not implemented on this machine");
-#endif /* not SYSVIPC */
- case O_RENAME:
- tmps = str_get(st[1]);
- tmps2 = str_get(st[2]);
-#ifdef TAINT
- TAINT_PROPER("rename");
-#endif
-#ifdef HAS_RENAME
- value = (double)(rename(tmps,tmps2) >= 0);
-#else
- if (same_dirent(tmps2, tmps)) /* can always rename to same name */
- anum = 1;
- else {
- if (euid || stat(tmps2,&statbuf) < 0 || !S_ISDIR(statbuf.st_mode))
- (void)UNLINK(tmps2);
- if (!(anum = link(tmps,tmps2)))
- anum = UNLINK(tmps);
- }
- value = (double)(anum >= 0);
-#endif
- goto donumset;
- case O_LINK:
-#ifdef HAS_LINK
- tmps = str_get(st[1]);
- tmps2 = str_get(st[2]);
-#ifdef TAINT
- TAINT_PROPER("link");
-#endif
- value = (double)(link(tmps,tmps2) >= 0);
- goto donumset;
-#else
- fatal("Unsupported function link");
- break;
-#endif
- case O_MKDIR:
- tmps = str_get(st[1]);
- anum = (int)str_gnum(st[2]);
-#ifdef TAINT
- TAINT_PROPER("mkdir");
-#endif
-#ifdef HAS_MKDIR
- value = (double)(mkdir(tmps,anum) >= 0);
- goto donumset;
-#else
- (void)strcpy(buf,"mkdir ");
-#endif
-#if !defined(HAS_MKDIR) || !defined(HAS_RMDIR)
- one_liner:
- for (tmps2 = buf+6; *tmps; ) {
- *tmps2++ = '\\';
- *tmps2++ = *tmps++;
- }
- (void)strcpy(tmps2," 2>&1");
- rsfp = mypopen(buf,"r");
- if (rsfp) {
- *buf = '\0';
- tmps2 = fgets(buf,sizeof buf,rsfp);
- (void)mypclose(rsfp);
- if (tmps2 != Nullch) {
- for (errno = 1; errno < sys_nerr; errno++) {
- if (instr(buf,sys_errlist[errno])) /* you don't see this */
- goto say_zero;
- }
- errno = 0;
-#ifndef EACCES
-#define EACCES EPERM
-#endif
- if (instr(buf,"cannot make"))
- errno = EEXIST;
- else if (instr(buf,"existing file"))
- errno = EEXIST;
- else if (instr(buf,"ile exists"))
- errno = EEXIST;
- else if (instr(buf,"non-exist"))
- errno = ENOENT;
- else if (instr(buf,"does not exist"))
- errno = ENOENT;
- else if (instr(buf,"not empty"))
- errno = EBUSY;
- else if (instr(buf,"cannot access"))
- errno = EACCES;
- else
- errno = EPERM;
- goto say_zero;
- }
- else { /* some mkdirs return no failure indication */
- tmps = str_get(st[1]);
- anum = (stat(tmps,&statbuf) >= 0);
- if (optype == O_RMDIR)
- anum = !anum;
- if (anum)
- errno = 0;
- else
- errno = EACCES; /* a guess */
- value = (double)anum;
- }
- goto donumset;
- }
- else
- goto say_zero;
-#endif
- case O_RMDIR:
- if (maxarg < 1)
- tmps = str_get(stab_val(defstab));
- else
- tmps = str_get(st[1]);
-#ifdef TAINT
- TAINT_PROPER("rmdir");
-#endif
-#ifdef HAS_RMDIR
- value = (double)(rmdir(tmps) >= 0);
- goto donumset;
-#else
- (void)strcpy(buf,"rmdir ");
- goto one_liner; /* see above in HAS_MKDIR */
-#endif
- case O_GETPPID:
-#ifdef HAS_GETPPID
- value = (double)getppid();
- goto donumset;
-#else
- fatal("Unsupported function getppid");
- break;
-#endif
- case O_GETPGRP:
-#ifdef HAS_GETPGRP
- if (maxarg < 1)
- anum = 0;
- else
- anum = (int)str_gnum(st[1]);
-#ifdef _POSIX_SOURCE
- if (anum != 0)
- fatal("POSIX getpgrp can't take an argument");
- value = (double)getpgrp();
-#else
- value = (double)getpgrp(anum);
-#endif
- goto donumset;
-#else
- fatal("The getpgrp() function is unimplemented on this machine");
- break;
-#endif
- case O_SETPGRP:
-#ifdef HAS_SETPGRP
- argtype = (int)str_gnum(st[1]);
- anum = (int)str_gnum(st[2]);
-#ifdef TAINT
- TAINT_PROPER("setpgrp");
-#endif
- value = (double)(setpgrp(argtype,anum) >= 0);
- goto donumset;
-#else
- fatal("The setpgrp() function is unimplemented on this machine");
- break;
-#endif
- case O_GETPRIORITY:
-#ifdef HAS_GETPRIORITY
- argtype = (int)str_gnum(st[1]);
- anum = (int)str_gnum(st[2]);
- value = (double)getpriority(argtype,anum);
- goto donumset;
-#else
- fatal("The getpriority() function is unimplemented on this machine");
- break;
-#endif
- case O_SETPRIORITY:
-#ifdef HAS_SETPRIORITY
- argtype = (int)str_gnum(st[1]);
- anum = (int)str_gnum(st[2]);
- optype = (int)str_gnum(st[3]);
-#ifdef TAINT
- TAINT_PROPER("setpriority");
-#endif
- value = (double)(setpriority(argtype,anum,optype) >= 0);
- goto donumset;
-#else
- fatal("The setpriority() function is unimplemented on this machine");
- break;
-#endif
- case O_CHROOT:
-#ifdef HAS_CHROOT
- if (maxarg < 1)
- tmps = str_get(stab_val(defstab));
- else
- tmps = str_get(st[1]);
-#ifdef TAINT
- TAINT_PROPER("chroot");
-#endif
- value = (double)(chroot(tmps) >= 0);
- goto donumset;
-#else
- fatal("Unsupported function chroot");
- break;
-#endif
- case O_FCNTL:
- case O_IOCTL:
- if (maxarg <= 0)
- stab = last_in_stab;
- else if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- argtype = U_I(str_gnum(st[2]));
-#ifdef TAINT
- TAINT_PROPER("ioctl");
-#endif
- anum = do_ctl(optype,stab,argtype,st[3]);
- if (anum == -1)
- goto say_undef;
- if (anum != 0) {
- value = (double)anum;
- goto donumset;
- }
- str_set(str,"0 but true");
- STABSET(str);
- break;
- case O_FLOCK:
-#ifdef HAS_FLOCK
- if (maxarg <= 0)
- stab = last_in_stab;
- else if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- if (stab && stab_io(stab))
- fp = stab_io(stab)->ifp;
- else
- fp = Nullfp;
- if (fp) {
- argtype = (int)str_gnum(st[2]);
- value = (double)(flock(fileno(fp),argtype) >= 0);
- }
- else
- value = 0;
- goto donumset;
-#else
- fatal("The flock() function is unimplemented on this machine");
- break;
-#endif
- case O_UNSHIFT:
- ary = stab_array(arg[1].arg_ptr.arg_stab);
- if (arglast[2] - arglast[1] != 1)
- do_unshift(ary,arglast);
- else {
- STR *tmpstr = Str_new(52,0); /* must copy the STR */
- str_sset(tmpstr,st[2]);
- aunshift(ary,1);
- (void)astore(ary,0,tmpstr);
- }
- value = (double)(ary->ary_fill + 1);
- goto donumset;
-
- case O_TRY:
- sp = do_try(arg[1].arg_ptr.arg_cmd,
- gimme,arglast);
- goto array_return;
-
- case O_EVALONCE:
- sp = do_eval(st[1], O_EVAL, curcmd->c_stash, TRUE,
- gimme,arglast);
- if (eval_root) {
- str_free(arg[1].arg_ptr.arg_str);
- arg[1].arg_ptr.arg_cmd = eval_root;
- arg[1].arg_type = (A_CMD|A_DONT);
- arg[0].arg_type = O_TRY;
- }
- goto array_return;
-
- case O_REQUIRE:
- case O_DOFILE:
- case O_EVAL:
- if (maxarg < 1)
- tmpstr = stab_val(defstab);
- else
- tmpstr =
- (arg[1].arg_type & A_MASK) != A_NULL ? st[1] : stab_val(defstab);
-#ifdef TAINT
- tainted |= tmpstr->str_tainted;
- TAINT_PROPER("eval");
-#endif
- sp = do_eval(tmpstr, optype, curcmd->c_stash, FALSE,
- gimme,arglast);
- goto array_return;
-
- case O_FTRREAD:
- argtype = 0;
- anum = S_IRUSR;
- goto check_perm;
- case O_FTRWRITE:
- argtype = 0;
- anum = S_IWUSR;
- goto check_perm;
- case O_FTREXEC:
- argtype = 0;
- anum = S_IXUSR;
- goto check_perm;
- case O_FTEREAD:
- argtype = 1;
- anum = S_IRUSR;
- goto check_perm;
- case O_FTEWRITE:
- argtype = 1;
- anum = S_IWUSR;
- goto check_perm;
- case O_FTEEXEC:
- argtype = 1;
- anum = S_IXUSR;
- check_perm:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- if (cando(anum,argtype,&statcache))
- goto say_yes;
- goto say_no;
-
- case O_FTIS:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- goto say_yes;
- case O_FTEOWNED:
- case O_FTROWNED:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- if (statcache.st_uid == (optype == O_FTEOWNED ? euid : uid) )
- goto say_yes;
- goto say_no;
- case O_FTZERO:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- if (!statcache.st_size)
- goto say_yes;
- goto say_no;
- case O_FTSIZE:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- value = (double)statcache.st_size;
- goto donumset;
-
- case O_FTMTIME:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- value = (double)(basetime - statcache.st_mtime) / 86400.0;
- goto donumset;
- case O_FTATIME:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- value = (double)(basetime - statcache.st_atime) / 86400.0;
- goto donumset;
- case O_FTCTIME:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- value = (double)(basetime - statcache.st_ctime) / 86400.0;
- goto donumset;
-
- case O_FTSOCK:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- if (S_ISSOCK(statcache.st_mode))
- goto say_yes;
- goto say_no;
- case O_FTCHR:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- if (S_ISCHR(statcache.st_mode))
- goto say_yes;
- goto say_no;
- case O_FTBLK:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- if (S_ISBLK(statcache.st_mode))
- goto say_yes;
- goto say_no;
- case O_FTFILE:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- if (S_ISREG(statcache.st_mode))
- goto say_yes;
- goto say_no;
- case O_FTDIR:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- if (S_ISDIR(statcache.st_mode))
- goto say_yes;
- goto say_no;
- case O_FTPIPE:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- if (S_ISFIFO(statcache.st_mode))
- goto say_yes;
- goto say_no;
- case O_FTLINK:
- if (mylstat(arg,st[1]) < 0)
- goto say_undef;
- if (S_ISLNK(statcache.st_mode))
- goto say_yes;
- goto say_no;
- case O_SYMLINK:
-#ifdef HAS_SYMLINK
- tmps = str_get(st[1]);
- tmps2 = str_get(st[2]);
-#ifdef TAINT
- TAINT_PROPER("symlink");
-#endif
- value = (double)(symlink(tmps,tmps2) >= 0);
- goto donumset;
-#else
- fatal("Unsupported function symlink");
-#endif
- case O_READLINK:
-#ifdef HAS_SYMLINK
- if (maxarg < 1)
- tmps = str_get(stab_val(defstab));
- else
- tmps = str_get(st[1]);
- anum = readlink(tmps,buf,sizeof buf);
- if (anum < 0)
- goto say_undef;
- str_nset(str,buf,anum);
- break;
-#else
- goto say_undef; /* just pretend it's a normal file */
-#endif
- case O_FTSUID:
-#ifdef S_ISUID
- anum = S_ISUID;
- goto check_xid;
-#else
- goto say_no;
-#endif
- case O_FTSGID:
-#ifdef S_ISGID
- anum = S_ISGID;
- goto check_xid;
-#else
- goto say_no;
-#endif
- case O_FTSVTX:
-#ifdef S_ISVTX
- anum = S_ISVTX;
-#else
- goto say_no;
-#endif
- check_xid:
- if (mystat(arg,st[1]) < 0)
- goto say_undef;
- if (statcache.st_mode & anum)
- goto say_yes;
- goto say_no;
- case O_FTTTY:
- if (arg[1].arg_type & A_DONT) {
- stab = arg[1].arg_ptr.arg_stab;
- tmps = "";
- }
- else
- stab = stabent(tmps = str_get(st[1]),FALSE);
- if (stab && stab_io(stab) && stab_io(stab)->ifp)
- anum = fileno(stab_io(stab)->ifp);
- else if (isDIGIT(*tmps))
- anum = atoi(tmps);
- else
- goto say_undef;
- if (isatty(anum))
- goto say_yes;
- goto say_no;
- case O_FTTEXT:
- case O_FTBINARY:
- str = do_fttext(arg,st[1]);
- break;
-#ifdef HAS_SOCKET
- case O_SOCKET:
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
-#ifndef lint
- value = (double)do_socket(stab,arglast);
-#else
- (void)do_socket(stab,arglast);
-#endif
- goto donumset;
- case O_BIND:
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
-#ifndef lint
- value = (double)do_bind(stab,arglast);
-#else
- (void)do_bind(stab,arglast);
-#endif
- goto donumset;
- case O_CONNECT:
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
-#ifndef lint
- value = (double)do_connect(stab,arglast);
-#else
- (void)do_connect(stab,arglast);
-#endif
- goto donumset;
- case O_LISTEN:
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
-#ifndef lint
- value = (double)do_listen(stab,arglast);
-#else
- (void)do_listen(stab,arglast);
-#endif
- goto donumset;
- case O_ACCEPT:
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- if ((arg[2].arg_type & A_MASK) == A_WORD)
- stab2 = arg[2].arg_ptr.arg_stab;
- else
- stab2 = stabent(str_get(st[2]),TRUE);
- do_accept(str,stab,stab2);
- STABSET(str);
- break;
- case O_GHBYNAME:
- if (maxarg < 1)
- goto say_undef;
- case O_GHBYADDR:
- case O_GHOSTENT:
- sp = do_ghent(optype,
- gimme,arglast);
- goto array_return;
- case O_GNBYNAME:
- if (maxarg < 1)
- goto say_undef;
- case O_GNBYADDR:
- case O_GNETENT:
- sp = do_gnent(optype,
- gimme,arglast);
- goto array_return;
- case O_GPBYNAME:
- if (maxarg < 1)
- goto say_undef;
- case O_GPBYNUMBER:
- case O_GPROTOENT:
- sp = do_gpent(optype,
- gimme,arglast);
- goto array_return;
- case O_GSBYNAME:
- if (maxarg < 1)
- goto say_undef;
- case O_GSBYPORT:
- case O_GSERVENT:
- sp = do_gsent(optype,
- gimme,arglast);
- goto array_return;
- case O_SHOSTENT:
- value = (double) sethostent((int)str_gnum(st[1]));
- goto donumset;
- case O_SNETENT:
- value = (double) setnetent((int)str_gnum(st[1]));
- goto donumset;
- case O_SPROTOENT:
- value = (double) setprotoent((int)str_gnum(st[1]));
- goto donumset;
- case O_SSERVENT:
- value = (double) setservent((int)str_gnum(st[1]));
- goto donumset;
- case O_EHOSTENT:
- value = (double) endhostent();
- goto donumset;
- case O_ENETENT:
- value = (double) endnetent();
- goto donumset;
- case O_EPROTOENT:
- value = (double) endprotoent();
- goto donumset;
- case O_ESERVENT:
- value = (double) endservent();
- goto donumset;
- case O_SOCKPAIR:
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- if ((arg[2].arg_type & A_MASK) == A_WORD)
- stab2 = arg[2].arg_ptr.arg_stab;
- else
- stab2 = stabent(str_get(st[2]),TRUE);
-#ifndef lint
- value = (double)do_spair(stab,stab2,arglast);
-#else
- (void)do_spair(stab,stab2,arglast);
-#endif
- goto donumset;
- case O_SHUTDOWN:
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
-#ifndef lint
- value = (double)do_shutdown(stab,arglast);
-#else
- (void)do_shutdown(stab,arglast);
-#endif
- goto donumset;
- case O_GSOCKOPT:
- case O_SSOCKOPT:
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- sp = do_sopt(optype,stab,arglast);
- goto array_return;
- case O_GETSOCKNAME:
- case O_GETPEERNAME:
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- if (!stab)
- goto say_undef;
- sp = do_getsockname(optype,stab,arglast);
- goto array_return;
-
-#else /* HAS_SOCKET not defined */
- case O_SOCKET:
- case O_BIND:
- case O_CONNECT:
- case O_LISTEN:
- case O_ACCEPT:
- case O_SOCKPAIR:
- case O_GHBYNAME:
- case O_GHBYADDR:
- case O_GHOSTENT:
- case O_GNBYNAME:
- case O_GNBYADDR:
- case O_GNETENT:
- case O_GPBYNAME:
- case O_GPBYNUMBER:
- case O_GPROTOENT:
- case O_GSBYNAME:
- case O_GSBYPORT:
- case O_GSERVENT:
- case O_SHOSTENT:
- case O_SNETENT:
- case O_SPROTOENT:
- case O_SSERVENT:
- case O_EHOSTENT:
- case O_ENETENT:
- case O_EPROTOENT:
- case O_ESERVENT:
- case O_SHUTDOWN:
- case O_GSOCKOPT:
- case O_SSOCKOPT:
- case O_GETSOCKNAME:
- case O_GETPEERNAME:
- badsock:
- fatal("Unsupported socket function");
-#endif /* HAS_SOCKET */
- case O_SSELECT:
-#ifdef HAS_SELECT
- sp = do_select(gimme,arglast);
- goto array_return;
-#else
- fatal("select not implemented");
-#endif
- case O_FILENO:
- if (maxarg < 1)
- goto say_undef;
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- if (!stab || !(stio = stab_io(stab)) || !(fp = stio->ifp))
- goto say_undef;
- value = fileno(fp);
- goto donumset;
- case O_BINMODE:
- if (maxarg < 1)
- goto say_undef;
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- if (!stab || !(stio = stab_io(stab)) || !(fp = stio->ifp))
- goto say_undef;
-#ifdef DOSISH
-#ifdef atarist
- if(fflush(fp))
- str_set(str, No);
- else
- {
- fp->_flag |= _IOBIN;
- str_set(str, Yes);
- }
-#else
- str_set(str, (setmode(fileno(fp), O_BINARY) != -1) ? Yes : No);
-#endif
-#else
- str_set(str, Yes);
-#endif
- STABSET(str);
- break;
- case O_VEC:
- sp = do_vec(str == st[1], arg->arg_ptr.arg_str, arglast);
- goto array_return;
- case O_GPWNAM:
- case O_GPWUID:
- case O_GPWENT:
-#ifdef HAS_PASSWD
- sp = do_gpwent(optype,
- gimme,arglast);
- goto array_return;
- case O_SPWENT:
- value = (double) setpwent();
- goto donumset;
- case O_EPWENT:
- value = (double) endpwent();
- goto donumset;
-#else
- case O_EPWENT:
- case O_SPWENT:
- fatal("Unsupported password function");
- break;
-#endif
- case O_GGRNAM:
- case O_GGRGID:
- case O_GGRENT:
-#ifdef HAS_GROUP
- sp = do_ggrent(optype,
- gimme,arglast);
- goto array_return;
- case O_SGRENT:
- value = (double) setgrent();
- goto donumset;
- case O_EGRENT:
- value = (double) endgrent();
- goto donumset;
-#else
- case O_EGRENT:
- case O_SGRENT:
- fatal("Unsupported group function");
- break;
-#endif
- case O_GETLOGIN:
-#ifdef HAS_GETLOGIN
- if (!(tmps = getlogin()))
- goto say_undef;
- str_set(str,tmps);
-#else
- fatal("Unsupported function getlogin");
-#endif
- break;
- case O_OPEN_DIR:
- case O_READDIR:
- case O_TELLDIR:
- case O_SEEKDIR:
- case O_REWINDDIR:
- case O_CLOSEDIR:
- if (maxarg < 1)
- goto say_undef;
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- if (!stab)
- goto say_undef;
- sp = do_dirop(optype,stab,gimme,arglast);
- goto array_return;
- case O_SYSCALL:
- value = (double)do_syscall(arglast);
- goto donumset;
- case O_PIPE_OP:
-#ifdef HAS_PIPE
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
- if ((arg[2].arg_type & A_MASK) == A_WORD)
- stab2 = arg[2].arg_ptr.arg_stab;
- else
- stab2 = stabent(str_get(st[2]),TRUE);
- do_pipe(str,stab,stab2);
- STABSET(str);
-#else
- fatal("Unsupported function pipe");
-#endif
- break;
- }
-
- normal_return:
- st[1] = str;
-#ifdef DEBUGGING
- if (debug) {
- dlevel--;
- if (debug & 8)
- deb("%s RETURNS \"%s\"\n",opname[optype],str_get(str));
- }
-#endif
- stack_ary = stack->ary_array;
- stack_max = stack_ary + stack->ary_max;
- stack_sp = stack_ary + arglast[0] + 1;
- return arglast[0] + 1;
-}
View Lorry Controller Status