-/* $Header: eval.c,v 3.0.1.3 89/12/21 20:03:05 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]
+ * patch13: added splice operator: @oldelems = splice(@array,$offset,$len,LIST)
+ *
+ * Revision 3.0.1.4 90/02/28 17:36:59 lwall
+ * patch9: added pipe function
+ * patch9: a return in scalar context wouldn't return array
+ * patch9: !~ now always returns scalar even in array context
+ * patch9: some machines can't cast float to long with high bit set
+ * patch9: piped opens returned undef in child
+ * patch9: @array in scalar context now returns length of array
+ * patch9: chdir; coredumped
+ * patch9: wait no longer ignores signals
+ * patch9: mkdir now handles odd versions of /bin/mkdir
+ * patch9: -l FILEHANDLE now disallowed
+ *
* Revision 3.0.1.3 89/12/21 20:03:05 lwall
* patch7: errno may now be a macro with an lvalue
* patch7: ANSI strerror() is now supported
#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
static STAB *stab2;
static STIO *stio;
static struct lstring *lstr;
-static char old_record_separator;
+static int old_record_separator;
+extern int wantarray;
double sin(), cos(), atan2(), pow();
STR_SSET(str,st[1]);
anum = (int)str_gnum(st[2]);
if (anum >= 1) {
- tmpstr = Str_new(50,0);
+ tmpstr = Str_new(50, 0);
str_sset(tmpstr,str);
- while (--anum > 0)
- str_scat(str,tmpstr);
+ 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';
}
else
str_sset(str,&str_no);
break;
case O_NMATCH:
sp = do_match(str,arg,
- gimme,arglast);
- if (gimme == G_ARRAY)
- goto array_return;
+ G_SCALAR,arglast);
str_sset(str, str_true(str) ? &str_no : &str_yes);
STABSET(str);
break;
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)(((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)(((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)(((long)value) & (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)(((long)value) ^ (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)(((long)value) | (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) ~(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
stab = arg[1].arg_ptr.arg_stab;
else
stab = stabent(str_get(st[1]),TRUE);
- if (do_open(stab,str_get(st[2]))) {
+ 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;
+ /* 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
- str = afetch(ary,maxarg - 1,FALSE);
- break;
+ 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);
}
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);
str_magic(str, tmpstab, 'D', tmps, anum);
#endif
break;
+ case O_LSLICE:
+ anum = 2;
+ argtype = FALSE;
+ goto do_slice_already;
case O_ASLICE:
- anum = TRUE;
+ anum = 1;
argtype = FALSE;
goto do_slice_already;
case O_HSLICE:
- anum = FALSE;
+ anum = 0;
argtype = FALSE;
goto do_slice_already;
case O_LASLICE:
- anum = TRUE;
+ anum = 1;
argtype = TRUE;
goto do_slice_already;
case O_LHSLICE:
- anum = FALSE;
+ anum = 0;
argtype = TRUE;
do_slice_already:
- sp = do_slice(arg[1].arg_ptr.arg_stab,anum,argtype,
+ 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);
tmps = str_get(st[2]);
}
if (!tmps || !*tmps)
- exit(1);
+ tmps = "Died";
fatal("%s",tmps);
goto say_zero;
case O_PRTF:
goto donumset;
case O_CHDIR:
if (maxarg < 1)
- tmps = str_get(stab_val(defstab));
+ tmps = Nullch;
else
tmps = str_get(st[1]);
if (!tmps || !*tmps) {
STABSET(str);
break;
case O_RETURN:
- tmps = "SUB"; /* just fake up a "last SUB" */
+ tmps = "_SUB_"; /* just fake up a "last _SUB_" */
optype = O_LAST;
- if (gimme == G_ARRAY) {
+ if (wantarray == G_ARRAY) {
lastretstr = Nullstr;
lastspbase = arglast[1];
lastsize = arglast[2] - arglast[1];
}
#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]);
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"))
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 = (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;
goto say_no;
#endif
case O_FTLINK:
+ if (arg[1].arg_type & A_DONT)
+ fatal("You must supply explicit filename with -l");
#ifdef LSTAT
if (lstat(str_get(st[1]),&statcache) < 0)
goto say_undef;
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:
case O_SYSCALL:
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
+ 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:
#ifdef DEBUGGING
if (debug) {
dlevel--;
- if (debug & 8)
- deb("%s RETURNS ARRAY OF %d ARGS\n",opname[optype],sp - arglast[0]);
+ 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],str_get(st[1]));
+ break;
+ default:
+ 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;
+ }
+ }
}
#endif
return sp;
projects / p5sagit/p5-mst-13.2.git / blobdiff