http://t3x.org/s9fes/unix.c.html

sys-unix/unix.c

1124 Lines

/*
 * Scheme 9 from Empty Space, Unix Interface
 * By Nils M Holm, 2009-2018
 * In the public domain
 *
 * A low-level interface to some Unix system services.
 */

/*
 * Make Linux happy.
 */

#ifndef _BSD_SOURCE
 #define _BSD_SOURCE
#endif

#ifndef __FreeBSD__
 #ifndef __NetBSD__
  #ifndef __OpenBSD__

   #ifndef _POSIX_SOURCE
    #define _POSIX_SOURCE
   #endif

   #ifndef _XOPEN_SOURCE
    #define _XOPEN_SOURCE
   #endif

   #ifndef _XOPEN_SOURCE_EXTENDED
    #define _XOPEN_SOURCE_EXTENDED
   #endif

   #ifndef _DEFAULT_SOURCE
    #define _DEFAULT_SOURCE
   #endif

  #endif
 #endif
#endif

#include "s9core.h"
#include "s9import.h"
#include "s9ext.h"

#include <stdlib.h>
#include <stdio.h>
#include <unistd.h>
#include <string.h>
#include <ctype.h>
#include <errno.h>
#include <fcntl.h>
#include <sys/types.h>
#include <sys/time.h>
#include <sys/stat.h>
#include <sys/param.h>
#include <sys/wait.h>
#include <sys/select.h>
#include <pwd.h>
#include <grp.h>
#include <dirent.h>
#include <signal.h>

#ifdef NETWORK
 #include <sys/socket.h>
 #include <netdb.h>
 #include <sys/utsname.h>
 #include <arpa/inet.h>
 #include <netinet/in.h>
#endif /* NETWORK */

/*
 * XXX Shouldn't these be defined in <sys/stat.h> and <signal.h>?
 * Probably just another POSIX hickup. Please someone supply a
 * clean solution.
 */

#ifndef S_ISVTX
 #define S_ISVTX	01000
#endif
#ifndef SIGTRAP
 #define SIGTRAP	5
#endif
#ifndef SIGEMT
 #define SIGEMT		7
#endif
#ifndef SIGSYS
 #define SIGSYS		12
#endif

/*
 *	Allow us at least to write
 *		assign(car(x), cons(foo, bar));
 *	in presence of that fact that C's
 *	order of evaluation messes up
 *		car(x) = cons(foo, bar);
 */

static cell		New_node;
#define assign(n,v)	do { New_node = (v); n = New_node; } while(0)

cell	Last_errno = 0;
cell	Catch_errors = 0;

cell sys_error(char *who) {
	char	buf[256];
	char	*p, *q;
	int	i, k;
	cell	a;

	Last_errno = errno;
	if (who) {
		if (Catch_errors) return FALSE;
		k = strlen(who);
		strcpy(buf, who);
		strcpy(&buf[k], ": ");
		k += 2;
		q = strerror(errno);
		for (p = &buf[k]; *q && k < 244; k++)
			*p++ = tolower((int) *q++);
		*p = 0;
		strcat(buf, ", arguments");
		save(a = NIL);
		for (i = narg(); i > 0; i--) {
			a = cons(parg(i), a);
			car(Stack) = a;
		}
		unsave(1);
		error(buf, a);
	}
	return FALSE;
}

cell sys_ok(void) {
	return Catch_errors? TRUE: UNSPECIFIC;
}

cell pp_sys_access(void) {
	return access(string(parg(1)),
		integer_value("sys:access", parg(2))) < 0? FALSE: TRUE;
}

cell pp_sys_catch_errors(void) {
	Catch_errors = parg(1) == TRUE;
	if (Catch_errors) Last_errno = 0;
	return UNSPECIFIC;
}

cell pp_sys_chdir(void) {
	if (chdir(string(parg(1))) < 0)
		return sys_error("sys:chdir");
	return sys_ok();
}

cell pp_sys_close(void) {
	if (close(integer_value("sys:close", parg(1))) < 0)
		return sys_error("sys:close");
	return sys_ok();
}

cell pp_sys_chmod(void) {
	int	r;

	r = chmod(string(parg(1)), integer_value("sys:chmod", parg(2)));
	if (r < 0) return sys_error("sys:chmod");
	return sys_ok();
}

cell pp_sys_chown(void) {
	int	r;

	r = chown(string(parg(1)),
		integer_value("sys:chown", parg(2)),
		integer_value("sys:chown", parg(3)));
	if (r < 0) return sys_error("sys:chown");
	return sys_ok();
}

cell pp_sys_command_line(void) {
	extern cell	Argv;

	return Argv;
}

cell pp_sys_creat(void) {
	int	fd;

	fd = open(string(parg(1)), O_CREAT|O_TRUNC|O_WRONLY,
			integer_value("sys:creat", parg(2)));
	if (fd < 0) return sys_error("sys:creat");
	return make_integer(fd);
}

cell pp_sys_dup(void) {
	int	r;

	r = dup(integer_value("sys:dup", parg(1)));
	if (r < 0) return sys_error("sys:dup");
	return make_integer(r);
}

