-/* $Header: eval.c,v 3.0.1.5 90/03/12 16:37:40 lwall Locked $
+/* $Header: eval.c,v 3.0.1.7 90/08/09 03:33:44 lwall Locked $
*
* Copyright (c) 1989, Larry Wall
*
* as specified in the README file that comes with the perl 3.0 kit.
*
* $Log: eval.c,v $
+ * Revision 3.0.1.7 90/08/09 03:33:44 lwall
+ * patch19: made ~ do vector operation on strings like &, | and ^
+ * patch19: dbmopen(%name...) didn't work right
+ * patch19: dbmopen(name, 'filename', undef) now refrains from creating
+ * patch19: empty %array now returns 0 in scalar context
+ * patch19: die with no arguments no longer exits unconditionally
+ * patch19: return outside a subroutine now returns a reasonable message
+ * patch19: rename done with unlink()/link()/unlink() now checks for clobbering
+ * patch19: -s now returns size of file
+ *
+ * Revision 3.0.1.6 90/03/27 15:53:51 lwall
+ * patch16: MSDOS support
+ * patch16: support for machines that can't cast negative floats to unsigned ints
+ * patch16: ioctl didn't return values correctly
+ *
* Revision 3.0.1.5 90/03/12 16:37:40 lwall
* patch13: undef $/ didn't work as advertised
* patch13: added list slice operator (LIST)[LIST]
#include "EXTERN.h"
#include "perl.h"
+#ifndef NSIG
#include <signal.h>
+#endif
+#ifdef I_FCNTL
+#include <fcntl.h>
+#endif
#ifdef I_VFORK
# include <vfork.h>
#endif
if (when >= 0)
value = (double)(when % tmplong);
else
- value = (double)(tmplong - (-when % tmplong));
+ value = (double)(tmplong - ((-when - 1) % tmplong)) - 1;
#endif
goto donumset;
case O_ADD:
value = str_gnum(st[1]);
anum = (int)str_gnum(st[2]);
#ifndef lint
- value = (double)(((unsigned long)value) << anum);
+ 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)(((unsigned long)value) >> anum);
+ value = (double)(U_L(value) >> anum);
#endif
goto donumset;
case O_LT:
if (!sawvec || st[1]->str_nok || st[2]->str_nok) {
value = str_gnum(st[1]);
#ifndef lint
- value = (double)(((unsigned long)value) &
- (unsigned long)str_gnum(st[2]));
+ value = (double)(U_L(value) & U_L(str_gnum(st[2])));
#endif
goto donumset;
}
if (!sawvec || st[1]->str_nok || st[2]->str_nok) {
value = str_gnum(st[1]);
#ifndef lint
- value = (double)(((unsigned long)value) ^
- (unsigned long)str_gnum(st[2]));
+ value = (double)(U_L(value) ^ U_L(str_gnum(st[2])));
#endif
goto donumset;
}
if (!sawvec || st[1]->str_nok || st[2]->str_nok) {
value = str_gnum(st[1]);
#ifndef lint
- value = (double)(((unsigned long)value) |
- (unsigned long)str_gnum(st[2]));
+ value = (double)(U_L(value) | U_L(str_gnum(st[2])));
#endif
goto donumset;
}
value = (double) !str_true(st[1]);
goto donumset;
case O_COMPLEMENT:
+ if (!sawvec || st[1]->str_nok) {
#ifndef lint
- value = (double) ~(unsigned long)str_gnum(st[1]);
+ value = (double) ~U_L(str_gnum(st[1]));
#endif
- goto donumset;
+ goto donumset;
+ }
+ else {
+ STR_SSET(str,st[1]);
+ tmps = str_get(str);
+ for (anum = str->str_cur; anum; anum--)
+ *tmps = ~*tmps;
+ }
+ break;
case O_SELECT:
tmps = stab_name(defoutstab);
if (maxarg > 0) {
break;
case O_DBMOPEN:
#ifdef SOME_DBM
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
+ stab = arg[1].arg_ptr.arg_stab;
+ if (st[3]->str_nok || st[3]->str_pok)
+ anum = (int)str_gnum(st[3]);
else
- stab = stabent(str_get(st[1]),TRUE);
- anum = (int)str_gnum(st[3]);
+ anum = -1;
value = (double)hdbmopen(stab_hash(stab),str_get(st[2]),anum);
goto donumset;
#else
#endif
case O_DBMCLOSE:
#ifdef SOME_DBM
- if ((arg[1].arg_type & A_MASK) == A_WORD)
- stab = arg[1].arg_ptr.arg_stab;
- else
- stab = stabent(str_get(st[1]),TRUE);
+ stab = arg[1].arg_ptr.arg_stab;
hdbmclose(stab_hash(stab));
goto say_yes;
#else
goto say_zero;
else
goto say_undef;
- break;
+ /* break; */
case O_TRANS:
value = (double) do_trans(str,arg);
str = arg->arg_ptr.arg_str;
astore(stack,sp + maxarg, Nullstr);
st = stack->ary_array;
}
- Copy(ary->ary_array, &st[sp+1], maxarg, STR*);
+ st += sp;
+ Copy(ary->ary_array, &st[1], maxarg, STR*);
sp += maxarg;
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);
gimme,arglast);
goto array_return;
case O_SPLICE:
- sp = do_splice(stab_array(arg[1].arg_ptr.arg_stab),str,gimme,arglast);
+ 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)
tmps = str_get(st[2]);
}
if (!tmps || !*tmps)
- exit(1);
+ tmps = "Died";
fatal("%s",tmps);
goto say_zero;
case O_PRTF:
}
#endif
}
- if (loop_ptr < 0)
+ 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;
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,
argtype = arg[2].arg_type & A_MASK;
argptr = arg[2].arg_ptr;
sp = arglast[0];
- st -= sp;
+ st -= sp++;
goto re_eval;
}
str_set(str,"");
}
break;
case O_FORK:
+#ifdef FORK
anum = fork();
if (!anum && (tmpstab = stabent("$",allstabs)))
str_numset(STAB_STR(tmpstab),(double)getpid());
value = (double)anum;
goto donumset;
+#else
+ fatal("Unsupported function fork");
+ break;
+#endif
case O_WAIT:
+#ifdef WAIT
#ifndef lint
- /* ihand = signal(SIGINT, SIG_IGN); */
- /* qhand = signal(SIGQUIT, SIG_IGN); */
anum = wait(&argflags);
if (anum > 0)
pidgone(anum,argflags);
value = (double)anum;
-#else
- /* ihand = qhand = 0; */
#endif
- /* (void)signal(SIGINT, ihand); */
- /* (void)signal(SIGQUIT, qhand); */
statusvalue = (unsigned short)argflags;
goto donumset;
+#else
+ fatal("Unsupported function wait");
+ break;
+#endif
case O_SYSTEM:
+#ifdef FORK
#ifdef TAINT
if (arglast[2] - arglast[1] == 1) {
taintenv();
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_exec(str_get(str_static(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_static(st[2])));
+ }
+ goto donumset;
+#endif /* FORK */
case O_EXEC:
if ((arg[1].arg_type & A_MASK) == A_STAB)
value = (double)do_aexec(st[1],arglast);
out:
value = (double)anum;
goto donumset;
- case O_CHMOD:
case O_CHOWN:
+#ifdef CHOWN
+ value = (double)apply(optype,arglast);
+ goto donumset;
+#else
+ fatal("Unsupported function chown");
+ break;
+#endif
case O_KILL:
+#ifdef 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 UMASK
if (maxarg < 1) {
anum = umask(0);
(void)umask(anum);
taintproper("Insecure dependency in umask");
#endif
goto donumset;
+#else
+ fatal("Unsupported function umask");
+ break;
+#endif
case O_RENAME:
tmps = str_get(st[1]);
tmps2 = str_get(st[2]);
#ifdef RENAME
value = (double)(rename(tmps,tmps2) >= 0);
#else
- if (euid || stat(tmps2,&statbuf) < 0 ||
- (statbuf.st_mode & S_IFMT) != S_IFDIR )
- (void)UNLINK(tmps2); /* avoid unlinking a directory */
- if (!(anum = link(tmps,tmps2)))
- anum = UNLINK(tmps);
+ if (same_dirent(tmps2, tmps) /* can always rename to same name */
+ anum = 1;
+ else {
+ if (euid || stat(tmps2,&statbuf) < 0 ||
+ (statbuf.st_mode & S_IFMT) != S_IFDIR )
+ (void)UNLINK(tmps2);
+ if (!(anum = link(tmps,tmps2)))
+ anum = UNLINK(tmps);
+ }
value = (double)(anum >= 0);
#endif
goto donumset;
case O_LINK:
+#ifdef LINK
tmps = str_get(st[1]);
tmps2 = str_get(st[2]);
#ifdef TAINT
#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]);
goto one_liner; /* see above in MKDIR */
#endif
case O_GETPPID:
+#ifdef GETPPID
value = (double)getppid();
goto donumset;
+#else
+ fatal("Unsupported function getppid");
+ break;
+#endif
case O_GETPGRP:
#ifdef GETPGRP
if (maxarg < 1)
break;
#endif
case O_CHROOT:
+#ifdef CHROOT
if (maxarg < 1)
tmps = str_get(stab_val(defstab));
else
#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 = arg[1].arg_ptr.arg_stab;
else
stab = stabent(str_get(st[1]),TRUE);
- argtype = (unsigned int)str_gnum(st[2]);
+ argtype = U_I(str_gnum(st[2]));
#ifdef TAINT
taintproper("Insecure dependency in ioctl");
#endif
anum = do_ctl(optype,stab,argtype,st[3]);
if (anum == -1)
goto say_undef;
- if (anum != 0)
+ if (anum != 0) {
+ value = (double)anum;
goto donumset;
+ }
str_set(str,"0 but true");
STABSET(str);
break;
}
value = (double)(ary->ary_fill + 1);
break;
+
+ case O_REQUIRE:
case O_DOFILE:
case O_EVAL:
if (maxarg < 1)
case O_FTSIZE:
if (mystat(arg,st[1]) < 0)
goto say_undef;
- if (statcache.st_size)
- goto say_yes;
- goto say_no;
+ value = (double)statcache.st_size;
+ goto donumset;
case O_FTSOCK:
#ifdef S_IFSOCK
anum = S_IFCHR;
goto check_file_type;
case O_FTBLK:
+#ifdef S_IFBLK
anum = S_IFBLK;
goto check_file_type;
+#else
+ goto say_no;
+#endif
case O_FTFILE:
anum = S_IFREG;
goto check_file_type;
value = (double)(symlink(tmps,tmps2) >= 0);
goto donumset;
#else
- fatal("Unsupported function symlink()");
+ fatal("Unsupported function symlink");
#endif
case O_READLINK:
#ifdef SYMLINK
str_nset(str,buf,anum);
break;
#else
- fatal("Unsupported function readlink()");
+ fatal("Unsupported function readlink");
#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;
case O_ESERVENT:
value = (double) endservent();
goto donumset;
- case O_SSELECT:
- sp = do_select(gimme,arglast);
- goto array_return;
- case O_SOCKETPAIR:
+ case O_SOCKPAIR:
if ((arg[1].arg_type & A_MASK) == A_WORD)
stab = arg[1].arg_ptr.arg_stab;
else
case O_CONNECT:
case O_LISTEN:
case O_ACCEPT:
- case O_SSELECT:
- case O_SOCKETPAIR:
+ case O_SOCKPAIR:
case O_GHBYNAME:
case O_GHBYADDR:
case O_GHOSTENT:
badsock:
fatal("Unsupported socket function");
#endif /* SOCKET */
+ case O_SSELECT:
+#ifdef SELECT
+ sp = do_select(gimme,arglast);
+ goto array_return;
+#else
+ fatal("select not implemented");
+#endif
case O_FILENO:
if (maxarg < 1)
goto say_undef;
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 MSDOS
+ str_set(str, (setmode(fileno(fp), O_BINARY) != -1) ? Yes : No);
+#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 PASSWD
sp = do_gpwent(optype,
gimme,arglast);
goto array_return;
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 GROUP
sp = do_ggrent(optype,
gimme,arglast);
goto array_return;
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 GETLOGIN
if (!(tmps = getlogin()))
goto say_undef;
str_set(str,tmps);
+#else
+ fatal("Unsupported function getlogin");
+#endif
break;
case O_OPENDIR:
case O_READDIR:
value = (double)do_syscall(arglast);
goto donumset;
case O_PIPE:
+#ifdef PIPE
if ((arg[1].arg_type & A_MASK) == A_WORD)
stab = arg[1].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;
}
deb("%s RETURNS (\"%s\")\n",opname[optype],str_get(st[1]));
break;
default:
- deb("%s RETURNS %d ARGS (\"%s\",%s\"%s\"\n",opname[optype],anum,
- str_get(st[1]),anum==2?"":"...,",str_get(st[anum]));
+ tmps = str_get(st[1]);
+ deb("%s RETURNS %d ARGS (\"%s\",%s\"%s\")\n",opname[optype],
+ anum,tmps,anum==2?"":"...,",str_get(st[anum]));
break;
}
}