Import Upstream version 4e6upstream/4e6

1 files changed, 408 insertions, 0 deletions

diff --git a/posix.c b/posix.c
new file mode 100644
index 0000000..422d61d
--- /dev/null
+++ b/posix.c
@@ -0,0 +1,408 @@
+/* Copyright (C) 1994, 1995 Free Software Foundation, Inc.
+ * 
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU General Public License as published by
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  
+ */
+
+/* "posix.c" functions only in Posix (unix).
+   Author: Aubrey Jaffer */
+
+#include "scm.h"
+
+#include <pwd.h>
+#include <sys/types.h>
+#include <sys/wait.h>
+
+#ifndef STDC_HEADERS
+	char *ttyname P((int fd));
+	FILE *popen P((const char* command, const char* type));
+	int pclose P((FILE* stream));
+#endif
+
+     /* Only the superuser can successfully execute this call */
+static char s_chown[] = "chown";
+SCM l_chown(path, owner, group)
+     SCM path, owner, group;
+{
+  int val;
+  ASSERT(NIMP(path) && STRINGP(path), path, ARG1, s_chown);
+  ASSERT(INUMP(owner), owner, ARG2, s_chown);
+  ASSERT(INUMP(group), group, ARG3, s_chown);
+  SYSCALL(val = chown(CHARS(path), INUM(owner), INUM(group)););
+  return val ? BOOL_F : BOOL_T;
+}
+
+static char s_link[] = "link";
+SCM l_link(oldpath, newpath)
+     SCM oldpath, newpath;
+{
+  int val;
+  ASSERT(NIMP(oldpath) && STRINGP(oldpath), oldpath, ARG1, s_link);
+  ASSERT(NIMP(newpath) && STRINGP(newpath), newpath, ARG2, s_link);
+  SYSCALL(val = link(CHARS(oldpath), CHARS(newpath)););
+  return val ? BOOL_F : BOOL_T;
+}
+
+SCM l_pipe()
+{
+  int fd[2], ret;
+  FILE *f_rd, *f_wt;
+  SCM p_rd, p_wt;
+  NEWCELL(p_rd); NEWCELL(p_wt);
+  SYSCALL(ret = pipe(fd););
+  if (ret) {ALLOW_INTS; return BOOL_F;}
+  SYSCALL(f_rd = fdopen(fd[0], "r"););
+  if (!f_rd) {
+    close(fd[0]);
+    goto errout;
+  }
+  SYSCALL(f_wt = fdopen(fd[1], "w"););
+  if (!f_wt) {
+    fclose(f_rd);
+  errout:
+    close(fd[1]);
+    wta(UNDEFINED, (char *)NALLOC, s_port_type);
+  }
+  CAR(p_rd) = tc16_fport | mode_bits("r");
+  CAR(p_wt) = tc16_fport | mode_bits("w");
+  SETSTREAM(p_rd, f_rd);
+  SETSTREAM(p_wt, f_wt);
+  ALLOW_INTS;
+  return cons(p_rd, p_wt);
+}
+
+char	s_op_pipe[] = "open-pipe";
+SCM open_pipe(pipestr, modes)
+     SCM pipestr, modes;
+{
+	FILE *f;
+	register SCM z;
+	ASSERT(NIMP(pipestr) && STRINGP(pipestr), pipestr, ARG1, s_op_pipe);
+	ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_op_pipe);
+	NEWCELL(z);
+	/* DEFER_INTS, SYSCALL, and ALLOW_INTS are probably paranoid here*/
+	DEFER_INTS;
+	ignore_signals();
+	SYSCALL(f = popen(CHARS(pipestr), CHARS(modes)););
+	unignore_signals();
+	if (!f) z = BOOL_F;
+	else {
+	  CAR(z) = tc16_pipe | OPN | (strchr(CHARS(modes), 'r') ? RDNG : WRTNG);
+	  SETSTREAM(z, f);
+	}
+	ALLOW_INTS;
+	return z;
+}
+SCM l_open_input_pipe(pipestr)
+     SCM pipestr;
+{
+  return open_pipe(pipestr, makfromstr("r", (sizeof "r")-1));
+}
+SCM l_open_output_pipe(pipestr)
+     SCM pipestr;
+{
+  return open_pipe(pipestr, makfromstr("w", (sizeof "w")-1));
+}
+static int prinpipe(exp, port, writing)
+     SCM exp; SCM port; int writing;
+{
+  prinport(exp, port, s_pipe);
+  return !0;
+}
+
+static char scm_s_getgroups[] = "getgroups";
+SCM scm_getgroups()
+{
+  SCM grps, ans;
+  int ngroups = getgroups(NULL, 0);
+  if (!ngroups) return BOOL_F;
+  NEWCELL(grps);
+  DEFER_INTS;
+  {
+    gid_t *groups = (gid_t *)must_malloc(ngroups * sizeof(gid_t),
+					 scm_s_getgroups);
+    int val = getgroups(ngroups, groups);
+    if (val < 0) {
+      must_free(groups);
+      ALLOW_INTS;
+      return BOOL_F;
+    }
+    SETCHARS(grps, groups);	/* set up grps as a GC protect */
+    SETLENGTH(grps, 0L + ngroups * sizeof(gid_t), tc7_string);
+    ALLOW_INTS;
+    ans = make_vector(MAKINUM(ngroups), UNDEFINED);
+    while (--ngroups >= 0) VELTS(ans)[ngroups] = MAKINUM(groups[ngroups]);
+    SETCHARS(grps, groups);	/* to make sure grps stays around. */
+    return ans;
+  }
+}  
+
+/* These 2 routines are not protected against `entry' being reused
+   before access to that structure is completed */
+
+static char s_pwinfo[] = "getpw";
+SCM l_pwinfo(user)
+     SCM user;
+{
+  SCM ans = make_vector(MAKINUM(7), UNSPECIFIED);
+  struct passwd *entry;
+  SCM *ve = VELTS(ans);
+  DEFER_INTS;
+  if UNBNDP(user) SYSCALL(entry = getpwent(););
+  else if INUMP(user) SYSCALL(entry = getpwuid(INUM(user)););
+  else {
+    ASSERT(NIMP(user) && STRINGP(user), user, ARG1, s_pwinfo);
+    SYSCALL(entry = getpwnam(CHARS(user)););
+  }
+  ALLOW_INTS;
+  if (!entry) return BOOL_F;
+  ve[ 0] = makfrom0str(entry->pw_name);
+  ve[ 1] = makfrom0str(entry->pw_passwd);
+  ve[ 2] = ulong2num((unsigned long)entry->pw_uid);
+  ve[ 3] = ulong2num((unsigned long)entry->pw_gid);
+  ve[ 4] = makfrom0str(entry->pw_gecos);
+  ve[ 5] = makfrom0str(entry->pw_dir);
+  ve[ 6] = makfrom0str(entry->pw_shell);
+  return ans;
+}
+#include <grp.h>
+static char s_grinfo[] = "getgr";
+SCM l_grinfo(name)
+     SCM name;
+{
+  SCM ans = make_vector(MAKINUM(4), UNSPECIFIED);
+  struct group *entry;
+  SCM *ve = VELTS(ans);
+  DEFER_INTS;
+  if UNBNDP(name) SYSCALL(entry = getgrent(););
+  else if INUMP(name) SYSCALL(entry = getgrgid(INUM(name)););
+  else {
+    ASSERT(NIMP(name) && STRINGP(name), name, ARG1, s_grinfo);
+    SYSCALL(entry = getgrnam(CHARS(name)););
+  }
+  ALLOW_INTS;
+  if (!entry) return BOOL_F;
+  ve[ 0] = makfrom0str(entry->gr_name);
+  ve[ 1] = makfrom0str(entry->gr_passwd);
+  ve[ 2] = ulong2num((unsigned long)entry->gr_gid);
+  ve[ 3] = makfromstrs(-1, entry->gr_mem);
+  return ans;
+}
+SCM l_setgr(arg)
+     SCM arg;
+{
+  if (UNBNDP(arg) || FALSEP(arg)) endgrent();
+  else setgrent();
+  return UNSPECIFIED;
+}
+SCM l_setpw(arg)
+     SCM arg;
+{
+  if (UNBNDP(arg) || FALSEP(arg)) endpwent();
+  else setpwent();
+  return UNSPECIFIED;
+}
+
+static char s_kill[] = "kill";
+SCM l_kill(pid, sig)
+     SCM pid, sig;
+{
+  int i;
+  ASSERT(INUMP(pid), pid, ARG1, s_kill);
+  ASSERT(INUMP(sig), sig, ARG2, s_kill);
+  SYSCALL(i = kill((int)INUM(pid), (int)INUM(sig)););
+  return MAKINUM(0L+i);
+}
+static char s_waitpid[] = "waitpid";
+SCM l_waitpid(pid, options)
+     SCM pid, options;
+{
+  int i, status;
+  ASSERT(INUMP(pid), pid, ARG1, s_waitpid);
+  ASSERT(INUMP(options), options, ARG2, s_waitpid);
+  SYSCALL(i = waitpid(INUM(pid), &status, INUM(options)););
+  return i < 0 ? BOOL_F : MAKINUM(0L+status);
+}
+
+SCM l_getppid()
+{
+  return MAKINUM(0L+getppid());
+}
+
+SCM l_getuid()
+{
+  return MAKINUM(0L+getuid());
+}
+SCM l_getgid()
+{
+  return MAKINUM(0L+getgid());
+}
+#ifndef LACK_E_IDs
+SCM l_geteuid()
+{
+  return MAKINUM(0L+geteuid());
+}
+SCM l_getegid()
+{
+  return MAKINUM(0L+getegid());
+}
+#endif
+
+static char s_setuid[] = "setuid";
+SCM l_setuid(id)
+     SCM id;
+{
+  ASSERT(INUMP(id), id, ARG1, s_setuid);
+  return setuid(INUM(id)) ? BOOL_F : BOOL_T;
+}
+static char s_setgid[] = "setgid";
+SCM l_setgid(id)
+     SCM id;
+{
+  ASSERT(INUMP(id), id, ARG1, s_setgid);
+  return setgid(INUM(id)) ? BOOL_F : BOOL_T;
+}
+
+#ifndef LACK_E_IDs
+static char s_seteuid[] = "seteuid";
+SCM l_seteuid(id)
+     SCM id;
+{
+  ASSERT(INUMP(id), id, ARG1, s_seteuid);
+  return seteuid(INUM(id)) ? BOOL_F : BOOL_T;
+}
+static char s_setegid[] = "setegid";
+SCM l_setegid(id)
+     SCM id;
+{
+  ASSERT(INUMP(id), id, ARG1, s_setegid);
+  return setegid(INUM(id)) ? BOOL_F : BOOL_T;
+}
+#endif
+
+static char s_ttyname[] = "ttyname";
+SCM l_ttyname(port)
+     SCM port;
+{
+  char *ans;
+  ASSERT(NIMP(port) && OPPORTP(port), port, ARG1, s_ttyname);
+  if (tc16_fport != TYP16(port)) return BOOL_F;
+  SYSCALL(ans = ttyname(fileno(STREAM(port))););
+  /* ans could be overwritten by another call to ttyname */
+  return ans ? makfrom0str(ans) : BOOL_F;
+}
+
+SCM l_fork()
+{
+  long pid = 0L + fork();
+  return -1L==pid ? BOOL_F : MAKINUM(pid);
+}
+
+#include <sys/utsname.h>
+SCM l_uname()
+{
+  struct utsname buf;
+  SCM ans = make_vector(MAKINUM(5), UNSPECIFIED);
+  SCM *ve = VELTS(ans);
+  if (uname(&buf)) return BOOL_F;
+  ve[ 0] = makfrom0str(buf.sysname);
+  ve[ 1] = makfrom0str(buf.nodename);
+  ve[ 2] = makfrom0str(buf.release);
+  ve[ 3] = makfrom0str(buf.version);
+  ve[ 4] = makfrom0str(buf.machine);
+  /* ve[ 5] = makfrom0str(buf.domainname); */
+  return ans;
+}
+
+static iproc subr0s[] = {
+	{"pipe", l_pipe},
+	{scm_s_getgroups, scm_getgroups},
+	{"getppid", l_getppid},
+	{"getuid", l_getuid},
+	{"getgid", l_getgid},
+#ifndef LACK_E_IDs
+	{"getegid", l_getegid},
+	{"geteuid", l_geteuid},
+#endif
+	{"uname", l_uname},
+	{"fork", l_fork},
+	{0, 0}};
+
+static iproc subr1os[] = {
+	{s_pwinfo, l_pwinfo},
+	{s_grinfo, l_grinfo},
+	{"setpwent", l_setpw},
+	{"setgrent", l_setgr},
+	{0, 0}};
+
+static iproc subr1s[] = {
+	{"setuid", l_setuid},
+	{"setgid", l_setgid},
+#ifndef LACK_E_IDs
+	{"setegid", l_setegid},
+	{"seteuid", l_seteuid},
+#endif
+	{"open-input-pipe", l_open_input_pipe},
+	{"open-output-pipe", l_open_output_pipe},
+	{s_ttyname, l_ttyname},
+	{0, 0}};
+
+static iproc subr2s[] = {
+	{s_link, l_link},
+	{s_kill, l_kill},
+	{s_waitpid, l_waitpid},
+	{s_op_pipe, open_pipe},
+	{0, 0}};
+
+static iproc subr3s[] = {
+	{s_chown, l_chown},
+	{0, 0}};
+
+void init_posix()
+{
+	init_iprocs(subr0s, tc7_subr_0);
+	init_iprocs(subr1s, tc7_subr_1);
+	init_iprocs(subr1os, tc7_subr_1o);
+	init_iprocs(subr2s, tc7_subr_2);
+	init_iprocs(subr3s, tc7_subr_3);
+	add_feature("posix");
+	ptobs[0x0ff & (tc16_pipe>>8)].fclose = pclose;
+	ptobs[0x0ff & (tc16_pipe>>8)].free = pclose;
+	ptobs[0x0ff & (tc16_pipe>>8)].print = prinpipe;
+	add_feature(s_pipe);
+}