cell pp_sys_dup2(void) {
	int	r;
	char	name[] = "sys:dup2";

	r = dup2(integer_value(name, parg(1)),
			integer_value(name, parg(2)));
	if (r < 0) return sys_error("sys:dup2");
	return make_integer(r);
}

cell pp_sys_errno(void) {
	int	e = Last_errno;

	Last_errno = 0;
	return make_integer(e);
}

cell pp_sys_execv(void) {
	char	**argv;
	cell	p;
	int	i;

	for (p = parg(2); p != NIL; p = cdr(p)) {
		if (!pair_p(p))
			error("sys:execv: improper list, last element is",
				p);
		if (!string_p(car(p)))
			error("sys:execv: expected list of string, got",
				car(p));
	}
	argv = malloc((length(parg(2)) + 2) * sizeof(char *));
	if (argv == NULL) return sys_error("sys:execv");
	argv[0] = string(parg(1));
	i = 1;
	for (p = parg(2); p != NIL; p = cdr(p))
		argv[i++] = string(car(p));
	argv[i] = NULL;
	execv(string(parg(1)), argv);
	free(argv);
	return sys_error("sys:execv");
}

cell pp_sys_exit(void) {
	int	r;

	r = integer_value("sys:exit", parg(1));
	if (r > 255 || r < 0)
		error("sys:exit: value out of range", parg(1));
	exit(r);
	fatal("sys:exit() failed");
	return sys_ok();
}

cell pp_sys_fileno(void) {
	if (!input_port_p(parg(1)) && !output_port_p(parg(1)))
		error("sys:fileno: expected port, got", parg(1));
	if (Ports[port_no(parg(1))] == NULL)
		error("sys:fileno: port not open", parg(1));
	return make_integer(fileno(Ports[port_no(parg(1))]));
}

cell pp_sys_flush(void) {
	if (fflush(Ports[port_no(parg(1))]))
		return sys_error("sys:flush");
	return sys_ok();
}

cell pp_sys_fork(void) {
	int	pid;

	pid = fork();
	if (pid < 0) return sys_error("sys:fork");
	return make_integer(pid);
}

cell pp_sys_getcwd(void) {
	char	*s;
	cell	n;

	s = getcwd(NULL, 1024);
	n = make_string(s, strlen(s));
	free(s);
	return n;
}

cell pp_sys_getenv(void) {
	char	*s;

	s = getenv(string(parg(1)));
	if (NULL == s) return FALSE;
	return make_string(s, strlen(s));
}

cell pp_sys_getgid(void) {
	return make_integer(getgid());
}

cell mkgrent(struct group *gr) {
	cell	n, a;

	n = cons(NIL, NIL);
	save(n);
	assign(car(n), cons(symbol_ref("name"), NIL));
	assign(cdar(n), make_string(gr->gr_name, strlen(gr->gr_name)));
	a = cons(NIL, NIL);
	cdr(n) = a;
	assign(car(a), cons(symbol_ref("gid"), NIL));
	assign(cdar(a), make_integer(gr->gr_gid));
	unsave(1);
	return n;
}

cell pp_sys_getgrnam(void) {
	struct group	*gr;

	gr = getgrnam(string(parg(1)));
	if (gr == NULL) return FALSE;
	return mkgrent(gr);
}

cell pp_sys_getgrgid(void) {
	struct group	*gr;

	gr = getgrgid(integer_value("sys:getgrgid", parg(1)));
	if (gr == NULL) return FALSE;
	return mkgrent(gr);
}

cell pp_sys_getpgid(void) {
	/* No prototype, neither on FreeBSD 8.2 nor on Debian Lenny? */
	pid_t	getpgid(pid_t);

	return make_integer(getpgid(0));
}

cell pp_sys_getpid(void) {
	return make_integer(getpid());
}

cell pp_sys_getpwent(void) {
	struct passwd	*pw;
	cell		n, a, pa;

	setpwent();
	n = cons(NIL, NIL);
	save(n);
	a = n;
	pa = n;
	while (1) {
		pw = getpwent();
		if (pw == NULL)
			break;
		pa = a;
		assign(car(a), make_string(pw->pw_name, strlen(pw->pw_name)));
		if (pw != NULL) {
			assign(cdr(a), cons(NIL, NIL));
			a = cdr(a);
		}
	}
	cdr(pa) = NIL;
	endpwent();
	unsave(1);
	return n;
}

cell mkpwent(struct passwd *pw) {
	cell	n, a;

	n = cons(NIL, NIL);
	save(n);
	assign(car(n), cons(symbol_ref("name"), NIL));
	assign(cdar(n), make_string(pw->pw_name, strlen(pw->pw_name)));
	a = cons(NIL, NIL);
	cdr(n) = a;
	assign(car(a), cons(symbol_ref("uid"), NIL));
	assign(cdar(a), make_integer(pw->pw_uid));
	assign(cdr(a), cons(NIL, NIL));
	a = cdr(a);
	assign(car(a), cons(symbol_ref("gid"), NIL));
	assign(cdar(a), make_integer(pw->pw_gid));
	assign(cdr(a), cons(NIL, NIL));
	a = cdr(a);
	assign(car(a), cons(symbol_ref("gecos"), NIL));
	assign(cdar(a), make_string(pw->pw_gecos, strlen(pw->pw_gecos)));
	assign(cdr(a), cons(NIL, NIL));
	a = cdr(a);
	assign(car(a), cons(symbol_ref("home"), NIL));
	assign(cdar(a), make_string(pw->pw_dir, strlen(pw->pw_dir)));
	assign(cdr(a), cons(NIL, NIL));
	a = cdr(a);
	assign(car(a), cons(symbol_ref("shell"), NIL));
	assign(cdar(a), make_string(pw->pw_shell, strlen(pw->pw_shell)));
	unsave(1);
	return n;
}

cell pp_sys_getpwnam(void) {
	struct passwd	*pw;

	pw = getpwnam(string(parg(1)));
	if (pw == NULL) return FALSE;
	return mkpwent(pw);
}

cell pp_sys_getpwuid(void) {
	struct passwd	*pw;

	pw = getpwuid(integer_value("sys:getpwuid", parg(1)));
	if (pw == NULL) return FALSE;
	return mkpwent(pw);
}

cell pp_sys_getuid(void) {
	return make_integer(getuid());
}

cell pp_sys_kill(void) {
	char	name[] = "sys:kill";
	int	sig = integer_value(name, parg(2));
	int	r;

	r = kill(integer_value(name, parg(1)), sig);
	if (r < 0) return sys_error("sys:kill");
	return sys_ok();
}

cell pp_sys_link(void) {
	if (link(string(parg(1)), string(parg(2))) < 0)
		return sys_error("sys:link");
	return sys_ok();
}

cell pp_sys_lock(void) {
	char	p[256], *s;

	s = string(parg(1));
	if (strlen(s) > 248)
		error("sys:lock: path too long", parg(1));
	sprintf(p, "%s.lock", s);
	return (mkdir(p, 0700) < 0)? FALSE: TRUE;
}

cell pp_sys_lseek(void) {
	char	name[] = "sys:lseek";
	long	r;

	r = lseek(integer_value(name, parg(1)),
		integer_value(name, parg(2)),
		integer_value(name, parg(3)));
	if (r < 0L) return sys_error("sys:lseek");
	return make_integer(r);
}

cell pp_sys_get_magic_value(void) {
	char	*s = string(parg(1));

	if (!strcmp(s, "F_OK")) return make_integer(F_OK);
	if (!strcmp(s, "X_OK")) return make_integer(X_OK);
	if (!strcmp(s, "W_OK")) return make_integer(W_OK);
	if (!strcmp(s, "R_OK")) return make_integer(R_OK);
	if (!strcmp(s, "O_RDONLY")) return make_integer(O_RDONLY);
	if (!strcmp(s, "O_WRONLY")) return make_integer(O_WRONLY);
	if (!strcmp(s, "O_RDWR")) return make_integer(O_RDWR);
	if (!strcmp(s, "SEEK_SET")) return make_integer(SEEK_SET);
	if (!strcmp(s, "SEEK_CUR")) return make_integer(SEEK_CUR);
	if (!strcmp(s, "SEEK_END")) return make_integer(SEEK_END);
	if (!strcmp(s, "SIGHUP")) return make_integer(SIGHUP);
	if (!strcmp(s, "SIGINT")) return make_integer(SIGINT);
	if (!strcmp(s, "SIGQUIT")) return make_integer(SIGQUIT);
	if (!strcmp(s, "SIGILL")) return make_integer(SIGILL);
	if (!strcmp(s, "SIGTRAP")) return make_integer(SIGTRAP);
	if (!strcmp(s, "SIGABRT")) return make_integer(SIGABRT);
	if (!strcmp(s, "SIGEMT")) return make_integer(SIGEMT);
	if (!strcmp(s, "SIGFPE")) return make_integer(SIGFPE);
	if (!strcmp(s, "SIGKILL")) return make_integer(SIGKILL);
	if (!strcmp(s, "SIGBUS")) return make_integer(SIGBUS);
	if (!strcmp(s, "SIGSEGV")) return make_integer(SIGSEGV);
	if (!strcmp(s, "SIGSYS")) return make_integer(SIGSYS);
	if (!strcmp(s, "SIGPIPE")) return make_integer(SIGPIPE);
	if (!strcmp(s, "SIGALRM")) return make_integer(SIGALRM);
	if (!strcmp(s, "SIGTERM")) return make_integer(SIGTERM);
	if (!strcmp(s, "S_ISUID")) return make_integer(S_ISUID);
	if (!strcmp(s, "S_ISGID")) return make_integer(S_ISGID);
	if (!strcmp(s, "S_ISVTX")) return make_integer(S_ISVTX);
	if (!strcmp(s, "S_IRUSR")) return make_integer(S_IRUSR);
	if (!strcmp(s, "S_IRWXU")) return make_integer(S_IRWXU);
	if (!strcmp(s, "S_IWUSR")) return make_integer(S_IWUSR);
	if (!strcmp(s, "S_IXUSR")) return make_integer(S_IXUSR);
	if (!strcmp(s, "S_IRWXG")) return make_integer(S_IRWXG);
	if (!strcmp(s, "S_IRGRP")) return make_integer(S_IRGRP);
	if (!strcmp(s, "S_IWGRP")) return make_integer(S_IWGRP);
	if (!strcmp(s, "S_IXGRP")) return make_integer(S_IXGRP);
	if (!strcmp(s, "S_IRWXO")) return make_integer(S_IRWXO);
	if (!strcmp(s, "S_IROTH")) return make_integer(S_IROTH);
	if (!strcmp(s, "S_IWOTH")) return make_integer(S_IWOTH);
	if (!strcmp(s, "S_IXOTH")) return make_integer(S_IXOTH);
	else error("sys:get-magic-value: requested value not found",
			parg(1));
	return UNDEFINED;
}

cell pp_sys_make_input_port(void) {
	int	in = new_port();

	if (in < 0) error("sys:make-input-port: out of ports", VOID);
	Ports[in] = fdopen(integer_value("sys:make-input-port", parg(1)),
				"r");
	return make_port(in, T_INPUT_PORT);
}

cell pp_sys_make_output_port(void) {
	int	out = new_port();

	if (out < 0) error("sys:make-output-port: out of ports", VOID);
	Ports[out] = fdopen(integer_value("sys:make-output-port", parg(1)),
				"w");
	return make_port(out, T_OUTPUT_PORT);
}

cell pp_sys_mkdir(void) {
	if (mkdir(string(parg(1)), integer_value("sys:mkdir", parg(2))) < 0)
		return sys_error("sys:mkdir");
	return sys_ok();
}

cell pp_sys_open(void) {
	int	fd;

	fd = open(string(parg(1)), integer_value("sys:open", parg(2)));
	if (fd < 0) return sys_error("sys:open");
	return make_integer(fd);
}

cell pp_sys_pipe(void) {
	int	fd[2];
	cell	n;

	if (pipe(fd) < 0) return sys_error("sys:pipe");
	n = cons(make_integer(fd[1]), NIL);
	save(n);
	n = cons(make_integer(fd[0]), n);
	unsave(1);
	return n;
}

cell pp_sys_read(void) {
	cell	buf, buf2;
	int	r, k;
	char	name[] = "sys:read";

	k = integer_value(name, parg(2));
	buf = make_string("", k);
	r = read(integer_value(name, parg(1)), string(buf), k);
	if (r < 0)
		return sys_error("sys:read");
	if (r < k) {
		save(buf);
		buf2 = make_string("", r);
		unsave(1);
		strcpy(string(buf2), string(buf));
		buf = buf2;
	}
	return buf;
}

cell pp_sys_readdir(void) {
	DIR		*dir;
	struct dirent	*dp;
	cell		n, a, pa;

	dir = opendir(string(parg(1)));
	if (dir == NULL) return sys_error("sys:readdir");
	n = cons(NIL, NIL);
	save(n);
	a = n;
	pa = n;
	while (1) {
		dp = readdir(dir);
		if (dp == NULL)
			break;
		if (	!strcmp(dp->d_name, ".") ||
			!strcmp(dp->d_name, "..")
		)
			continue;
		pa = a;
		assign(car(a), make_string(dp->d_name, strlen(dp->d_name)));
		assign(cdr(a), cons(NIL, NIL));
		a = cdr(a);
	}
	cdr(pa) = NIL;
	if (car(n) == NIL) n = NIL;
	closedir(dir);
	unsave(1);
	return n;
}

cell pp_sys_readlink(void) {
	char	buf[MAXPATHLEN+1];
	int	k;

	k = readlink(string(parg(1)), buf, MAXPATHLEN);
	if (k < 0) return sys_error("sys:readlink");
	buf[k] = 0;
	return make_string(buf, k);
}

cell pp_sys_rename(void) {
	int	r;

	r = rename(string(parg(1)), string(parg(2)));
	if (r < 0) return sys_error("sys:rename");
	return sys_ok();
}

cell pp_sys_rmdir(void) {
	if (rmdir(string(parg(1))) < 0)
		return sys_error("sys:rmdir");
	return sys_ok();
}

cell pp_sys_select(void) {
	cell		p;
	struct timeval	tv, *tvp;
	fd_set		rset, wset;
	char		name[] = "sys:select";
	int		r, k, nfd;
	char		msg[] = "sys:select: expected list of integer, got";

	if (	parg(1) != NIL &&
		(!integer_p(car(parg(1))) ||
		 cdr(parg(1)) == NIL ||
		 !integer_p(cadr(parg(1))) ||
		 cddr(parg(1)) != NIL)
	) {
		error(msg, parg(1));
	}
	FD_ZERO(&rset);
	nfd = 0;
	for (p = parg(2); p != NIL; p = cdr(p)) {
		if (!pair_p(p))
			error("sys:select: improper list", parg(2));
		if (!integer_p(car(p)))
			error(msg, parg(2));
		k = integer_value(name, car(p));
		FD_SET(k, &rset);
		if (k > nfd) nfd = k;
	}
	FD_ZERO(&wset);
	for (p = parg(3); p != NIL; p = cdr(p)) {
		if (!pair_p(p))
			error("sys:select: improper list", parg(3));
		if (!integer_p(car(p)))
			error(msg, parg(3));
		k = integer_value(name, car(p));
		FD_SET(k, &wset);
		if (k > nfd) nfd = k;
	}
	nfd++;
	if (parg(1) == NIL) {
		tvp = NULL;
	}
	else {
		tv.tv_sec = integer_value(name, car(parg(1)));
		tv.tv_usec = integer_value(name, cadr(parg(1)));
		tvp = &tv;
	}
	r = select(nfd, &rset, &wset, NULL, tvp);
	if (r < 0) return sys_error(name);
	return r==0? FALSE: make_integer(r);
}

cell pp_sys_setgid(void) {
	if (setgid(integer_value("sys:setgid", parg(1))) < 0)
		return sys_error("sys:setgid");
	return sys_ok();
}

cell pp_sys_setpgid(void) {
	int	r;

	r = setpgid(0, integer_value("sys:setpgid", parg(1)));
	if (r < 0) return sys_error("sys:setpgid");
	return sys_ok();
}

cell pp_sys_setuid(void) {
	if (setuid(integer_value("sys:setgid", parg(1))) < 0)
		return sys_error("sys:setuid");
	return sys_ok();
}

cell pp_sys_sleep(void) {
	if (sleep(integer_value("sys:sleep", parg(1))))
		return sys_error("sys:sleep");
	return sys_ok();
}

cell sys_stat(int follow) {
	struct stat	sb;
	cell		n, a;

	if ((follow? stat: lstat)(string(parg(1)), &sb) < 0)
		return sys_error(NULL);
	n = cons(NIL, NIL);
	save(n);
	assign(car(n), cons(symbol_ref("name"), parg(1)));
	a = cons(NIL, NIL);
	cdr(n) = a;
	assign(car(a), cons(symbol_ref("size"), NIL));
	assign(cdar(a), make_integer(sb.st_size));
	assign(cdr(a), cons(NIL, NIL));
	a = cdr(a);
	assign(car(a), cons(symbol_ref("uid"), NIL));
	assign(cdar(a), make_integer(sb.st_uid));
	assign(cdr(a), cons(NIL, NIL));
	a = cdr(a);
	assign(car(a), cons(symbol_ref("gid"), NIL));
	assign(cdar(a), make_integer(sb.st_gid));
	assign(cdr(a), cons(NIL, NIL));
	a = cdr(a);
	assign(car(a), cons(symbol_ref("mode"), NIL));
	assign(cdar(a), make_integer(sb.st_mode));
	assign(cdr(a), cons(NIL, NIL));
	a = cdr(a);
	assign(car(a), cons(symbol_ref("ctime"), NIL));
	assign(cdar(a), make_integer(sb.st_ctime));
	assign(cdr(a), cons(NIL, NIL));
	a = cdr(a);
	assign(car(a), cons(symbol_ref("atime"), NIL));
	assign(cdar(a), make_integer(sb.st_atime));
	assign(cdr(a), cons(NIL, NIL));
	a = cdr(a);
	assign(car(a), cons(symbol_ref("mtime"), NIL));
	assign(cdar(a), make_integer(sb.st_mtime));
	assign(cdr(a), cons(NIL, NIL));
	a = cdr(a);
	assign(car(a), cons(symbol_ref("dev"), NIL));
	assign(cdar(a), make_integer(sb.st_dev));
	assign(cdr(a), cons(NIL, NIL));
	a = cdr(a);
	assign(car(a), cons(symbol_ref("ino"), NIL));
	assign(cdar(a), make_integer(sb.st_ino));
	assign(cdr(a), cons(NIL, NIL));
	a = cdr(a);
	assign(car(a), cons(symbol_ref("nlink"), NIL));
	assign(cdar(a), make_integer(sb.st_nlink));
	unsave(1);
	return n;
}

cell pp_sys_stat(void) {
	return sys_stat(1);
}

cell pp_sys_lstat(void) {
	return sys_stat(0);
}

int stat_mode(char *who, int follow) {
	struct stat	st;

	if ((follow? stat: lstat)(string(parg(1)), &st) < 0)
		return sys_error(who);
	return st.st_mode;
}

cell pp_sys_stat_block_dev_p(void) {
	return S_ISBLK(stat_mode("stat-block-dev?", 1))? TRUE: FALSE;
}

cell pp_sys_stat_char_dev_p(void) {
	return S_ISCHR(stat_mode("stat-char-dev?", 1))? TRUE: FALSE;
}

cell pp_sys_stat_directory_p(void) {
	return S_ISDIR(stat_mode("stat-directory?", 1))? TRUE: FALSE;
}

cell pp_sys_stat_pipe_p(void) {
	return S_ISFIFO(stat_mode("stat-pipe?", 1))? TRUE: FALSE;
}

cell pp_sys_stat_regular_p(void) {
	return S_ISREG(stat_mode("stat-regular?", 1))? TRUE: FALSE;
}

cell pp_sys_stat_socket_p(void) {
	return S_ISSOCK(stat_mode("stat-socket?", 1))? TRUE: FALSE;
}

cell pp_sys_lstat_block_dev_p(void) {
	return S_ISBLK(stat_mode("lstat-block-dev?", 0))? TRUE: FALSE;
}

cell pp_sys_lstat_char_dev_p(void) {
	return S_ISCHR(stat_mode("lstat-char-dev?", 0))? TRUE: FALSE;
}

cell pp_sys_lstat_directory_p(void) {
	return S_ISDIR(stat_mode("lstat-directory?", 0))? TRUE: FALSE;
}

cell pp_sys_lstat_pipe_p(void) {
	return S_ISFIFO(stat_mode("lstat-pipe?", 0))? TRUE: FALSE;
}

cell pp_sys_lstat_regular_p(void) {
	return S_ISREG(stat_mode("lstat-regular?", 0))? TRUE: FALSE;
}

cell pp_sys_lstat_socket_p(void) {
	return S_ISSOCK(stat_mode("lstat-socket?", 0))? TRUE: FALSE;
}

cell pp_sys_lstat_symlink_p(void) {
	return S_ISLNK(stat_mode("lstat-symlink?", 0))? TRUE: FALSE;
}

cell pp_sys_strerror(void) {
	char	*s = strerror(integer_value("sys:strerror", parg(1)));

	return make_string(s, strlen(s));
}

cell pp_sys_symlink(void) {
	if (symlink(string(parg(1)), string(parg(2))) < 0)
		return sys_error("sys:symlink");
	return sys_ok();
}

cell pp_sys_system(void) {
	int	r;

	r = system(string(parg(1)));
	if (r < 0 || r > 127) return sys_error("sys:system");
	return make_integer(r);
}

cell pp_sys_gettimeofday(void) {
	struct timeval	t;
	cell		n, m;

	gettimeofday(&t, NULL);
	n = make_integer(t.tv_usec);
	n = cons(n, NIL);
	save(n);
	m = make_integer(t.tv_sec);
	n = cons(m, n);
	unsave(1);
	return n;
}

cell pp_sys_umask(void) {
	int	r;

	if (0 == narg())
		umask(r = umask(0));
	else
		r = umask(integer_value("sys:umask", parg(1)));
	return make_integer(r);
}

cell pp_sys_unlink(void) {
	if (unlink(string(parg(1))) < 0)
		return sys_error("sys:unlink");
	return sys_ok();
}

cell pp_sys_unlock(void) {
	char	p[256], *s;

	s = string(parg(1));
	if (strlen(s) > 248)
		error("sys:unlock: path too long", parg(1));
	sprintf(p, "%s.lock", s);
	rmdir(p);
	return sys_ok();
}

cell pp_sys_usleep(void) {
#if __FreeBSD__ == 7
	int usleep(useconds_t microseconds);
#endif
	if (usleep(integer_value("sys:usleep", parg(1))))
		return sys_error("sys:usleep");
	return sys_ok();
}

cell pp_sys_utimes(void) {
	if (utimes(string(parg(1)), NULL) < 0)
		return sys_error("sys:utimes");
	return sys_ok();
}

cell pp_sys_wait(void) {
	int	r, status;
	cell	n;

	r = wait(&status);
	if (r < 0) return sys_error("sys:wait");
	n = cons(make_integer(r), NIL);
	save(n);
	n = cons(make_integer(WEXITSTATUS(status)), n);
	unsave(1);
	return n;
}

cell pp_sys_waitpid(void) {
	int	r, status;
	char	name[] = "sys:waitpid";

	r = waitpid(integer_value(name, parg(1)), &status, WNOHANG);
	if (r < 0) return sys_error(name);
	return r == 0? FALSE: make_integer(WEXITSTATUS(status));
}

cell pp_sys_write(void) {
	int	r;

	r = write(integer_value("sys:write", parg(1)), string(parg(2)),
		string_len(parg(2))-1);
	if (r < 0) return sys_error("sys:write");
	return make_integer(r);
}

#ifdef NETWORK

cell pp_sys_inet_accept(void) {
	int	r;

	r = accept(integer_value("sys:inet-accept", parg(1)), NULL, 0);
	if (r < 0) return sys_error("sys:inet-accept");
	return make_integer(r);
}

cell pp_sys_inet_connect(void) {
	struct addrinfo	hints, *res, *rp;
	int 		s;
	int		r;

	memset(&hints, 0, sizeof(hints));
	hints.ai_family = AF_UNSPEC;
	hints.ai_socktype = SOCK_STREAM;
	r = getaddrinfo(string(parg(1)), string(parg(1)), &hints, &res);
	if (r != 0)
		return sys_error("sys:inet-connect/getaddrinfo");
	s = -1;
	for (rp = res; s < 0 && rp; rp = rp->ai_next) {
		s = socket(rp->ai_family, rp->ai_socktype, rp->ai_protocol);
		if (s < 0)
                           continue;
		if (connect(s, rp->ai_addr, rp->ai_addrlen) < 0) {
			close(s);
			s = -1;
			continue;
		}
	}
	if (s < 0)
		return sys_error("sys:inet-connect");
	freeaddrinfo(res);
	return make_integer(s);
}

cell pp_sys_inet_getpeername(void) {
	socklen_t		len;
	struct sockaddr_storage addr;
	char			ip[128];
	int			port, fd;
	cell			n, m;

	fd = integer_value("sys:inet-getpeername", parg(1));
	len = sizeof addr;
	if (getpeername(fd, (struct sockaddr *) &addr, &len) < 0)
		return sys_error(NULL);
	if (addr.ss_family == AF_INET6) {
		struct sockaddr_in6 *s = (struct sockaddr_in6 *) &addr;
		port = ntohs(s->sin6_port);
		inet_ntop(AF_INET6, &s->sin6_addr, ip, sizeof ip);
	}
	else {
		struct sockaddr_in *s = (struct sockaddr_in *) &addr;
		port = ntohs(s->sin_port);
		inet_ntop(AF_INET, &s->sin_addr, ip, sizeof ip);
	}
	n = cons(make_integer(port), NIL);
	save(n);
	m = make_string(ip, strlen(ip));
	n = cons(m, n);
	unsave(1);
	return n;
}

cell pp_sys_inet_listen(void) {
	struct addrinfo	hints, *res, *rp;
	int		s;
	int		r, maxq;
	char		*host;
	struct utsname	u;

	maxq = integer_value("sys:inet-listen", parg(3));
	if (string_p(parg(1))) {
		host = string(parg(1));
	}
	else if (parg(1) == TRUE) {
		r = uname(&u);
		if (r < 0)
			return sys_error("sys:inet-listen/uname");
		host = u.nodename;
	}
	else {
		error("sys:inet-listen: expected string or #t, got",
			parg(1));
		return UNDEFINED; /*LINT*/
	}
	memset(&hints, 0, sizeof(hints));
	hints.ai_family = AF_UNSPEC;
	hints.ai_socktype = SOCK_STREAM;
	hints.ai_flags = AI_PASSIVE;
	r = getaddrinfo(host, string(parg(2)), &hints, &res);
	if (r != 0)
		return sys_error("sys:inet-listen/getaddrinfo");
	s = -1;
	for (rp = res; s < 0 && rp; rp = rp->ai_next) {
		s = socket(rp->ai_family, rp->ai_socktype, rp->ai_protocol);
		if (s < 0)
			continue;
		if (bind(s, rp->ai_addr, rp->ai_addrlen) < 0) {
			close(s);
			s = -1;
			continue;
		}
		listen(s, maxq);
	}
	if (s < 0)
		return sys_error("sys:inet-listen");
	freeaddrinfo(res);
	return make_integer(s);
}

#endif /* NETWORK */

S9_PRIM Unix_primitives[] = {
 { "sys:access",           pp_sys_access,           2,  2, { STR,INT,___ } },
 { "sys:catch-errors",     pp_sys_catch_errors,     1,  1, { BOL,___,___ } },
 { "sys:chdir",            pp_sys_chdir,            1,  1, { STR,___,___ } },
 { "sys:close",            pp_sys_close,            1,  1, { INT,___,___ } },
 { "sys:chmod",            pp_sys_chmod,            2,  2, { STR,INT,___ } },
 { "sys:chown",            pp_sys_chown,            3,  3, { STR,INT,INT } },
 { "sys:command-line",     pp_sys_command_line,     0,  0, { ___,___,___ } },
 { "sys:creat",            pp_sys_creat,            2,  2, { STR,INT,___ } },
 { "sys:dup",              pp_sys_dup,              1,  1, { INT,___,___ } },
 { "sys:dup2",             pp_sys_dup2,             2,  2, { INT,INT,___ } },
 { "sys:errno",            pp_sys_errno,            0,  0, { ___,___,___ } },
 { "sys:execv",            pp_sys_execv,            2,  2, { STR,LST,___ } },
 { "sys:exit",             pp_sys_exit,             1,  1, { INT,___,___ } },
 { "sys:fileno",           pp_sys_fileno,           1,  1, { ___,___,___ } },
 { "sys:flush",            pp_sys_flush,            1,  1, { OUP,___,___ } },
 { "sys:fork",             pp_sys_fork,             0,  0, { ___,___,___ } },
 { "sys:getcwd",           pp_sys_getcwd,           0,  0, { ___,___,___ } },
 { "sys:getenv",           pp_sys_getenv,           1,  1, { STR,___,___ } },
 { "sys:getgid",           pp_sys_getgid,           0,  0, { ___,___,___ } },
 { "sys:getgrnam",         pp_sys_getgrnam,         1,  1, { STR,___,___ } },
 { "sys:getgrgid",         pp_sys_getgrgid,         1,  1, { INT,___,___ } },
 { "sys:getpgid",          pp_sys_getpgid,          0,  0, { ___,___,___ } },
 { "sys:getpid",           pp_sys_getpid,           0,  0, { ___,___,___ } },
 { "sys:getpwent",         pp_sys_getpwent,         0,  0, { ___,___,___ } },
 { "sys:getpwnam",         pp_sys_getpwnam,         1,  1, { STR,___,___ } },
 { "sys:getpwuid",         pp_sys_getpwuid,         1,  1, { INT,___,___ } },
 { "sys:gettimeofday",     pp_sys_gettimeofday,     0,  0, { ___,___,___ } },
 { "sys:getuid",           pp_sys_getuid,           0,  0, { ___,___,___ } },
 { "sys:kill",             pp_sys_kill,             2,  2, { INT,INT,___ } },
 { "sys:link",             pp_sys_link,             2,  2, { STR,STR,___ } },
 { "sys:lock",             pp_sys_lock,             1,  1, { STR,___,___ } },
 { "sys:lseek",            pp_sys_lseek,            3,  3, { INT,INT,INT } },
 { "sys:lstat",            pp_sys_lstat,            1,  1, { STR,___,___ } },
 { "sys:lstat-block-dev?", pp_sys_lstat_block_dev_p,1,  1, { STR,___,___ } },
 { "sys:lstat-char-dev?",  pp_sys_lstat_char_dev_p, 1,  1, { STR,___,___ } },
 { "sys:lstat-directory?", pp_sys_lstat_directory_p,1,  1, { STR,___,___ } },
 { "sys:lstat-pipe?",      pp_sys_lstat_pipe_p,     1,  1, { STR,___,___ } },
 { "sys:lstat-regular?",   pp_sys_lstat_regular_p,  1,  1, { STR,___,___ } },
 { "sys:lstat-socket?",    pp_sys_lstat_socket_p,   1,  1, { STR,___,___ } },
 { "sys:lstat-symlink?",   pp_sys_lstat_symlink_p,  1,  1, { STR,___,___ } },
 { "sys:get-magic-value",  pp_sys_get_magic_value,  1,  1, { STR,___,___ } },
 { "sys:make-input-port",  pp_sys_make_input_port,  1,  1, { INT,___,___ } },
 { "sys:make-output-port", pp_sys_make_output_port, 1,  1, { INT,___,___ } },
 { "sys:mkdir",            pp_sys_mkdir,            2,  2, { STR,INT,___ } },
 { "sys:open",             pp_sys_open,             2,  2, { STR,INT,___ } },
 { "sys:pipe",             pp_sys_pipe,             0,  0, { ___,___,___ } },
 { "sys:read",             pp_sys_read,             2,  2, { INT,INT,___ } },
 { "sys:readdir",          pp_sys_readdir,          1,  1, { STR,___,___ } },
 { "sys:readlink",         pp_sys_readlink,         1,  1, { STR,___,___ } },
 { "sys:rename",           pp_sys_rename,           2,  2, { STR,STR,___ } },
 { "sys:rmdir",            pp_sys_rmdir,            1,  1, { STR,___,___ } },
 { "sys:setgid",           pp_sys_setgid,           1,  1, { INT,___,___ } },
 { "sys:select",           pp_sys_select,           3,  3, { LST,LST,LST } },
 { "sys:setpgid",          pp_sys_setpgid,          1,  1, { INT,___,___ } },
 { "sys:setuid",           pp_sys_setuid,           1,  1, { INT,___,___ } },
 { "sys:sleep",            pp_sys_sleep,            1,  1, { INT,___,___ } },
 { "sys:stat",             pp_sys_stat,             1,  1, { STR,___,___ } },
 { "sys:stat-block-dev?",  pp_sys_stat_block_dev_p, 1,  1, { STR,___,___ } },
 { "sys:stat-char-dev?",   pp_sys_stat_char_dev_p,  1,  1, { STR,___,___ } },
 { "sys:stat-directory?",  pp_sys_stat_directory_p, 1,  1, { STR,___,___ } },
 { "sys:stat-pipe?",       pp_sys_stat_pipe_p,      1,  1, { STR,___,___ } },
 { "sys:stat-regular?",    pp_sys_stat_regular_p,   1,  1, { STR,___,___ } },
 { "sys:stat-socket?",     pp_sys_stat_socket_p,    1,  1, { STR,___,___ } },
 { "sys:strerror",         pp_sys_strerror,         1,  1, { INT,___,___ } },
 { "sys:symlink",          pp_sys_symlink,          2,  2, { STR,STR,___ } },
 { "sys:system",           pp_sys_system,           1,  1, { STR,___,___ } },
 { "sys:umask",            pp_sys_umask,            0,  1, { INT,___,___ } },
 { "sys:unlink",           pp_sys_unlink,           1,  1, { STR,___,___ } },
 { "sys:unlock",           pp_sys_unlock,           1,  1, { STR,___,___ } },
 { "sys:usleep",           pp_sys_usleep,           1,  1, { INT,___,___ } },
 { "sys:utimes",           pp_sys_utimes,           1,  1, { STR,___,___ } },
 { "sys:wait",             pp_sys_wait,             0,  0, { ___,___,___ } },
 { "sys:waitpid",          pp_sys_waitpid,          1,  1, { INT,___,___ } },
 { "sys:write",            pp_sys_write,            2,  2, { INT,STR,___ } },
#ifdef NETWORK
 { "sys:inet-accept",      pp_sys_inet_accept,      1,  1, { INT,___,___ } },
 { "sys:inet-connect",     pp_sys_inet_connect,     2,  2, { STR,STR,___ } },
 { "sys:inet-getpeername", pp_sys_inet_getpeername, 1,  1, { INT,___,___ } },
 { "sys:inet-listen",      pp_sys_inet_listen,      3,  3, { ___,STR,INT } },
#endif /* NETWORK */
 { NULL }
};

void sys_init(void) {
	signal(SIGPIPE, SIG_IGN);
	add_primitives("sys-unix", Unix_primitives);
#ifdef NETWORK
	add_primitives("net-unix", NULL);
#endif /* NETWORK */
}

contact  |  privacy