diff options
91 files changed, 4141 insertions, 0 deletions
diff --git a/otherlibs/unix/Makefile b/otherlibs/unix/Makefile new file mode 100644 index 0000000000..3542eeb4d7 --- /dev/null +++ b/otherlibs/unix/Makefile @@ -0,0 +1,57 @@ +# Makefile for the Unix interface library + +include ../../Makefile.config + +# Compilation options +CFLAGS=-I../../byterun -O $(CCCOMPOPTS) +CAMLC=../../boot/camlrun ../../boot/camlc -I ../../boot + +OBJS=accept.o access.o addrofstr.o alarm.o bind.o chdir.o chmod.o \ + chown.o chroot.o close.o closedir.o connect.o cst2constr.o cstringv.o \ + dup.o dup2.o envir.o errmsg.o execv.o execve.o execvp.o exit.o \ + fchmod.o fchown.o fcntl.o fork.o ftruncate.o getcwd.o getegid.o \ + geteuid.o getgid.o getgr.o getgroups.o gethost.o gethostname.o \ + getlogin.o getpid.o getppid.o getproto.o getpw.o getserv.o getuid.o \ + gmtime.o ioctl.o kill.o link.o listen.o lockf.o lseek.o mkdir.o \ + mkfifo.o nice.o open.o opendir.o pause.o pipe.o read.o \ + readdir.o readlink.o rename.o rewinddir.o rmdir.o select.o sendrecv.o \ + setgid.o setuid.o shutdown.o sleep.o socket.o socketaddr.o \ + socketpair.o stat.o strofaddr.o symlink.o termios.o time.o times.o \ + truncate.o umask.o unix.o unlink.o utimes.o wait.o waitpid.o \ + write.o + +INTF= unix.cmi +IMPL= unix.cmo +LIB= unix.cma + +all: libunix.a $(INTF) $(LIB) + +libunix.a: $(OBJS) + rm -f libunix.a + ar rc libunix.a $(OBJS) + $(RANLIB) libunix.a + +unix.cma: $(IMPL) + $(CAMLC) -a -o unix.cma $(IMPL) + +clean: + rm -f libunix.a *.o *.cm[ioa] + +install: + cp libunix.a $(LIBDIR)/libunix.a + cd $(LIBDIR); $(RANLIB) libunix.a + cp $(INTF) $(LIB) $(LIBDIR) + +.SUFFIXES: .ml .mli .cmo .cmi + +.mli.cmi: + $(CAMLC) -c $(COMPFLAGS) $< + +.ml.cmo: + $(CAMLC) -c $(COMPFLAGS) $< + +depend: + gcc -MM $(CFLAGS) *.c > .depend + ../../tools/camldep *.mli *.ml >> .depend + +include .depend diff --git a/otherlibs/unix/accept.c b/otherlibs/unix/accept.c new file mode 100644 index 0000000000..0018663192 --- /dev/null +++ b/otherlibs/unix/accept.c @@ -0,0 +1,34 @@ +#include <mlvalues.h> +#include <alloc.h> +#include <memory.h> +#include "unix.h" + +#ifdef HAS_SOCKETS + +#include "socketaddr.h" + +value unix_accept(sock) /* ML */ + value sock; +{ + int retcode; + value res; + Push_roots(a,1); + + sock_addr_len = sizeof(sock_addr); + enter_blocking_section(); + retcode = accept(Int_val(sock), &sock_addr.s_gen, &sock_addr_len); + leave_blocking_section(); + if (retcode == -1) uerror("accept", Nothing); + a[0] = alloc_sockaddr(); + res = alloc_tuple(2); + Field(res, 0) = Val_int(retcode); + Field(res, 1) = a[0]; + Pop_roots(); + return res; +} + +#else + +value unix_accept() { invalid_argument("accept not implemented"); } + +#endif diff --git a/otherlibs/unix/access.c b/otherlibs/unix/access.c new file mode 100644 index 0000000000..d23ee68b62 --- /dev/null +++ b/otherlibs/unix/access.c @@ -0,0 +1,30 @@ +#include <mlvalues.h> +#include <alloc.h> +#include "unix.h" + +#ifdef HAS_UNISTD +#include <unistd.h> +#else +#include <sys/file.h> +#ifndef R_OK +#define R_OK 4/* test for read permission */ +#define W_OK 2/* test for write permission */ +#define X_OK 1/* test for execute (search) permission */ +#define F_OK 0/* test for presence of file */ +#endif +#endif + +static int access_permission_table[] = { + R_OK, W_OK, X_OK, F_OK +}; + +value unix_access(path, perms) /* ML */ + value path, perms; +{ + int ret; + ret = access(String_val(path), + convert_flag_list(perms, access_permission_table)); + if (ret == -1) + uerror("access", path); + return Val_unit; +} diff --git a/otherlibs/unix/addrofstr.c b/otherlibs/unix/addrofstr.c new file mode 100644 index 0000000000..393e32fb0f --- /dev/null +++ b/otherlibs/unix/addrofstr.c @@ -0,0 +1,25 @@ +#include <mlvalues.h> +#include <fail.h> +#include "unix.h" + +#ifdef HAS_SOCKETS + +#include "socketaddr.h" + +extern unsigned long inet_addr(); + +value unix_inet_addr_of_string(s) /* ML */ + value s; +{ + unsigned long address; + address = inet_addr(String_val(s)); + if (address == (unsigned long) -1) failwith("inet_addr_of_string"); + return alloc_inet_addr(address); +} + +#else + +value unix_inet_addr_of_string() +{ invalid_argument("inet_addr_of_string not implemented"); } + +#endif diff --git a/otherlibs/unix/alarm.c b/otherlibs/unix/alarm.c new file mode 100644 index 0000000000..a4bd78c9d8 --- /dev/null +++ b/otherlibs/unix/alarm.c @@ -0,0 +1,8 @@ +#include <mlvalues.h> +#include "unix.h" + +value unix_alarm(t) /* ML */ + value t; +{ + return Val_int(alarm((unsigned int) Long_val(t))); +} diff --git a/otherlibs/unix/bind.c b/otherlibs/unix/bind.c new file mode 100644 index 0000000000..1684ccb183 --- /dev/null +++ b/otherlibs/unix/bind.c @@ -0,0 +1,22 @@ +#include <mlvalues.h> +#include "unix.h" + +#ifdef HAS_SOCKETS + +#include "socketaddr.h" + +value unix_bind(socket, address) /* ML */ + value socket, address; +{ + int ret; + get_sockaddr(address); + ret = bind(Int_val(socket), &sock_addr.s_gen, sock_addr_len); + if (ret == -1) uerror("bind", Nothing); + return Val_unit; +} + +#else + +value unix_bind() { invalid_argument("bind not implemented"); } + +#endif diff --git a/otherlibs/unix/chdir.c b/otherlibs/unix/chdir.c new file mode 100644 index 0000000000..ec7aeb4650 --- /dev/null +++ b/otherlibs/unix/chdir.c @@ -0,0 +1,11 @@ +#include <mlvalues.h> +#include "unix.h" + +value unix_chdir(path) /* ML */ + value path; +{ + int ret; + ret = chdir(String_val(path)); + if (ret == -1) uerror("chdir", path); + return Val_unit; +} diff --git a/otherlibs/unix/chmod.c b/otherlibs/unix/chmod.c new file mode 100644 index 0000000000..ebfa6368b3 --- /dev/null +++ b/otherlibs/unix/chmod.c @@ -0,0 +1,11 @@ +#include <mlvalues.h> +#include "unix.h" + +value unix_chmod(path, perm) /* ML */ + value path, perm; +{ + int ret; + ret = chmod(String_val(path), Int_val(perm)); + if (ret == -1) uerror("chmod", path); + return Val_unit; +} diff --git a/otherlibs/unix/chown.c b/otherlibs/unix/chown.c new file mode 100644 index 0000000000..b7ea57d6d3 --- /dev/null +++ b/otherlibs/unix/chown.c @@ -0,0 +1,11 @@ +#include <mlvalues.h> +#include "unix.h" + +value unix_chown(path, uid, gid) /* ML */ + value path, uid, gid; +{ + int ret; + ret = chown(String_val(path), Int_val(uid), Int_val(gid)); + if (ret == -1) uerror("chown", path); + return Val_unit; +} diff --git a/otherlibs/unix/chroot.c b/otherlibs/unix/chroot.c new file mode 100644 index 0000000000..6f5954b665 --- /dev/null +++ b/otherlibs/unix/chroot.c @@ -0,0 +1,11 @@ +#include <mlvalues.h> +#include "unix.h" + +value unix_chroot(path) /* ML */ + value path; +{ + int ret; + ret = chroot(String_val(path)); + if (ret == -1) uerror("chroot", path); + return Val_unit; +} diff --git a/otherlibs/unix/close.c b/otherlibs/unix/close.c new file mode 100644 index 0000000000..47ea2ef1da --- /dev/null +++ b/otherlibs/unix/close.c @@ -0,0 +1,9 @@ +#include <mlvalues.h> +#include "unix.h" + +value unix_close(fd) /* ML */ + value fd; +{ + if (close(Int_val(fd)) == -1) uerror("close", Nothing); + return Val_unit; +} diff --git a/otherlibs/unix/closedir.c b/otherlibs/unix/closedir.c new file mode 100644 index 0000000000..2701e51d6e --- /dev/null +++ b/otherlibs/unix/closedir.c @@ -0,0 +1,15 @@ +#include <mlvalues.h> +#include "unix.h" +#include <sys/types.h> +#ifdef HAS_DIRENT +#include <dirent.h> +#else +#include <sys/dir.h> +#endif + +value unix_closedir(d) /* ML */ + value d; +{ + closedir((DIR *) d); + return Val_unit; +} diff --git a/otherlibs/unix/connect.c b/otherlibs/unix/connect.c new file mode 100644 index 0000000000..51eee43050 --- /dev/null +++ b/otherlibs/unix/connect.c @@ -0,0 +1,21 @@ +#include <mlvalues.h> +#include "unix.h" + +#ifdef HAS_SOCKETS + +#include "socketaddr.h" + +value unix_connect(socket, address) /* ML */ + value socket, address; +{ + get_sockaddr(address); + if (connect(Int_val(socket), &sock_addr.s_gen, sock_addr_len) == -1) + uerror("connect", Nothing); + return Val_unit; +} + +#else + +value unix_connect() { invalid_argument("connect not implemented"); } + +#endif diff --git a/otherlibs/unix/cst2constr.c b/otherlibs/unix/cst2constr.c new file mode 100644 index 0000000000..7a519a7501 --- /dev/null +++ b/otherlibs/unix/cst2constr.c @@ -0,0 +1,15 @@ +#include <mlvalues.h> +#include <fail.h> +#include "cst2constr.h" + +value cst_to_constr(n, tbl, size, deflt) + int n; + int * tbl; + int size; + int deflt; +{ + int i; + for (i = 0; i < size; i++) + if (n == tbl[i]) return Atom(i); + return Atom(deflt); +} diff --git a/otherlibs/unix/cst2constr.h b/otherlibs/unix/cst2constr.h new file mode 100644 index 0000000000..307926b353 --- /dev/null +++ b/otherlibs/unix/cst2constr.h @@ -0,0 +1,5 @@ +#ifdef ANSI +value cst_to_constr(int, int *, int, int); +#else +value cst_to_constr(); +#endif diff --git a/otherlibs/unix/cstringv.c b/otherlibs/unix/cstringv.c new file mode 100644 index 0000000000..8c2fa1e564 --- /dev/null +++ b/otherlibs/unix/cstringv.c @@ -0,0 +1,18 @@ +#include <mlvalues.h> +#include <memory.h> +#include "unix.h" + +char ** cstringvect(arg) + value arg; +{ + char ** res; + mlsize_t size, i; + + size = Wosize_val(arg); + res = (char **) stat_alloc((size + 1) * sizeof(char *)); + for (i = 0; i < size; i++) res[i] = String_val(Field(arg, i)); + res[size] = NULL; + return res; +} + + diff --git a/otherlibs/unix/dup.c b/otherlibs/unix/dup.c new file mode 100644 index 0000000000..5ee521305b --- /dev/null +++ b/otherlibs/unix/dup.c @@ -0,0 +1,11 @@ +#include <mlvalues.h> +#include "unix.h" + +value unix_dup(fd) /* ML */ + value fd; +{ + int ret; + ret = dup(Int_val(fd)); + if (ret == -1) uerror("dup", Nothing); + return Val_int(ret); +} diff --git a/otherlibs/unix/dup2.c b/otherlibs/unix/dup2.c new file mode 100644 index 0000000000..e8fbc3647a --- /dev/null +++ b/otherlibs/unix/dup2.c @@ -0,0 +1,37 @@ +#include <mlvalues.h> +#include "unix.h" + +#ifdef HAS_DUP2 + +value unix_dup2(fd1, fd2) /* ML */ + value fd1, fd2; +{ + if (dup2(Int_val(fd1), Int_val(fd2)) == -1) uerror("dup2", Nothing); + return Val_unit; +} + +#else + +static int do_dup2(fd1, fd2) + int fd1, fd2; +{ + int fd; + int res; + + fd = dup(fd1); + if (fd == -1) return -1; + if (fd == fd2) return 0; + res = do_dup2(fd1, fd2); + close(fd); + return res; +} + +value unix_dup2(fd1, fd2) /* ML */ + value fd1, fd2; +{ + close(Int_val(fd2)); + if (do_dup2(Int_val(fd1), Int_val(fd2)) == -1) uerror("dup2", Nothing); + return Val_unit; +} + +#endif diff --git a/otherlibs/unix/envir.c b/otherlibs/unix/envir.c new file mode 100644 index 0000000000..a9489fe87f --- /dev/null +++ b/otherlibs/unix/envir.c @@ -0,0 +1,9 @@ +#include <mlvalues.h> +#include <alloc.h> + +extern char ** environ; + +value unix_environment() +{ + return copy_string_array(environ); +} diff --git a/otherlibs/unix/errmsg.c b/otherlibs/unix/errmsg.c new file mode 100644 index 0000000000..d3efc8414b --- /dev/null +++ b/otherlibs/unix/errmsg.c @@ -0,0 +1,36 @@ +#include <errno.h> +#include <mlvalues.h> +#include <alloc.h> + +extern int error_table[]; + +#ifdef HAS_STRERROR + +#include <string.h> + +value unix_error_message(err) + value err; +{ + int errnum; + errnum = error_table[Tag_val(err)]; + return copy_string(strerror(errno)); +} + +#else + +extern int sys_nerr; +extern char *sys_errlist[]; + +value unix_error_message(err) + value err; +{ + int errnum; + errnum = error_table[Tag_val(err)]; + if (errnum < 0 || errnum >= sys_nerr) { + return copy_string("Unknown error"); + } else { + return copy_string(sys_errlist[errnum]); + } +} + +#endif diff --git a/otherlibs/unix/execv.c b/otherlibs/unix/execv.c new file mode 100644 index 0000000000..851d331cb1 --- /dev/null +++ b/otherlibs/unix/execv.c @@ -0,0 +1,18 @@ +#include <mlvalues.h> +#include <memory.h> +#include "unix.h" + +extern char ** cstringvect(); + +value unix_execv(path, args) /* ML */ + value path, args; +{ + char ** argv; + argv = cstringvect(args); + (void) execv(String_val(path), argv); + stat_free((char *) argv); + uerror("execv", path); + return Val_unit; /* never reached, but suppress warnings */ + /* from smart compilers */ +} + diff --git a/otherlibs/unix/execve.c b/otherlibs/unix/execve.c new file mode 100644 index 0000000000..ecdad41046 --- /dev/null +++ b/otherlibs/unix/execve.c @@ -0,0 +1,21 @@ +#include <mlvalues.h> +#include <memory.h> +#include "unix.h" + +extern char ** cstringvect(); + +value unix_execve(path, args, env) /* ML */ + value path, args, env; +{ + char ** argv; + char ** envp; + argv = cstringvect(args); + envp = cstringvect(env); + (void) execve(String_val(path), argv, envp); + stat_free((char *) argv); + stat_free((char *) envp); + uerror("execve", path); + return Val_unit; /* never reached, but suppress warnings */ + /* from smart compilers */ +} + diff --git a/otherlibs/unix/execvp.c b/otherlibs/unix/execvp.c new file mode 100644 index 0000000000..d8f77bfabd --- /dev/null +++ b/otherlibs/unix/execvp.c @@ -0,0 +1,18 @@ +#include <mlvalues.h> +#include <memory.h> +#include "unix.h" + +extern char ** cstringvect(); + +value unix_execvp(path, args) /* ML */ + value path, args; +{ + char ** argv; + argv = cstringvect(args); + (void) execvp(String_val(path), argv); + stat_free((char *) argv); + uerror("execvp", path); + return Val_unit; /* never reached, but suppress warnings */ + /* from smart compilers */ +} + diff --git a/otherlibs/unix/exit.c b/otherlibs/unix/exit.c new file mode 100644 index 0000000000..c3cf6572c9 --- /dev/null +++ b/otherlibs/unix/exit.c @@ -0,0 +1,12 @@ +#include <mlvalues.h> +#include "unix.h" + +value unix_exit(n) /* ML */ + value n; +{ + _exit(Int_val(n)); + return Val_unit; /* never reached, but suppress warnings */ + /* from smart compilers */ +} + + diff --git a/otherlibs/unix/fchmod.c b/otherlibs/unix/fchmod.c new file mode 100644 index 0000000000..fd74353c0a --- /dev/null +++ b/otherlibs/unix/fchmod.c @@ -0,0 +1,17 @@ +#include <mlvalues.h> +#include "unix.h" + +#ifdef HAS_FCHMOD + +value unix_fchmod(fd, perm) /* ML */ + value fd, perm; +{ + if (fchmod(Int_val(fd), Int_val(perm)) == -1) uerror("fchmod", Nothing); + return Val_unit; +} + +#else + +value unix_fchmod() { invalid_argument("fchmod not implemented"); } + +#endif diff --git a/otherlibs/unix/fchown.c b/otherlibs/unix/fchown.c new file mode 100644 index 0000000000..4aaa2ae55e --- /dev/null +++ b/otherlibs/unix/fchown.c @@ -0,0 +1,18 @@ +#include <mlvalues.h> +#include "unix.h" + +#ifdef HAS_FCHMOD + +value unix_fchown(fd, uid, gid) /* ML */ + value fd, uid, gid; +{ + if (fchown(Int_val(fd), Int_val(uid), Int_val(gid)) == -1) + uerror("fchown", Nothing); + return Val_unit; +} + +#else + +value unix_fchown() { invalid_argument("fchown not implemented"); } + +#endif diff --git a/otherlibs/unix/fcntl.c b/otherlibs/unix/fcntl.c new file mode 100644 index 0000000000..7898d3c848 --- /dev/null +++ b/otherlibs/unix/fcntl.c @@ -0,0 +1,20 @@ +#include <mlvalues.h> +#include "unix.h" + +value unix_fcntl_int(fd, request, arg) + value fd, request, arg; +{ + int retcode; + retcode = fcntl(Int_val(fd), Int_val(request), (char *) Int_val(arg)); + if (retcode == -1) uerror("fcntl_int", Nothing); + return Val_int(retcode); +} + +value unix_fcntl_ptr(fd, request, arg) + value fd, request, arg; +{ + int retcode; + retcode = fcntl(Int_val(fd), Int_val(request), String_val(arg)); + if (retcode == -1) uerror("fcntl_ptr", Nothing); + return Val_int(retcode); +} diff --git a/otherlibs/unix/fork.c b/otherlibs/unix/fork.c new file mode 100644 index 0000000000..046dd894ce --- /dev/null +++ b/otherlibs/unix/fork.c @@ -0,0 +1,12 @@ +#include <mlvalues.h> +#include "unix.h" + +value unix_fork(unit) /* ML */ + value unit; +{ + int ret; + ret = fork(); + if (ret == -1) uerror("fork", Nothing); + return Val_int(ret); +} + diff --git a/otherlibs/unix/ftruncate.c b/otherlibs/unix/ftruncate.c new file mode 100644 index 0000000000..769ff86fb2 --- /dev/null +++ b/otherlibs/unix/ftruncate.c @@ -0,0 +1,18 @@ +#include <mlvalues.h> +#include "unix.h" + +#ifdef HAS_TRUNCATE + +value unix_ftruncate(fd, len) /* ML */ + value fd, len; +{ + if (ftruncate(Int_val(fd), Long_val(len)) == -1) + uerror("ftruncate", Nothing); + return Val_unit; +} + +#else + +value unix_ftruncate() { invalid_argument("ftruncate not implemented"); } + +#endif diff --git a/otherlibs/unix/getcwd.c b/otherlibs/unix/getcwd.c new file mode 100644 index 0000000000..7bbddf12df --- /dev/null +++ b/otherlibs/unix/getcwd.c @@ -0,0 +1,33 @@ +#include <mlvalues.h> +#include <alloc.h> +#include "unix.h" + +#ifdef HAS_GETCWD + +#include <sys/param.h> + +value unix_getcwd() /* ML */ +{ + char buff[MAXPATHLEN]; + if (getcwd(buff, sizeof(buff)) == 0) uerror("getcwd", NULL); + return copy_string(buff); +} + +#else +#ifdef HAS_GETWD + +#include <sys/param.h> + +value unix_getcwd() +{ + char buff[MAXPATHLEN]; + if (getwd(buff) == 0) uerror("getcwd", buff); + return copy_string(buff); +} + +#else + +value unix_getcwd() { invalid_argument("getcwd not implemented"); } + +#endif +#endif diff --git a/otherlibs/unix/getegid.c b/otherlibs/unix/getegid.c new file mode 100644 index 0000000000..482177410f --- /dev/null +++ b/otherlibs/unix/getegid.c @@ -0,0 +1,7 @@ +#include <mlvalues.h> +#include "unix.h" + +value unix_getegid() /* ML */ +{ + return Val_int(getegid()); +} diff --git a/otherlibs/unix/geteuid.c b/otherlibs/unix/geteuid.c new file mode 100644 index 0000000000..e7e8d4c4ab --- /dev/null +++ b/otherlibs/unix/geteuid.c @@ -0,0 +1,7 @@ +#include <mlvalues.h> +#include "unix.h" + +value unix_geteuid() /* ML */ +{ + return Val_int(geteuid()); +} diff --git a/otherlibs/unix/getgid.c b/otherlibs/unix/getgid.c new file mode 100644 index 0000000000..81debfa058 --- /dev/null +++ b/otherlibs/unix/getgid.c @@ -0,0 +1,7 @@ +#include <mlvalues.h> +#include "unix.h" + +value unix_getgid() /* ML */ +{ + return Val_int(getgid()); +} diff --git a/otherlibs/unix/getgr.c b/otherlibs/unix/getgr.c new file mode 100644 index 0000000000..efb55b9b5a --- /dev/null +++ b/otherlibs/unix/getgr.c @@ -0,0 +1,43 @@ +#include <mlvalues.h> +#include <fail.h> +#include <alloc.h> +#include <memory.h> +#include "unix.h" +#include <stdio.h> +#include <grp.h> + +static value alloc_group_entry(entry) + struct group * entry; +{ + value res; + Push_roots(s, 3); + + s[0] = copy_string(entry->gr_name); + s[1] = copy_string(entry->gr_passwd); + s[2] = copy_string_array(entry->gr_mem); + res = alloc_tuple(4); + Field(res,0) = s[0]; + Field(res,1) = s[1]; + Field(res,2) = Val_int(entry->gr_gid); + Field(res,3) = s[2]; + Pop_roots(); + return res; +} + +value unix_getgrnam(name) /* ML */ + value name; +{ + struct group * entry; + entry = getgrnam(String_val(name)); + if (entry == NULL) mlraise(Atom(NOT_FOUND_EXN)); + return alloc_group_entry(entry); +} + +value unix_getgrgid(gid) /* ML */ + value gid; +{ + struct group * entry; + entry = getgrgid(Int_val(gid)); + if (entry == NULL) mlraise(Atom(NOT_FOUND_EXN)); + return alloc_group_entry(entry); +} diff --git a/otherlibs/unix/getgroups.c b/otherlibs/unix/getgroups.c new file mode 100644 index 0000000000..b5c1d52e48 --- /dev/null +++ b/otherlibs/unix/getgroups.c @@ -0,0 +1,29 @@ +#include <mlvalues.h> +#include <alloc.h> + +#ifdef HAS_GETGROUPS + +#include <sys/types.h> +#include <sys/param.h> +#include "unix.h" + +value unix_getgroups() /* ML */ +{ + int gidset[NGROUPS]; + int n; + value res; + int i; + + n = getgroups(NGROUPS, gidset); + if (n == -1) uerror("getgroups", Nothing); + res = alloc_tuple(n); + for (i = 0; i < n; i++) + Field(res, i) = Val_int(gidset[i]); + return res; +} + +#else + +value unix_getgroups() { invalid_argument("getgroups not implemented"); } + +#endif diff --git a/otherlibs/unix/gethost.c b/otherlibs/unix/gethost.c new file mode 100644 index 0000000000..096b28fe50 --- /dev/null +++ b/otherlibs/unix/gethost.c @@ -0,0 +1,76 @@ +#include <mlvalues.h> +#include <alloc.h> +#include <memory.h> +#include <fail.h> +#include "unix.h" + +#ifdef HAS_SOCKETS + +#include "socketaddr.h" +#include <netdb.h> + +static int entry_h_length; + +extern int socket_domain_table[]; + +static value alloc_one_addr(a) + char * a; +{ + bcopy(a, &sock_addr.s_inet.sin_addr, entry_h_length); + return alloc_inet_addr(sock_addr.s_inet.sin_addr.s_addr); +} + +static value alloc_host_entry(entry) + struct hostent * entry; +{ + value res; + Push_roots(r, 4); + + r[0] = copy_string(entry->h_name); + r[1] = copy_string_array(entry->h_aliases); + entry_h_length = entry->h_length; +#ifdef h_addr + r[2] = alloc_array(alloc_one_addr, entry->h_addr_list); +#else + r[3] = alloc_one_addr(entry->h_addr); + r[2] = alloc_tuple(1); + Field(r[2], 0) = r[3]; +#endif + res = alloc_tuple(4); + Field(res, 0) = r[0]; + Field(res, 1) = r[1]; + Field(res, 2) = entry->h_addrtype == PF_UNIX ? Atom(0) : Atom(1); + Field(res, 3) = r[2]; + Pop_roots(); + return res; +} + +value unix_gethostbyaddr(a) /* ML */ + value a; +{ + struct in_addr in_addr; + struct hostent * entry; + in_addr.s_addr = GET_INET_ADDR(a); + entry = gethostbyaddr((char *) &in_addr, sizeof(in_addr), 0); + if (entry == (struct hostent *) NULL) mlraise(Atom(NOT_FOUND_EXN)); + return alloc_host_entry(entry); +} + +value unix_gethostbyname(name) /* ML */ + value name; +{ + struct hostent * entry; + entry = gethostbyname(String_val(name)); + if (entry == (struct hostent *) NULL) mlraise(Atom(NOT_FOUND_EXN)); + return alloc_host_entry(entry); +} + +#else + +value unix_gethostbyaddr() +{ invalid_argument("gethostbyaddr not implemented"); } + +value unix_gethostbyname() +{ invalid_argument("gethostbyname not implemented"); } + +#endif diff --git a/otherlibs/unix/gethostname.c b/otherlibs/unix/gethostname.c new file mode 100644 index 0000000000..4c11c6b2a9 --- /dev/null +++ b/otherlibs/unix/gethostname.c @@ -0,0 +1,37 @@ +#include <mlvalues.h> +#include <alloc.h> +#include <sys/param.h> +#include "unix.h" + +#ifdef HAS_GETHOSTNAME + +#ifndef MAXHOSTNAMELEN +#define MAXHOSTNAMELEN 256 +#endif + +value unix_gethostname() /* ML */ +{ + char name[MAXHOSTNAMELEN]; + gethostname(name, MAXHOSTNAMELEN); + name[MAXHOSTNAMELEN-1] = 0; + return copy_string(name); +} + +#else +#ifdef HAS_UNAME + +#include <sys/utsname.h> + +value unix_gethostname() +{ + struct utsname un; + uname(&un); + return copy_string(un.nodename); +} + +#else + +value unix_gethostname() { invalid_argument("gethostname not implemented"); } + +#endif +#endif diff --git a/otherlibs/unix/getlogin.c b/otherlibs/unix/getlogin.c new file mode 100644 index 0000000000..72274a7d93 --- /dev/null +++ b/otherlibs/unix/getlogin.c @@ -0,0 +1,14 @@ +#include <mlvalues.h> +#include <alloc.h> +#include "unix.h" +#include <errno.h> + +extern char * getlogin(); + +value unix_getlogin() /* ML */ +{ + char * name; + name = getlogin(); + if (name == NULL) unix_error(ENOENT, "getlogin", Nothing); + return copy_string(name); +} diff --git a/otherlibs/unix/getpid.c b/otherlibs/unix/getpid.c new file mode 100644 index 0000000000..b8082b95f0 --- /dev/null +++ b/otherlibs/unix/getpid.c @@ -0,0 +1,7 @@ +#include <mlvalues.h> +#include "unix.h" + +value unix_getpid() /* ML */ +{ + return Val_int(getpid()); +} diff --git a/otherlibs/unix/getppid.c b/otherlibs/unix/getppid.c new file mode 100644 index 0000000000..4b76b736e5 --- /dev/null +++ b/otherlibs/unix/getppid.c @@ -0,0 +1,7 @@ +#include <mlvalues.h> +#include "unix.h" + +value unix_getppid() /* ML */ +{ + return Val_int(getppid()); +} diff --git a/otherlibs/unix/getproto.c b/otherlibs/unix/getproto.c new file mode 100644 index 0000000000..56ea699134 --- /dev/null +++ b/otherlibs/unix/getproto.c @@ -0,0 +1,53 @@ +#include <mlvalues.h> +#include <alloc.h> +#include <memory.h> +#include <fail.h> +#include "unix.h" + +#ifdef HAS_SOCKETS + +#include <netdb.h> + +static value alloc_proto_entry(entry) + struct protoent * entry; +{ + value res; + Push_roots(r, 2); + + r[0] = copy_string(entry->p_name); + r[1] = copy_string_array(entry->p_aliases); + res = alloc_tuple(3); + Field(res,0) = r[0]; + Field(res,1) = r[1]; + Field(res,2) = Val_int(entry->p_proto); + Pop_roots(); + return res; +} + +value unix_getprotobyname(name) /* ML */ + value name; +{ + struct protoent * entry; + entry = getprotobyname(String_val(name)); + if (entry == (struct protoent *) NULL) mlraise(Atom(NOT_FOUND_EXN)); + return alloc_proto_entry(entry); +} + +value unix_getprotobynumber(proto) /* ML */ + value proto; +{ + struct protoent * entry; + entry = getprotobynumber(Int_val(proto)); + if (entry == (struct protoent *) NULL) mlraise(Atom(NOT_FOUND_EXN)); + return alloc_proto_entry(entry); +} + +#else + +value unix_getprotobynumber() +{ invalid_argument("getprotobynumber not implemented"); } + +value unix_getprotobyname() +{ invalid_argument("getprotobyname not implemented"); } + +#endif diff --git a/otherlibs/unix/getpw.c b/otherlibs/unix/getpw.c new file mode 100644 index 0000000000..86d27474ab --- /dev/null +++ b/otherlibs/unix/getpw.c @@ -0,0 +1,47 @@ +#include <mlvalues.h> +#include <alloc.h> +#include <memory.h> +#include <fail.h> +#include "unix.h" +#include <pwd.h> + +static value alloc_passwd_entry(entry) + struct passwd * entry; +{ + value res; + Push_roots(s, 5); + + s[0] = copy_string(entry->pw_name); + s[1] = copy_string(entry->pw_passwd); + s[2] = copy_string(entry->pw_gecos); + s[3] = copy_string(entry->pw_dir); + s[4] = copy_string(entry->pw_shell); + res = alloc_tuple(7); + Field(res,0) = s[0]; + Field(res,1) = s[1]; + Field(res,2) = Val_int(entry->pw_uid); + Field(res,3) = Val_int(entry->pw_gid); + Field(res,4) = s[2]; + Field(res,5) = s[3]; + Field(res,6) = s[4]; + Pop_roots(); + return res; +} + +value unix_getpwnam(name) /* ML */ + value name; +{ + struct passwd * entry; + entry = getpwnam(String_val(name)); + if (entry == (struct passwd *) NULL) mlraise(Atom(NOT_FOUND_EXN)); + return alloc_passwd_entry(entry); +} + +value unix_getpwuid(uid) /* ML */ + value uid; +{ + struct passwd * entry; + entry = getpwuid(Int_val(uid)); + if (entry == (struct passwd *) NULL) mlraise(Atom(NOT_FOUND_EXN)); + return alloc_passwd_entry(entry); +} diff --git a/otherlibs/unix/getserv.c b/otherlibs/unix/getserv.c new file mode 100644 index 0000000000..ddd25dafb7 --- /dev/null +++ b/otherlibs/unix/getserv.c @@ -0,0 +1,58 @@ +#include <mlvalues.h> +#include <alloc.h> +#include <memory.h> +#include <fail.h> +#include "unix.h" + +#ifdef HAS_SOCKETS + +#include <sys/types.h> +#include <sys/socket.h> +#include <netinet/in.h> +#include <netdb.h> + +static value alloc_service_entry(entry) + struct servent * entry; +{ + value res; + Push_roots(r, 3); + + r[0] = copy_string(entry->s_name); + r[1] = copy_string_array(entry->s_aliases); + r[2] = copy_string(entry->s_proto); + res = alloc_tuple(4); + Field(res,0) = r[0]; + Field(res,1) = r[1]; + Field(res,2) = Val_int(ntohs(entry->s_port)); + Field(res,3) = r[2]; + Pop_roots(); + return res; +} + +value unix_getservbyname(name, proto) /* ML */ + value name, proto; +{ + struct servent * entry; + entry = getservbyname(String_val(name), String_val(proto)); + if (entry == (struct servent *) NULL) mlraise(Atom(NOT_FOUND_EXN)); + return alloc_service_entry(entry); +} + +value unix_getservbyport(port, proto) /* ML */ + value port, proto; +{ + struct servent * entry; + entry = getservbyport(Int_val(port), String_val(proto)); + if (entry == (struct servent *) NULL) mlraise(Atom(NOT_FOUND_EXN)); + return alloc_service_entry(entry); +} + +#else + +value unix_getservbyport() +{ invalid_argument("getservbyport not implemented"); } + +value unix_getservbyname() +{ invalid_argument("getservbyname not implemented"); } + +#endif diff --git a/otherlibs/unix/getuid.c b/otherlibs/unix/getuid.c new file mode 100644 index 0000000000..558e5e2992 --- /dev/null +++ b/otherlibs/unix/getuid.c @@ -0,0 +1,7 @@ +#include <mlvalues.h> +#include "unix.h" + +value unix_getuid() /* ML */ +{ + return Val_int(getuid()); +} diff --git a/otherlibs/unix/gmtime.c b/otherlibs/unix/gmtime.c new file mode 100644 index 0000000000..ecbcd81a5f --- /dev/null +++ b/otherlibs/unix/gmtime.c @@ -0,0 +1,37 @@ +#include <mlvalues.h> +#include <alloc.h> +#include "unix.h" +#include <time.h> + +static value alloc_tm(tm) + struct tm * tm; +{ + value res; + res = alloc_tuple(9); + Field(res,0) = Val_int(tm->tm_sec); + Field(res,1) = Val_int(tm->tm_min); + Field(res,2) = Val_int(tm->tm_hour); + Field(res,3) = Val_int(tm->tm_mday); + Field(res,4) = Val_int(tm->tm_mon); + Field(res,5) = Val_int(tm->tm_year); + Field(res,6) = Val_int(tm->tm_wday); + Field(res,7) = Val_int(tm->tm_yday); + Field(res,8) = tm->tm_isdst ? Val_true : Val_false; + return res; +} + +value unix_gmtime(t) /* ML */ + value t; +{ + int clock; + clock = Int_val(t); + return alloc_tm(gmtime(&clock)); +} + +value unix_localtime(t) /* ML */ + value t; +{ + int clock; + clock = Int_val(t); + return alloc_tm(localtime(&clock)); +} diff --git a/otherlibs/unix/ioctl.c b/otherlibs/unix/ioctl.c new file mode 100644 index 0000000000..e4d2e5e6d4 --- /dev/null +++ b/otherlibs/unix/ioctl.c @@ -0,0 +1,20 @@ +#include <mlvalues.h> +#include "unix.h" + +value unix_ioctl_int(fd, request, arg) + value fd, request, arg; +{ + int retcode; + retcode = ioctl(Int_val(fd), Int_val(request), (char *) Int_val(arg)); + if (retcode == -1) uerror("ioctl_int", Nothing); + return Val_int(retcode); +} + +value unix_ioctl_ptr(fd, request, arg) + value fd, request, arg; +{ + int retcode; + retcode = ioctl(Int_val(fd), Int_val(request), String_val(arg)); + if (retcode == -1) uerror("ioctl_ptr", Nothing); + return Val_int(retcode); +} diff --git a/otherlibs/unix/kill.c b/otherlibs/unix/kill.c new file mode 100644 index 0000000000..a552d0931c --- /dev/null +++ b/otherlibs/unix/kill.c @@ -0,0 +1,20 @@ +#include <mlvalues.h> +#include <fail.h> +#include "unix.h" +#include <signal.h> + +extern int posix_signals[]; /* defined in byterun/signals.c */ + +value unix_kill(pid, signal) /* ML */ + value pid, signal; +{ + int sig; + sig = Int_val(signal); + if (sig < 0) { + sig = posix_signals[-sig-1]; + if (sig == 0) invalid_argument("Unix.kill: unavailable signal"); + } + if (kill(Int_val(pid), sig) == -1) + uerror("kill", Nothing); + return Val_unit; +} diff --git a/otherlibs/unix/link.c b/otherlibs/unix/link.c new file mode 100644 index 0000000000..3c7ef671dc --- /dev/null +++ b/otherlibs/unix/link.c @@ -0,0 +1,9 @@ +#include <mlvalues.h> +#include "unix.h" + +value unix_link(path1, path2) /* ML */ + value path1, path2; +{ + if (link(String_val(path1), String_val(path2)) == -1) uerror("link", path2); + return Val_unit; +} diff --git a/otherlibs/unix/listen.c b/otherlibs/unix/listen.c new file mode 100644 index 0000000000..d3791a2c4a --- /dev/null +++ b/otherlibs/unix/listen.c @@ -0,0 +1,17 @@ +#include <mlvalues.h> +#include "unix.h" + +#ifdef HAS_SOCKETS + +value unix_listen(sock, backlog) + value sock, backlog; +{ + if (listen(Int_val(sock), Int_val(backlog)) == -1) uerror("listen", Nothing); + return Val_unit; +} + +#else + +value unix_listen() { invalid_argument("listen not implemented"); } + +#endif diff --git a/otherlibs/unix/lockf.c b/otherlibs/unix/lockf.c new file mode 100644 index 0000000000..bfc22c77dc --- /dev/null +++ b/otherlibs/unix/lockf.c @@ -0,0 +1,89 @@ +#include <mlvalues.h> +#include "unix.h" + +#ifdef HAS_LOCKF +#ifdef HAS_UNISTD +#include <unistd.h> +#else +#define F_ULOCK 0 +#define F_LOCK 1 +#define F_TLOCK 2 +#define F_TEST 3 +#endif + +static int lock_command_table[] = { + F_ULOCK, F_LOCK, F_TLOCK, F_TEST +}; + +value unix_lockf(fd, cmd, span) /* ML */ + value fd, cmd, span; +{ + if (lockf(Int_val(fd), lock_command_table[Tag_val(cmd)], Long_val(span)) + == -1) uerror("lockf", Nothing); + return Atom(0); +} + +#else + +#include <errno.h> +#include <fcntl.h> + +#ifdef F_SETLK + +value unix_lockf(fd, cmd, span) /* ML */ + value fd, cmd, span; +{ + struct flock l; + int ret; + int fildes; + long size; + + fildes = Int_val(fd); + size = Long_val(span); + l.l_whence = 1; + if (size < 0) { + l.l_start = size; + l.l_len = -size; + } else { + l.l_start = 0L; + l.l_len = size; + } + switch (Tag_val(cmd)) { + case 0: /* F_ULOCK */ + l.l_type = F_UNLCK; + ret = fcntl(fildes, F_SETLK, &l); + break; + case 1: /* F_LOCK */ + l.l_type = F_WRLCK; + ret = fcntl(fildes, F_SETLKW, &l); + break; + case 2: /* F_TLOCK */ + l.l_type = F_WRLCK; + ret = fcntl(fildes, F_SETLK, &l); + break; + case 3: /* F_TEST */ + l.l_type = F_WRLCK; + ret = fcntl(fildes, F_GETLK, &l); + if (ret != -1) { + if (l.l_type == F_UNLCK) + ret = 0; + else { + errno = EACCES; + ret = -1; + } + } + break; + default: + errno = EINVAL; + ret = -1; + } + if (ret == -1) uerror("lockf", Nothing); + return Val_unit; +} + +#else + +value unix_lockf() { invalid_argument("lockf not implemented"); } + +#endif +#endif diff --git a/otherlibs/unix/lseek.c b/otherlibs/unix/lseek.c new file mode 100644 index 0000000000..05d6d2422e --- /dev/null +++ b/otherlibs/unix/lseek.c @@ -0,0 +1,24 @@ +#include <mlvalues.h> +#include "unix.h" + +#ifdef HAS_UNISTD +#include <unistd.h> +#else +#define SEEK_SET 0 +#define SEEK_CUR 1 +#define SEEK_END 2 +#endif + +static int seek_command_table[] = { + SEEK_SET, SEEK_CUR, SEEK_END +}; + +value unix_lseek(fd, ofs, cmd) /* ML */ + value fd, ofs, cmd; +{ + long ret; + ret = lseek(Int_val(fd), Long_val(ofs), + seek_command_table[Tag_val(cmd)]); + if (ret == -1) uerror("lseek", Nothing); + return Val_long(ret); +} diff --git a/otherlibs/unix/mkdir.c b/otherlibs/unix/mkdir.c new file mode 100644 index 0000000000..a65157532b --- /dev/null +++ b/otherlibs/unix/mkdir.c @@ -0,0 +1,9 @@ +#include <mlvalues.h> +#include "unix.h" + +value unix_mkdir(path, perm) /* ML */ + value path, perm; +{ + if (mkdir(String_val(path), Int_val(perm)) == -1) uerror("mkdir", path); + return Val_unit; +} diff --git a/otherlibs/unix/mkfifo.c b/otherlibs/unix/mkfifo.c new file mode 100644 index 0000000000..453bcfc5e6 --- /dev/null +++ b/otherlibs/unix/mkfifo.c @@ -0,0 +1,36 @@ +#include <mlvalues.h> +#include "unix.h" + +#ifdef HAS_MKFIFO + +value unix_mkfifo(path, mode) + value path; + value mode; +{ + if (mkfifo(String_val(path), Int_val(mode)) == -1) + uerror("mkfifo", path); + return Val_unit; +} + +#else + +#include <sys/types.h> +#include <sys/stat.h> + +#ifdef S_IFIFO + +value unix_mkfifo(path, mode) + value path; + value mode; +{ + if (mknod(String_val(path), (Int_val(mode) & 07777) | S_IFIFO, 0) == -1) + uerror("mkfifo", path); + return Val_unit; +} + +#else + +value unix_mkfifo() { invalid_argument("mkfifo not implemented"); } + +#endif +#endif diff --git a/otherlibs/unix/nice.c b/otherlibs/unix/nice.c new file mode 100644 index 0000000000..8fc265adba --- /dev/null +++ b/otherlibs/unix/nice.c @@ -0,0 +1,36 @@ +#include <mlvalues.h> +#include "unix.h" +#include <errno.h> + +#ifdef HAS_GETPRIORITY + +#include <sys/time.h> +#include <sys/resource.h> + +value unix_nice(incr) + value incr; +{ + int prio; + errno = 0; + prio = getpriority(PRIO_PROCESS, 0); + if (prio == -1 && errno != 0) + uerror("nice", Nothing); + prio += Int_val(incr); + if (setpriority(PRIO_PROCESS, 0, prio) == -1) + uerror("nice", Nothing); + return Val_int(prio); +} + +#else + +value unix_nice(incr) + value incr; +{ + int ret; + errno = 0; + ret = nice(Int_val(incr)); + if (ret == -1 && errno != 0) uerror("nice", Nothing); + return Val_int(ret); +} + +#endif diff --git a/otherlibs/unix/open.c b/otherlibs/unix/open.c new file mode 100644 index 0000000000..bec1e8ed80 --- /dev/null +++ b/otherlibs/unix/open.c @@ -0,0 +1,19 @@ +#include <mlvalues.h> +#include <alloc.h> +#include "unix.h" +#include <fcntl.h> + +static int open_flag_table[] = { + O_RDONLY, O_WRONLY, O_RDWR, O_NDELAY, O_APPEND, O_CREAT, O_TRUNC, O_EXCL +}; + +value unix_open(path, flags, perm) /* ML */ + value path, flags, perm; +{ + int ret; + + ret = open(String_val(path), convert_flag_list(flags, open_flag_table), + Int_val(perm)); + if (ret == -1) uerror("open", path); + return Val_int(ret); +} diff --git a/otherlibs/unix/opendir.c b/otherlibs/unix/opendir.c new file mode 100644 index 0000000000..0fa82657fd --- /dev/null +++ b/otherlibs/unix/opendir.c @@ -0,0 +1,17 @@ +#include <mlvalues.h> +#include "unix.h" +#include <sys/types.h> +#ifdef HAS_DIRENT +#include <dirent.h> +#else +#include <sys/dir.h> +#endif + +value unix_opendir(path) /* ML */ + value path; +{ + DIR * d; + d = opendir(String_val(path)); + if (d == (DIR *) NULL) uerror("opendir", path); + return (value) d; +} diff --git a/otherlibs/unix/pause.c b/otherlibs/unix/pause.c new file mode 100644 index 0000000000..126c310f9d --- /dev/null +++ b/otherlibs/unix/pause.c @@ -0,0 +1,8 @@ +#include <mlvalues.h> +#include "unix.h" + +value unix_pause() /* ML */ +{ + pause(); + return Val_unit; +} diff --git a/otherlibs/unix/pipe.c b/otherlibs/unix/pipe.c new file mode 100644 index 0000000000..102aeafb98 --- /dev/null +++ b/otherlibs/unix/pipe.c @@ -0,0 +1,14 @@ +#include <mlvalues.h> +#include <alloc.h> +#include "unix.h" + +value unix_pipe() /* ML */ +{ + int fd[2]; + value res; + if (pipe(fd) == -1) uerror("pipe", Nothing); + res = alloc_tuple(2); + Field(res, 0) = Val_int(fd[0]); + Field(res, 1) = Val_int(fd[1]); + return res; +} diff --git a/otherlibs/unix/read.c b/otherlibs/unix/read.c new file mode 100644 index 0000000000..18ba74d662 --- /dev/null +++ b/otherlibs/unix/read.c @@ -0,0 +1,13 @@ +#include <mlvalues.h> +#include "unix.h" + +value unix_read(fd, buf, ofs, len) /* ML */ + value fd, buf, ofs, len; +{ + int ret; + enter_blocking_section(); + ret = read(Int_val(fd), &Byte(buf, Long_val(ofs)), Int_val(len)); + leave_blocking_section(); + if (ret == -1) uerror("read", Nothing); + return Val_int(ret); +} diff --git a/otherlibs/unix/readdir.c b/otherlibs/unix/readdir.c new file mode 100644 index 0000000000..41093f95a7 --- /dev/null +++ b/otherlibs/unix/readdir.c @@ -0,0 +1,22 @@ +#include <mlvalues.h> +#include <fail.h> +#include <alloc.h> +#include "unix.h" +#include <sys/types.h> +#ifdef HAS_DIRENT +#include <dirent.h> +typedef struct dirent directory_entry; +#else +#include <sys/dir.h> +typedef struct direct directory_entry; +#endif + +value unix_readdir(d) /* ML */ + value d; +{ + directory_entry * e; + + e = readdir((DIR *) d); + if (e == (directory_entry *) NULL) mlraise(Atom(END_OF_FILE_EXN)); + return copy_string(e->d_name); +} diff --git a/otherlibs/unix/readlink.c b/otherlibs/unix/readlink.c new file mode 100644 index 0000000000..ffd979da5c --- /dev/null +++ b/otherlibs/unix/readlink.c @@ -0,0 +1,24 @@ +#include <mlvalues.h> +#include <alloc.h> + +#ifdef HAS_SYMLINK + +#include <sys/param.h> +#include "unix.h" + +value unix_readlink(path) /* ML */ + value path; +{ + char buffer[MAXPATHLEN]; + int len; + len = readlink(String_val(path), buffer, sizeof(buffer) - 1); + if (len == -1) uerror("readlink", path); + buffer[len] = '\0'; + return copy_string(buffer); +} + +#else + +value unix_readlink() { invalid_argument("readlink not implemented"); } + +#endif diff --git a/otherlibs/unix/rename.c b/otherlibs/unix/rename.c new file mode 100644 index 0000000000..76b6e3f6e5 --- /dev/null +++ b/otherlibs/unix/rename.c @@ -0,0 +1,10 @@ +#include <mlvalues.h> +#include "unix.h" + +value unix_rename(path1, path2) /* ML */ + value path1, path2; +{ + if (rename(String_val(path1), String_val(path2)) == -1) + uerror("rename", path1); + return Atom(0); +} diff --git a/otherlibs/unix/rewinddir.c b/otherlibs/unix/rewinddir.c new file mode 100644 index 0000000000..4062a46c7e --- /dev/null +++ b/otherlibs/unix/rewinddir.c @@ -0,0 +1,15 @@ +#include <mlvalues.h> +#include "unix.h" +#include <sys/types.h> +#ifdef HAS_DIRENT +#include <dirent.h> +#else +#include <sys/dir.h> +#endif + +value unix_rewinddir(d) /* ML */ + value d; +{ + rewinddir((DIR *) d); + return Atom(0); +} diff --git a/otherlibs/unix/rmdir.c b/otherlibs/unix/rmdir.c new file mode 100644 index 0000000000..49e82b253a --- /dev/null +++ b/otherlibs/unix/rmdir.c @@ -0,0 +1,9 @@ +#include <mlvalues.h> +#include "unix.h" + +value unix_rmdir(path) /* ML */ + value path; +{ + if (rmdir(String_val(path)) == -1) uerror("rmdir", path); + return Atom(0); +} diff --git a/otherlibs/unix/select.c b/otherlibs/unix/select.c new file mode 100644 index 0000000000..7015cdb75e --- /dev/null +++ b/otherlibs/unix/select.c @@ -0,0 +1,90 @@ +#include <mlvalues.h> +#include <alloc.h> +#include <memory.h> +#include "unix.h" + +#ifdef HAS_SELECT + +#include <sys/types.h> +#include <sys/time.h> + +#ifdef FD_ISSET +typedef fd_set file_descr_set; +#else +typedef int file_descr_set; +#define FD_SETSIZE (sizeof(int) * 8) +#define FD_SET(fd,fds) (*(fds) |= 1 << (fd)) +#define FD_CLR(fd,fds) (*(fds) &= ~(1 << (fd))) +#define FD_ISSET(fd,fds) (*(fds) & (1 << (fd))) +#define FD_ZERO(fds) (*(fds) = 0) +#endif + +static void fdlist_to_fdset(fdlist, fdset) + value fdlist; + file_descr_set * fdset; +{ + value l; + FD_ZERO(fdset); + for (l = fdlist; Tag_val(l) == 1; l = Field(l, 1)) { + FD_SET(Int_val(Field(l, 0)), fdset); + } +} + +static value fdset_to_fdlist(fdset) + file_descr_set * fdset; +{ + int i; + Push_roots(roots, 1) +#define res roots[0] + res = Atom(0); + for (i = FD_SETSIZE - 1; i >= 0; i--) { + if (FD_ISSET(i, fdset)) { + value newres = alloc(2, 1); + Field(newres, 0) = Val_int(i); + Field(newres, 1) = res; + res = newres; + } + } + Pop_roots(); + return res; +#undef res +} + +value unix_select(readfds, writefds, exceptfds, timeout) /* ML */ + value readfds, writefds, exceptfds, timeout; +{ + file_descr_set read, write, except; + double tm; + struct timeval tv; + struct timeval * tvp; + int retcode; + Push_roots(roots, 1) +#define res roots[0] + + fdlist_to_fdset(readfds, &read); + fdlist_to_fdset(writefds, &write); + fdlist_to_fdset(exceptfds, &except); + tm = Double_val(timeout); + if (tm < 0.0) + tvp = (struct timeval *) NULL; + else { + tv.tv_sec = (int) tm; + tv.tv_usec = (int) (1e6 * (tm - (int) tm)); + tvp = &tv; + } + retcode = select(FD_SETSIZE, &read, &write, &except, tvp); + if (retcode == -1) uerror("select", Nothing); + res = alloc_tuple(3); + Field(res, 0) = fdset_to_fdlist(&read); + Field(res, 1) = fdset_to_fdlist(&write); + Field(res, 2) = fdset_to_fdlist(&except); + Pop_roots(); + return res; +#undef res +} + +#else + +value unix_select() { invalid_argument("select not implemented"); } + +#endif diff --git a/otherlibs/unix/sendrecv.c b/otherlibs/unix/sendrecv.c new file mode 100644 index 0000000000..82f7ebf1d3 --- /dev/null +++ b/otherlibs/unix/sendrecv.c @@ -0,0 +1,87 @@ +#include <mlvalues.h> +#include <alloc.h> +#include <memory.h> +#include "unix.h" + +#ifdef HAS_SOCKETS +#include "socketaddr.h" +#endif + +#if defined(HAS_SOCKETS) && defined(MSG_OOB) && defined(MSG_DONTROUTE) && defined(MSG_PEEK) + +static int msg_flag_table[] = { + MSG_OOB, MSG_DONTROUTE, MSG_PEEK +}; + +value unix_recv(sock, buff, ofs, len, flags) /* ML */ + value sock, buff, ofs, len, flags; +{ + int ret; + enter_blocking_section(); + ret = recv(Int_val(sock), &Byte(buff, Long_val(ofs)), Int_val(len), + convert_flag_list(flags, msg_flag_table)); + leave_blocking_section(); + if (ret == -1) uerror("recv", Nothing); + return Val_int(ret); +} + +value unix_recvfrom(sock, buff, ofs, len, flags) /* ML */ + value sock, buff, ofs, len, flags; +{ + int retcode; + value res; + Push_roots(a, 1); + + sock_addr_len = sizeof(sock_addr); + enter_blocking_section(); + retcode = recvfrom(Int_val(sock), &Byte(buff, Long_val(ofs)), Int_val(len), + convert_flag_list(flags, msg_flag_table), + &sock_addr.s_gen, &sock_addr_len); + leave_blocking_section(); + if (retcode == -1) uerror("recvfrom", Nothing); + a[0] = alloc_sockaddr(); + res = alloc_tuple(2); + Field(res, 0) = Val_int(retcode); + Field(res, 1) = a[0]; + Pop_roots(); + return res; +} + +value unix_send(sock, buff, ofs, len, flags) /* ML */ + value sock, buff, ofs, len, flags; +{ + int ret; + enter_blocking_section(); + ret = send(Int_val(sock), &Byte(buff, Long_val(ofs)), Int_val(len), + convert_flag_list(flags, msg_flag_table)); + leave_blocking_section(); + if (ret == -1) uerror("send", Nothing); + return Val_int(ret); +} + +value unix_sendto(argv, argc) /* ML */ + value * argv; + int argc; +{ + int ret; + get_sockaddr(argv[5]); + enter_blocking_section(); + ret = sendto(Int_val(argv[0]), &Byte(argv[1], Long_val(argv[2])), + Int_val(argv[3]), convert_flag_list(argv[4], msg_flag_table), + &sock_addr.s_gen, sock_addr_len); + leave_blocking_section(); + if (ret == -1) uerror("sendto", Nothing); + return Val_int(ret); +} + +#else + +value unix_recv() { invalid_argument("recv not implemented"); } + +value unix_recvfrom() { invalid_argument("recvfrom not implemented"); } + +value unix_send() { invalid_argument("send not implemented"); } + +value unix_sendto() { invalid_argument("sendto not implemented"); } + +#endif diff --git a/otherlibs/unix/setgid.c b/otherlibs/unix/setgid.c new file mode 100644 index 0000000000..eff8a444f0 --- /dev/null +++ b/otherlibs/unix/setgid.c @@ -0,0 +1,9 @@ +#include <mlvalues.h> +#include "unix.h" + +value unix_setgid(gid) /* ML */ + value gid; +{ + if (setgid(Int_val(gid)) == -1) uerror("setgid", Nothing); + return Val_unit; +} diff --git a/otherlibs/unix/setuid.c b/otherlibs/unix/setuid.c new file mode 100644 index 0000000000..31bba023f7 --- /dev/null +++ b/otherlibs/unix/setuid.c @@ -0,0 +1,9 @@ +#include <mlvalues.h> +#include "unix.h" + +value unix_setuid(uid) /* ML */ + value uid; +{ + if (setuid(Int_val(uid)) == -1) uerror("setuid", Nothing); + return Val_unit; +} diff --git a/otherlibs/unix/shutdown.c b/otherlibs/unix/shutdown.c new file mode 100644 index 0000000000..79326494e5 --- /dev/null +++ b/otherlibs/unix/shutdown.c @@ -0,0 +1,22 @@ +#include <mlvalues.h> +#include "unix.h" + +#ifdef HAS_SOCKETS + +static int shutdown_command_table[] = { + 0, 1, 2 +}; + +value unix_shutdown(sock, cmd) /* ML */ + value sock, cmd; +{ + if (shutdown(Int_val(sock), shutdown_command_table[Tag_val(cmd)]) == -1) + uerror("shutdown", Nothing); + return Val_unit; +} + +#else + +value unix_shutdown() { invalid_argument("shutdown not implemented"); } + +#endif diff --git a/otherlibs/unix/sleep.c b/otherlibs/unix/sleep.c new file mode 100644 index 0000000000..6abc80edfd --- /dev/null +++ b/otherlibs/unix/sleep.c @@ -0,0 +1,11 @@ +#include <mlvalues.h> +#include "unix.h" + +value unix_sleep(t) /* ML */ + value t; +{ + enter_blocking_section(); + sleep(Int_val(t)); + leave_blocking_section(); + return Val_unit; +} diff --git a/otherlibs/unix/socket.c b/otherlibs/unix/socket.c new file mode 100644 index 0000000000..6a1e197545 --- /dev/null +++ b/otherlibs/unix/socket.c @@ -0,0 +1,33 @@ +#include <mlvalues.h> +#include "unix.h" + +#ifdef HAS_SOCKETS + +#include <sys/types.h> +#include <sys/socket.h> + +int socket_domain_table[] = { + PF_UNIX, PF_INET +}; + +int socket_type_table[] = { + SOCK_STREAM, SOCK_DGRAM, SOCK_RAW, SOCK_SEQPACKET +}; + +value unix_socket(domain, type, proto) /* ML */ + value domain, type, proto; +{ + int retcode; + retcode = socket(socket_domain_table[Tag_val(domain)], + socket_type_table[Tag_val(type)], + Int_val(proto)); + if (retcode == -1) uerror("socket", Nothing); + return Val_int(retcode); + +} + +#else + +value unix_socket() { invalid_argument("socket not implemented"); } + +#endif diff --git a/otherlibs/unix/socketaddr.c b/otherlibs/unix/socketaddr.c new file mode 100644 index 0000000000..1cb9115a07 --- /dev/null +++ b/otherlibs/unix/socketaddr.c @@ -0,0 +1,81 @@ +#include <mlvalues.h> +#include <alloc.h> +#include <memory.h> +#include <str.h> +#include <errno.h> +#include "unix.h" + +#ifdef HAS_SOCKETS + +#include "socketaddr.h" + +value alloc_inet_addr(a) + unsigned long a; +{ + value res; + res = alloc(1, Abstract_tag); + GET_INET_ADDR(res) = a; + return res; +} + +void get_sockaddr(a) + value a; +{ + switch(Tag_val(a)) { + case 0: /* ADDR_UNIX */ + { value path; + mlsize_t len; + path = Field(a, 0); + len = string_length(path); + sock_addr.s_unix.sun_family = AF_UNIX; + if (len >= sizeof(sock_addr.s_unix.sun_path)) { + unix_error(ENAMETOOLONG, "", path); + } + bcopy(String_val(path), sock_addr.s_unix.sun_path, (int) len + 1); + sock_addr_len = sizeof(sock_addr.s_unix.sun_family) + len; + break; + } + case 1: /* ADDR_INET */ + { + char * p; + int n; + for (p = (char *) &sock_addr.s_inet, n = sizeof(sock_addr.s_inet); + n > 0; p++, n--) + *p = 0; + sock_addr.s_inet.sin_family = AF_INET; + sock_addr.s_inet.sin_addr.s_addr = GET_INET_ADDR(Field(a, 0)); + sock_addr.s_inet.sin_port = htons(Int_val(Field(a, 1))); + sock_addr_len = sizeof(struct sockaddr_in); + break; + } + } +} + +value alloc_sockaddr() +{ + value res; + switch(sock_addr.s_gen.sa_family) { + case AF_UNIX: + { Push_roots(n, 1); + n[0] = copy_string(sock_addr.s_unix.sun_path); + res = alloc(1, 0); + Field(res,0) = n[0]; + Pop_roots(); + break; + } + case AF_INET: + { Push_roots(a, 1); + a[0] = alloc_inet_addr(sock_addr.s_inet.sin_addr.s_addr); + res = alloc(2, 1); + Field(res,0) = a[0]; + Field(res,1) = Val_int(ntohs(sock_addr.s_inet.sin_port)); + Pop_roots(); + break; + } + default: + unix_error(EAFNOSUPPORT, "", Nothing); + } + return res; +} + +#endif diff --git a/otherlibs/unix/socketaddr.h b/otherlibs/unix/socketaddr.h new file mode 100644 index 0000000000..0cc9be8f79 --- /dev/null +++ b/otherlibs/unix/socketaddr.h @@ -0,0 +1,24 @@ +#include <sys/types.h> +#include <sys/socket.h> +#include <sys/un.h> +#include <netinet/in.h> + +union { + struct sockaddr s_gen; + struct sockaddr_un s_unix; + struct sockaddr_in s_inet; +} sock_addr; + +int sock_addr_len; + +#ifdef ANSI +void get_sockaddr(value); +value alloc_sockaddr(void); +value alloc_inet_addr(unsigned long); +#else +void get_sockaddr(); +value alloc_sockaddr(); +value alloc_inet_addr(); +#endif + +#define GET_INET_ADDR(v) (*((unsigned long *) (v))) diff --git a/otherlibs/unix/socketpair.c b/otherlibs/unix/socketpair.c new file mode 100644 index 0000000000..5a5a02d968 --- /dev/null +++ b/otherlibs/unix/socketpair.c @@ -0,0 +1,28 @@ +#include <mlvalues.h> +#include <alloc.h> +#include "unix.h" + +#ifdef HAS_SOCKETS + +extern int socket_domain_table[], socket_type_table[]; + +value unix_socketpair(domain, type, proto) /* ML */ + value domain, type, proto; +{ + int sv[2]; + value res; + if (socketpair(socket_domain_table[Tag_val(domain)], + socket_type_table[Tag_val(type)], + Int_val(proto), sv) == -1) + uerror("socketpair", Nothing); + res = alloc_tuple(2); + Field(res,0) = Val_int(sv[0]); + Field(res,1) = Val_int(sv[1]); + return res; +} + +#else + +value unix_socketpair() { invalid_argument("socketpair not implemented"); } + +#endif diff --git a/otherlibs/unix/stat.c b/otherlibs/unix/stat.c new file mode 100644 index 0000000000..5b19049b36 --- /dev/null +++ b/otherlibs/unix/stat.c @@ -0,0 +1,76 @@ +#include <mlvalues.h> +#include <alloc.h> +#include "unix.h" +#include "cst2constr.h" +#include <sys/types.h> +#include <sys/stat.h> + +#ifndef S_IFLNK +#define S_IFLNK 0 +#endif +#ifndef S_IFIFO +#define S_IFIFO 0 +#endif +#ifndef S_IFSOCK +#define S_IFSOCK 0 +#endif + +static int file_kind_table[] = { + S_IFREG, S_IFDIR, S_IFCHR, S_IFBLK, S_IFLNK, S_IFIFO, S_IFSOCK +}; + +static value stat_aux(buf) + struct stat * buf; +{ + value v; + + v = alloc_tuple(12); + Field (v, 0) = Val_int (buf->st_dev); + Field (v, 1) = Val_int (buf->st_ino); + Field (v, 2) = cst_to_constr(buf->st_mode & S_IFMT, file_kind_table, + sizeof(file_kind_table) / sizeof(int), 0); + Field (v, 3) = Val_int(buf->st_mode & 07777); + Field (v, 4) = Val_int (buf->st_nlink); + Field (v, 5) = Val_int (buf->st_uid); + Field (v, 6) = Val_int (buf->st_gid); + Field (v, 7) = Val_int (buf->st_rdev); + Field (v, 8) = Val_int (buf->st_size); + Field (v, 9) = Val_int (buf->st_atime); + Field (v, 10) = Val_int (buf->st_mtime); + Field (v, 11) = Val_int (buf->st_ctime); + return v; +} + +value unix_stat(path) /* ML */ + value path; +{ + int ret; + struct stat buf; + ret = stat(String_val(path), &buf); + if (ret == -1) uerror("stat", path); + return stat_aux(&buf); +} + +value unix_lstat(path) /* ML */ + value path; +{ + int ret; + struct stat buf; +#ifdef HAS_SYMLINK + ret = lstat(String_val(path), &buf); +#else + ret = stat(String_val(path), &buf); +#endif + if (ret == -1) uerror("lstat", path); + return stat_aux(&buf); +} + +value unix_fstat(fd) /* ML */ + value fd; +{ + int ret; + struct stat buf; + ret = fstat(Int_val(fd), &buf); + if (ret == -1) uerror("fstat", Nothing); + return stat_aux(&buf); +} diff --git a/otherlibs/unix/strofaddr.c b/otherlibs/unix/strofaddr.c new file mode 100644 index 0000000000..3407989462 --- /dev/null +++ b/otherlibs/unix/strofaddr.c @@ -0,0 +1,24 @@ +#include <mlvalues.h> +#include <alloc.h> +#include "unix.h" + +#ifdef HAS_SOCKETS + +#include "socketaddr.h" + +extern char * inet_ntoa(); + +value unix_string_of_inet_addr(a) /* ML */ + value a; +{ + struct in_addr address; + address.s_addr = GET_INET_ADDR(a); + return copy_string(inet_ntoa(address)); +} + +#else + +value unix_string_of_inet_addr() +{ invalid_argument("string_of_inet_addr not implemented"); } + +#endif diff --git a/otherlibs/unix/symlink.c b/otherlibs/unix/symlink.c new file mode 100644 index 0000000000..e4fdabd94b --- /dev/null +++ b/otherlibs/unix/symlink.c @@ -0,0 +1,18 @@ +#include <mlvalues.h> +#include "unix.h" + +#ifdef HAS_SYMLINK + +value unix_symlink(path1, path2) /* ML */ + value path1, path2; +{ + if (symlink(String_val(path1), String_val(path2)) == -1) + uerror("symlink", path2); + return Val_unit; +} + +#else + +value unix_symlink() { invalid_argument("symlink not implemented"); } + +#endif diff --git a/otherlibs/unix/termios.c b/otherlibs/unix/termios.c new file mode 100644 index 0000000000..fdb0fb95dd --- /dev/null +++ b/otherlibs/unix/termios.c @@ -0,0 +1,303 @@ +#include <mlvalues.h> +#include <alloc.h> +#include "unix.h" + +#ifdef HAS_TERMIOS + +#include <termios.h> +#include <errno.h> + +static struct termios terminal_status; + +enum { Bool, Enum, Speed, Char, End }; + +enum { Input, Output }; + +#define iflags ((long)(&terminal_status.c_iflag)) +#define oflags ((long)(&terminal_status.c_oflag)) +#define cflags ((long)(&terminal_status.c_cflag)) +#define lflags ((long)(&terminal_status.c_lflag)) +#define cc(n) ((long)(&terminal_status.c_cc[n])) + +/* Number of fields in the terminal_io record field. Cf. unix.mli */ + +#define NFIELDS 51 + +/* Structure of the terminal_io record. Cf. unix.mli */ + +static long terminal_io_descr[] = { + /* Input modes */ + Bool, iflags, IGNBRK, + Bool, iflags, BRKINT, + Bool, iflags, IGNPAR, + Bool, iflags, PARMRK, + Bool, iflags, INPCK, + Bool, iflags, ISTRIP, + Bool, iflags, INLCR, + Bool, iflags, IGNCR, + Bool, iflags, ICRNL, + Bool, iflags, IXON, + Bool, iflags, IXOFF, + /* Output modes */ + Bool, oflags, OPOST, + Bool, oflags, OLCUC, + Bool, oflags, ONLCR, + Bool, oflags, OCRNL, + Bool, oflags, ONOCR, + Bool, oflags, ONLRET, + Bool, oflags, OFILL, + Bool, oflags, OFDEL, + Enum, oflags, 0, 2, NLDLY, NL0, NL1, + Enum, oflags, 0, 2, CRDLY, CR0, CR1, + Enum, oflags, 0, 4, TABDLY, TAB0, TAB1, TAB2, TAB3, + Enum, oflags, 0, 2, BSDLY, BS0, BS1, + Enum, oflags, 0, 2, VTDLY, VT0, VT1, + Enum, oflags, 0, 2, FFDLY, FF0, FF1, + /* Control modes */ + Speed, Output, + Speed, Input, + Enum, cflags, 5, 4, CSIZE, CS5, CS6, CS7, CS8, + Enum, cflags, 1, 2, CSTOPB, 0, CSTOPB, + Bool, cflags, CREAD, + Bool, cflags, PARENB, + Bool, cflags, PARODD, + Bool, cflags, HUPCL, + Bool, cflags, CLOCAL, + /* Local modes */ + Bool, lflags, ISIG, + Bool, lflags, ICANON, + Bool, lflags, NOFLSH, + Bool, lflags, ECHO, + Bool, lflags, ECHOE, + Bool, lflags, ECHOK, + Bool, lflags, ECHONL, + /* Control characters */ + Char, cc(VINTR), + Char, cc(VQUIT), + Char, cc(VERASE), + Char, cc(VKILL), + Char, cc(VEOF), + Char, cc(VEOL), + Char, cc(VMIN), + Char, cc(VTIME), + Char, cc(VSTART), + Char, cc(VSTOP), + End +}; + +#undef iflags +#undef oflags +#undef cflags +#undef lflags +#undef cc + +struct speedtable_entry ; + +static struct { + speed_t speed; + int baud; +} speedtable[] = { + B0, 0, + B50, 50, + B75, 75, + B110, 110, + B134, 134, + B150, 150, + B300, 300, + B600, 600, + B1200, 1200, + B1800, 1800, + B2400, 2400, + B4800, 4800, + B9600, 9600, + B19200, 19200, + B38400, 38400 +}; + +#define NSPEEDS (sizeof(speedtable) / sizeof(speedtable[0])) + +static void encode_terminal_status(dst) + value * dst; +{ + long * pc; + int i; + + for(pc = terminal_io_descr; *pc != End; dst++) { + switch(*pc++) { + case Bool: + { int * src = (int *) (*pc++); + int msk = *pc++; + *dst = Val_bool(*src & msk); + break; } + case Enum: + { int * src = (int *) (*pc++); + int ofs = *pc++; + int num = *pc++; + int msk = *pc++; + for (i = 0; i < num; i++) { + if ((*src & msk) == pc[i]) { + *dst = Val_int(i + ofs); + break; + } + } + pc += num; + break; } + case Speed: + { int which = *pc++; + speed_t speed; + switch (which) { + case Output: + speed = cfgetospeed(&terminal_status); break; + case Input: + speed = cfgetispeed(&terminal_status); break; + } + for (i = 0; i < NSPEEDS; i++) { + if (speed == speedtable[i].speed) { + *dst = Val_int(speedtable[i].baud); + break; + } + } + break; } + case Char: + { unsigned char * src = (unsigned char *) (*pc++); + *dst = Val_int(*src); + break; } + } + } +} + +static void decode_terminal_status(src) + value * src; +{ + long * pc; + int i; + + for (pc = terminal_io_descr; *pc != End; src++) { + switch(*pc++) { + case Bool: + { int * dst = (int *) (*pc++); + int msk = *pc++; + if (Tag_val(*src) != 0) + *dst |= msk; + else + *dst &= ~msk; + break; } + case Enum: + { int * dst = (int *) (*pc++); + int ofs = *pc++; + int num = *pc++; + int msk = *pc++; + i = Int_val(*src) - ofs; + if (i >= 0 && i < num) { + *dst = (*dst & ~msk) | pc[i]; + } else { + unix_error(EINVAL, "tcsetattr", Nothing); + } + pc += num; + break; } + case Speed: + { int which = *pc++; + int baud = Int_val(*src); + int res; + for (i = 0; i < NSPEEDS; i++) { + if (baud == speedtable[i].baud) { + switch (which) { + case Output: + res = cfsetospeed(&terminal_status, speedtable[i].speed); break; + case Input: + res = cfsetispeed(&terminal_status, speedtable[i].speed); break; + } + if (res == -1) uerror("tcsetattr", Nothing); + goto ok; + } + } + unix_error(EINVAL, "tcsetattr", Nothing); + ok: + break; } + case Char: + { unsigned char * dst = (unsigned char *) (*pc++); + *dst = Int_val(*src); + break; } + } + } +} + +value unix_tcgetattr(fd) + value fd; +{ + value res; + + if (tcgetattr(Int_val(fd), &terminal_status) == -1) + uerror("tcgetattr", Nothing); + res = alloc_tuple(NFIELDS); + encode_terminal_status(&Field(res, 0)); + return res; +} + +static int when_flag_table[] = { + TCSANOW, TCSADRAIN, TCSAFLUSH +}; + +value unix_tcsetattr(fd, when, arg) + value fd, when, arg; +{ + if (tcgetattr(Int_val(fd), &terminal_status) == -1) + uerror("tcsetattr", Nothing); + decode_terminal_status(&Field(arg, 0)); + if (tcsetattr(Int_val(fd), + when_flag_table[Tag_val(when)], + &terminal_status) == -1) + uerror("tcsetattr", Nothing); + return Val_unit; +} + +value unix_tcsendbreak(fd, delay) + value fd, delay; +{ + if (tcsendbreak(Int_val(fd), Int_val(delay)) == -1) + uerror("tcsendbreak", Nothing); + return Val_unit; +} + +value unix_tcdrain(fd) + value fd; +{ + if (tcdrain(Int_val(fd)) == -1) uerror("tcdrain", Nothing); + return Val_unit; +} + +static int queue_flag_table[] = { + TCIFLUSH, TCOFLUSH, TCIOFLUSH +}; + +value unix_tcflush(fd, queue) + value fd, queue; +{ + if (tcflush(Int_val(fd), queue_flag_table[Tag_val(queue)]) == -1) + uerror("tcflush", Nothing); + return Val_unit; +} + +static int action_flag_table[] = { + TCOOFF, TCOON, TCIOFF, TCION +}; + +value unix_tcflow(fd, action) + value fd, action; +{ + if (tcflow(Int_val(fd), action_flag_table[Tag_val(action)]) == -1) + uerror("tcflow", Nothing); + return Val_unit; +} + +#else + +value unix_tcgetattr() { invalid_argument("tcgetattr not implemented"); } +value unix_tcsetattr() { invalid_argument("tcsetattr not implemented"); } +value unix_tcsendbreak() { invalid_argument("tcsendbreak not implemented"); } +value unix_tcdrain() { invalid_argument("tcdrain not implemented"); } +value unix_tcflush() { invalid_argument("tcflush not implemented"); } +value unix_tcflow() { invalid_argument("tcflow not implemented"); } + +#endif + diff --git a/otherlibs/unix/time.c b/otherlibs/unix/time.c new file mode 100644 index 0000000000..5cf811b472 --- /dev/null +++ b/otherlibs/unix/time.c @@ -0,0 +1,9 @@ +#include <mlvalues.h> +#include "unix.h" + +extern long time(); + +value unix_time() /* ML */ +{ + return Val_long(time((long *) NULL)); +} diff --git a/otherlibs/unix/times.c b/otherlibs/unix/times.c new file mode 100644 index 0000000000..a64ec327c2 --- /dev/null +++ b/otherlibs/unix/times.c @@ -0,0 +1,29 @@ +#include <mlvalues.h> +#include <alloc.h> +#include <memory.h> +#include "unix.h" +#include <sys/types.h> +#include <sys/times.h> + +value unix_times() /* ML */ +{ + value res; + struct tms buffer; + int i; + Push_roots(t,4); + +#ifndef HZ +#define HZ 60 +#endif + + times(&buffer); + t[0] = copy_double((double) buffer.tms_utime / HZ); + t[1] = copy_double((double) buffer.tms_stime / HZ); + t[2] = copy_double((double) buffer.tms_cutime / HZ); + t[3] = copy_double((double) buffer.tms_cstime / HZ); + res = alloc_tuple(4); + for (i = 0; i < 4; i++) + Field(res, i) = t[i]; + Pop_roots(); + return res; +} diff --git a/otherlibs/unix/truncate.c b/otherlibs/unix/truncate.c new file mode 100644 index 0000000000..1226df122d --- /dev/null +++ b/otherlibs/unix/truncate.c @@ -0,0 +1,18 @@ +#include <mlvalues.h> +#include "unix.h" + +#ifdef HAS_TRUNCATE + +value unix_truncate(path, len) /* ML */ + value path, len; +{ + if (truncate(String_val(path), Long_val(len)) == -1) + uerror("truncate", path); + return Val_unit; +} + +#else + +value unix_truncate() { invalid_argument("truncate not implemented"); } + +#endif diff --git a/otherlibs/unix/umask.c b/otherlibs/unix/umask.c new file mode 100644 index 0000000000..e5581fb2b8 --- /dev/null +++ b/otherlibs/unix/umask.c @@ -0,0 +1,8 @@ +#include <mlvalues.h> +#include "unix.h" + +value unix_umask(perm) /* ML */ + value perm; +{ + return Val_int(umask(Int_val(perm))); +} diff --git a/otherlibs/unix/unix.c b/otherlibs/unix/unix.c new file mode 100644 index 0000000000..848b650e58 --- /dev/null +++ b/otherlibs/unix/unix.c @@ -0,0 +1,287 @@ +#include <mlvalues.h> +#include <alloc.h> +#include <memory.h> +#include <fail.h> +#include "unix.h" +#include "cst2constr.h" +#include <errno.h> + +#ifndef EPERM +#define EPERM (-1) +#endif +#ifndef ENOENT +#define ENOENT (-1) +#endif +#ifndef ESRCH +#define ESRCH (-1) +#endif +#ifndef EINTR +#define EINTR (-1) +#endif +#ifndef EIO +#define EIO (-1) +#endif +#ifndef ENXIO +#define ENXIO (-1) +#endif +#ifndef E2BIG +#define E2BIG (-1) +#endif +#ifndef ENOEXEC +#define ENOEXEC (-1) +#endif +#ifndef EBADF +#define EBADF (-1) +#endif +#ifndef ECHILD +#define ECHILD (-1) +#endif +#ifndef EAGAIN +#define EAGAIN (-1) +#endif +#ifndef ENOMEM +#define ENOMEM (-1) +#endif +#ifndef EACCES +#define EACCES (-1) +#endif +#ifndef EFAULT +#define EFAULT (-1) +#endif +#ifndef ENOTBLK +#define ENOTBLK (-1) +#endif +#ifndef EBUSY +#define EBUSY (-1) +#endif +#ifndef EEXIST +#define EEXIST (-1) +#endif +#ifndef EXDEV +#define EXDEV (-1) +#endif +#ifndef ENODEV +#define ENODEV (-1) +#endif +#ifndef ENOTDIR +#define ENOTDIR (-1) +#endif +#ifndef EISDIR +#define EISDIR (-1) +#endif +#ifndef EINVAL +#define EINVAL (-1) +#endif +#ifndef ENFILE +#define ENFILE (-1) +#endif +#ifndef EMFILE +#define EMFILE (-1) +#endif +#ifndef ENOTTY +#define ENOTTY (-1) +#endif +#ifndef ETXTBSY +#define ETXTBSY (-1) +#endif +#ifndef EFBIG +#define EFBIG (-1) +#endif +#ifndef ENOSPC +#define ENOSPC (-1) +#endif +#ifndef ESPIPE +#define ESPIPE (-1) +#endif +#ifndef EROFS +#define EROFS (-1) +#endif +#ifndef EMLINK +#define EMLINK (-1) +#endif +#ifndef EPIPE +#define EPIPE (-1) +#endif +#ifndef EDOM +#define EDOM (-1) +#endif +#ifndef ERANGE +#define ERANGE (-1) +#endif +#ifndef EWOULDBLOCK +#define EWOULDBLOCK (-1) +#endif +#ifndef EINPROGRESS +#define EINPROGRESS (-1) +#endif +#ifndef EALREADY +#define EALREADY (-1) +#endif +#ifndef ENOTSOCK +#define ENOTSOCK (-1) +#endif +#ifndef EDESTADDRREQ +#define EDESTADDRREQ (-1) +#endif +#ifndef EMSGSIZE +#define EMSGSIZE (-1) +#endif +#ifndef EPROTOTYPE +#define EPROTOTYPE (-1) +#endif +#ifndef ENOPROTOOPT +#define ENOPROTOOPT (-1) +#endif +#ifndef EPROTONOSUPPORT +#define EPROTONOSUPPORT (-1) +#endif +#ifndef ESOCKTNOSUPPORT +#define ESOCKTNOSUPPORT (-1) +#endif +#ifndef EOPNOTSUPP +#define EOPNOTSUPP (-1) +#endif +#ifndef EPFNOSUPPORT +#define EPFNOSUPPORT (-1) +#endif +#ifndef EAFNOSUPPORT +#define EAFNOSUPPORT (-1) +#endif +#ifndef EADDRINUSE +#define EADDRINUSE (-1) +#endif +#ifndef EADDRNOTAVAIL +#define EADDRNOTAVAIL (-1) +#endif +#ifndef ENETDOWN +#define ENETDOWN (-1) +#endif +#ifndef ENETUNREACH +#define ENETUNREACH (-1) +#endif +#ifndef ENETRESET +#define ENETRESET (-1) +#endif +#ifndef ECONNABORTED +#define ECONNABORTED (-1) +#endif +#ifndef ECONNRESET +#define ECONNRESET (-1) +#endif +#ifndef ENOBUFS +#define ENOBUFS (-1) +#endif +#ifndef EISCONN +#define EISCONN (-1) +#endif +#ifndef ENOTCONN +#define ENOTCONN (-1) +#endif +#ifndef ESHUTDOWN +#define ESHUTDOWN (-1) +#endif +#ifndef ETOOMANYREFS +#define ETOOMANYREFS (-1) +#endif +#ifndef ETIMEDOUT +#define ETIMEDOUT (-1) +#endif +#ifndef ECONNREFUSED +#define ECONNREFUSED (-1) +#endif +#ifndef ELOOP +#define ELOOP (-1) +#endif +#ifndef ENAMETOOLONG +#define ENAMETOOLONG (-1) +#endif +#ifndef EHOSTDOWN +#define EHOSTDOWN (-1) +#endif +#ifndef EHOSTUNREACH +#define EHOSTUNREACH (-1) +#endif +#ifndef ENOTEMPTY +#define ENOTEMPTY (-1) +#endif +#ifndef EPROCLIM +#define EPROCLIM (-1) +#endif +#ifndef EUSERS +#define EUSERS (-1) +#endif +#ifndef EDQUOT +#define EDQUOT (-1) +#endif +#ifndef ESTALE +#define ESTALE (-1) +#endif +#ifndef EREMOTE +#define EREMOTE (-1) +#endif +#ifndef EIDRM +#define EIDRM (-1) +#endif +#ifndef EDEADLK +#define EDEADLK (-1) +#endif +#ifndef ENOLCK +#define ENOLCK (-1) +#endif +#ifndef ENOSYS +#define ENOSYS (-1) +#endif + +int error_table[] = { + 0, EPERM, ENOENT, ESRCH, EINTR, EIO, ENXIO, E2BIG, ENOEXEC, EBADF, + ECHILD, EAGAIN, ENOMEM, EACCES, EFAULT, ENOTBLK, EBUSY, EEXIST, EXDEV, + ENODEV, ENOTDIR, EISDIR, EINVAL, ENFILE, EMFILE, ENOTTY, ETXTBSY, + EFBIG, ENOSPC, ESPIPE, EROFS, EMLINK, EPIPE, EDOM, ERANGE, + EWOULDBLOCK, EINPROGRESS, EALREADY, ENOTSOCK, EDESTADDRREQ, EMSGSIZE, + EPROTOTYPE, ENOPROTOOPT, EPROTONOSUPPORT, ESOCKTNOSUPPORT, EOPNOTSUPP, + EPFNOSUPPORT, EAFNOSUPPORT, EADDRINUSE, EADDRNOTAVAIL, ENETDOWN, + ENETUNREACH, ENETRESET, ECONNABORTED, ECONNRESET, ENOBUFS, EISCONN, + ENOTCONN, ESHUTDOWN, ETOOMANYREFS, ETIMEDOUT, ECONNREFUSED, ELOOP, + ENAMETOOLONG, EHOSTDOWN, EHOSTUNREACH, ENOTEMPTY, EPROCLIM, EUSERS, + EDQUOT, ESTALE, EREMOTE, EIDRM, EDEADLK, ENOLCK, ENOSYS + /*, EUNKNOWNERROR */ +}; + +static value unix_error_exn; + +value unix_register_error(exnval) + value exnval; +{ + unix_error_exn = Field(exnval, 0); + register_global_root(&unix_error_exn); + return Val_unit; +} + +void unix_error(errcode, cmdname, cmdarg) + int errcode; + char * cmdname; + value cmdarg; +{ + value res; + Push_roots(r, 2); +#define name r[0] +#define arg r[1] + arg = cmdarg == Nothing ? copy_string("") : cmdarg; + name = copy_string(cmdname); + res = alloc(4, 0); + Field(res, 0) = unix_error_exn; + Field(res, 1) = + cst_to_constr(errcode, error_table, sizeof(error_table)/sizeof(int), + sizeof(error_table)/sizeof(int)); + Field(res, 2) = name; + Field(res, 3) = arg; + Pop_roots(); + mlraise(res); +} + +void uerror(cmdname, cmdarg) + char * cmdname; + value cmdarg; +{ + unix_error(errno, cmdname, cmdarg); +} diff --git a/otherlibs/unix/unix.h b/otherlibs/unix/unix.h new file mode 100644 index 0000000000..e63b04a7fe --- /dev/null +++ b/otherlibs/unix/unix.h @@ -0,0 +1,18 @@ +#define Nothing ((value) 0) + +#ifndef NULL +#ifdef ANSI +#define NULL ((void *) 0) +#else +#define NULL ((char *) 0) +#endif +#endif + +#ifdef ANSI +extern void unix_error(int errcode, char * cmdname, value arg); +extern void uerror(char * cmdname, value arg); +#else +void unix_error(); +void uerror(); +#endif + diff --git a/otherlibs/unix/unix.ml b/otherlibs/unix/unix.ml new file mode 100644 index 0000000000..729105ca18 --- /dev/null +++ b/otherlibs/unix/unix.ml @@ -0,0 +1,536 @@ +type error = + ENOERR + | EPERM + | ENOENT + | ESRCH + | EINTR + | EIO + | ENXIO + | E2BIG + | ENOEXEC + | EBADF + | ECHILD + | EAGAIN + | ENOMEM + | EACCES + | EFAULT + | ENOTBLK + | EBUSY + | EEXIST + | EXDEV + | ENODEV + | ENOTDIR + | EISDIR + | EINVAL + | ENFILE + | EMFILE + | ENOTTY + | ETXTBSY + | EFBIG + | ENOSPC + | ESPIPE + | EROFS + | EMLINK + | EPIPE + | EDOM + | ERANGE + | EWOULDBLOCK + | EINPROGRESS + | EALREADY + | ENOTSOCK + | EDESTADDRREQ + | EMSGSIZE + | EPROTOTYPE + | ENOPROTOOPT + | EPROTONOSUPPORT + | ESOCKTNOSUPPORT + | EOPNOTSUPP + | EPFNOSUPPORT + | EAFNOSUPPORT + | EADDRINUSE + | EADDRNOTAVAIL + | ENETDOWN + | ENETUNREACH + | ENETRESET + | ECONNABORTED + | ECONNRESET + | ENOBUFS + | EISCONN + | ENOTCONN + | ESHUTDOWN + | ETOOMANYREFS + | ETIMEDOUT + | ECONNREFUSED + | ELOOP + | ENAMETOOLONG + | EHOSTDOWN + | EHOSTUNREACH + | ENOTEMPTY + | EPROCLIM + | EUSERS + | EDQUOT + | ESTALE + | EREMOTE + | EIDRM + | EDEADLK + | ENOLCK + | ENOSYS + | EUNKNOWNERR + +exception Unix_error of error * string * string + +external register_unix_error: exn -> unit = "unix_register_error" + +let _ = register_unix_error(Unix_error(EUNKNOWNERR, "", "")) + +external error_message : error -> string = "unix_error_message" + +let handle_unix_error f arg = + try + f arg + with Unix_error(err, fun_name, arg) -> + prerr_string Sys.argv.(0); + prerr_string ": \""; + prerr_string fun_name; + prerr_string "\" failed"; + if String.length arg > 0 then begin + prerr_string " on \""; + prerr_string arg; + prerr_string "\"" + end; + prerr_string ": "; + prerr_endline (error_message err); + exit 2 + +external environment : unit -> string array = "unix_environment" + +type process_status = + WEXITED of int + | WSIGNALED of int * bool + | WSTOPPED of int + +type wait_flag = + WNOHANG + | WUNTRACED + +external execv : string -> string array -> unit = "unix_execv" +external execve : string -> string array -> string array -> unit = "unix_execve" +external execvp : string -> string array -> unit = "unix_execvp" +external fork : unit -> int = "unix_fork" +external wait : unit -> int * process_status = "unix_wait" +external waitpid : wait_flag list -> int -> int * process_status = "unix_waitpid" +external getpid : unit -> int = "unix_getpid" +external getppid : unit -> int = "unix_getppid" +external nice : int -> int = "unix_nice" + +type file_descr = int + +let stdin = 0 +let stdout = 1 +let stderr = 2 + +type open_flag = + O_RDONLY + | O_WRONLY + | O_RDWR + | O_NDELAY + | O_APPEND + | O_CREAT + | O_TRUNC + | O_EXCL + +type file_perm = int + + +external openfile : string -> open_flag list -> file_perm -> file_descr + = "unix_open" +external close : file_descr -> unit = "unix_close" +external read : file_descr -> string -> int -> int -> int = "unix_read" +external write : file_descr -> string -> int -> int -> int = "unix_write" +external in_channel_of_descr : file_descr -> in_channel = "open_descriptor" +external out_channel_of_descr : file_descr -> out_channel = "open_descriptor" +external descr_of_in_channel : in_channel -> file_descr = "channel_descriptor" +external descr_of_out_channel : out_channel -> file_descr = "channel_descriptor" + +type seek_command = + SEEK_SET + | SEEK_CUR + | SEEK_END + +external lseek : file_descr -> int -> seek_command -> int = "unix_lseek" +external truncate : string -> int -> unit = "unix_truncate" +external ftruncate : file_descr -> int -> unit = "unix_ftruncate" + +type file_kind = + S_REG + | S_DIR + | S_CHR + | S_BLK + | S_LNK + | S_FIFO + | S_SOCK + +type stats = + { st_dev : int; + st_ino : int; + st_kind : file_kind; + st_perm : file_perm; + st_nlink : int; + st_uid : int; + st_gid : int; + st_rdev : int; + st_size : int; + st_atime : int; + st_mtime : int; + st_ctime : int } + +external stat : string -> stats = "unix_stat" +external lstat : string -> stats = "unix_lstat" +external fstat : file_descr -> stats = "unix_fstat" +external unlink : string -> unit = "unix_unlink" +external rename : string -> string -> unit = "unix_rename" +external link : string -> string -> unit = "unix_link" + +type access_permission = + R_OK + | W_OK + | X_OK + | F_OK + +external chmod : string -> file_perm -> unit = "unix_chmod" +external fchmod : file_descr -> file_perm -> unit = "unix_fchmod" +external chown : string -> int -> int -> unit = "unix_chown" +external fchown : file_descr -> int -> int -> unit = "unix_fchown" +external umask : int -> int = "unix_umask" +external access : string -> access_permission list -> unit = "unix_access" +external fcntl_int : file_descr -> int -> int -> int = "unix_fcntl_int" +external fcntl_ptr : file_descr -> int -> string -> int = "unix_fcntl_ptr" +external mkdir : string -> file_perm -> unit = "unix_mkdir" +external rmdir : string -> unit = "unix_rmdir" +external chdir : string -> unit = "unix_chdir" +external getcwd : unit -> string = "unix_getcwd" + +type dir_handle + +external opendir : string -> dir_handle = "unix_opendir" +external readdir : dir_handle -> string = "unix_readdir" +external rewinddir : dir_handle -> unit = "unix_rewinddir" +external closedir : dir_handle -> unit = "unix_closedir" +external pipe : unit -> file_descr * file_descr = "unix_pipe" +external dup : file_descr -> file_descr = "unix_dup" +external dup2 : file_descr -> file_descr -> unit = "unix_dup2" +external symlink : string -> string -> unit = "unix_symlink" +external readlink : string -> string = "unix_readlink" +external mkfifo : string -> file_perm -> unit = "unix_mkfifo" +external ioctl_int : file_descr -> int -> int -> int = "unix_ioctl_int" +external ioctl_ptr : file_descr -> int -> string -> int = "unix_ioctl_ptr" +external select : + file_descr list -> file_descr list -> file_descr list -> float -> + file_descr list * file_descr list * file_descr list = "unix_select" + +type lock_command = + F_ULOCK + | F_LOCK + | F_TLOCK + | F_TEST + +external lockf : file_descr -> lock_command -> int -> unit = "unix_lockf" +external kill : int -> int -> unit = "unix_kill" +external pause : unit -> unit = "unix_pause" + +type process_times = + { tms_utime : float; + tms_stime : float; + tms_cutime : float; + tms_cstime : float } + +type tm = + { tm_sec : int; + tm_min : int; + tm_hour : int; + tm_mday : int; + tm_mon : int; + tm_year : int; + tm_wday : int; + tm_yday : int; + tm_isdst : bool } + +external time : unit -> int = "unix_time" +external gmtime : int -> tm = "unix_gmtime" +external localtime : int -> tm = "unix_localtime" +external alarm : int -> int = "unix_alarm" +external sleep : int -> unit = "unix_sleep" +external times : unit -> process_times = "unix_times" +external utimes : string -> int -> int -> unit = "unix_utimes" +external getuid : unit -> int = "unix_getuid" +external geteuid : unit -> int = "unix_geteuid" +external setuid : int -> unit = "unix_setuid" +external getgid : unit -> int = "unix_getgid" +external getegid : unit -> int = "unix_getegid" +external setgid : int -> unit = "unix_setgid" +external getgroups : unit -> int array = "unix_getgroups" + +type passwd_entry = + { pw_name : string; + pw_passwd : string; + pw_uid : int; + pw_gid : int; + pw_gecos : string; + pw_dir : string; + pw_shell : string } + +type group_entry = + { gr_name : string; + gr_passwd : string; + gr_gid : int; + gr_mem : string array } + + +external getlogin : unit -> string = "unix_getlogin" +external getpwnam : string -> passwd_entry = "unix_getpwnam" +external getgrnam : string -> group_entry = "unix_getgrnam" +external getpwuid : int -> passwd_entry = "unix_getpwuid" +external getgrgid : int -> group_entry = "unix_getgrgid" + +type inet_addr + +external inet_addr_of_string : string -> inet_addr + = "unix_inet_addr_of_string" +external string_of_inet_addr : inet_addr -> string + = "unix_string_of_inet_addr" +type socket_domain = + PF_UNIX + | PF_INET + +type socket_type = + SOCK_STREAM + | SOCK_DGRAM + | SOCK_RAW + | SOCK_SEQPACKET + +type sockaddr = + ADDR_UNIX of string + | ADDR_INET of inet_addr * int + +type shutdown_command = + SHUTDOWN_RECEIVE + | SHUTDOWN_SEND + | SHUTDOWN_ALL + +type msg_flag = + MSG_OOB + | MSG_DONTROUTE + | MSG_PEEK + +external socket : socket_domain -> socket_type -> int -> file_descr + = "unix_socket" +external socketpair : + socket_domain -> socket_type -> int -> file_descr * file_descr + = "unix_socketpair" +external accept : file_descr -> file_descr * sockaddr = "unix_accept" +external bind : file_descr -> sockaddr -> unit = "unix_bind" +external connect : file_descr -> sockaddr -> unit = "unix_connect" +external listen : file_descr -> int -> unit = "unix_listen" +external shutdown : file_descr -> shutdown_command -> unit = "unix_shutdown" +external recv : file_descr -> string -> int -> int -> msg_flag list -> int + = "unix_recv" +external recvfrom : + file_descr -> string -> int -> int -> msg_flag list -> int * sockaddr + = "unix_recvfrom" +external send : file_descr -> string -> int -> int -> msg_flag list -> int + = "unix_send" +external sendto : + file_descr -> string -> int -> int -> msg_flag list -> sockaddr -> int + = "unix_sendto" + +type host_entry = + { h_name : string; + h_aliases : string array; + h_addrtype : socket_domain; + h_addr_list : inet_addr array } + +type protocol_entry = + { p_name : string; + p_aliases : string array; + p_proto : int } + +type service_entry = + { s_name : string; + s_aliases : string array; + s_port : int; + s_proto : string } + +external gethostname : unit -> string = "unix_gethostname" +external gethostbyname : string -> host_entry = "unix_gethostbyname" +external gethostbyaddr : inet_addr -> host_entry = "unix_gethostbyaddr" +external getprotobyname : string -> protocol_entry + = "unix_getprotobyname" +external getprotobynumber : int -> protocol_entry + = "unix_getprotobynumber" +external getservbyname : string -> string -> service_entry + = "unix_getservbyname" +external getservbyport : int -> string -> service_entry + = "unix_getservbyport" +type terminal_io = { + mutable c_ignbrk: bool; + mutable c_brkint: bool; + mutable c_ignpar: bool; + mutable c_parmrk: bool; + mutable c_inpck: bool; + mutable c_istrip: bool; + mutable c_inlcr: bool; + mutable c_igncr: bool; + mutable c_icrnl: bool; + mutable c_ixon: bool; + mutable c_ixoff: bool; + mutable c_opost: bool; + mutable c_olcuc: bool; + mutable c_onlcr: bool; + mutable c_ocrnl: bool; + mutable c_onocr: bool; + mutable c_onlret: bool; + mutable c_ofill: bool; + mutable c_ofdel: bool; + mutable c_nldly: int; + mutable c_crdly: int; + mutable c_tabdly: int; + mutable c_bsdly: int; + mutable c_vtdly: int; + mutable c_ffdly: int; + mutable c_obaud: int; + mutable c_ibaud: int; + mutable c_csize: int; + mutable c_cstopb: int; + mutable c_cread: bool; + mutable c_parenb: bool; + mutable c_parodd: bool; + mutable c_hupcl: bool; + mutable c_clocal: bool; + mutable c_isig: bool; + mutable c_icanon: bool; + mutable c_noflsh: bool; + mutable c_echo: bool; + mutable c_echoe: bool; + mutable c_echok: bool; + mutable c_echonl: bool; + mutable c_vintr: char; + mutable c_vquit: char; + mutable c_verase: char; + mutable c_vkill: char; + mutable c_veof: char; + mutable c_veol: char; + mutable c_vmin: int; + mutable c_vtime: int; + mutable c_vstart: char; + mutable c_vstop: char + } + +external tcgetattr: file_descr -> terminal_io = "unix_tcgetattr" + +type setattr_when = TCSANOW | TCSADRAIN | TCSAFLUSH + +external tcsetattr: file_descr -> setattr_when -> terminal_io -> unit + = "unix_tcsetattr" +external tcsendbreak: file_descr -> int -> unit = "unix_tcsendbreak" +external tcdrain: file_descr -> unit = "unix_tcdrain" + +type flush_queue = TCIFLUSH | TCOFLUSH | TCIOFLUSH + +external tcflush: file_descr -> flush_queue -> unit = "unix_tcflush" + +type flow_action = TCOOFF | TCOON | TCIOFF | TCION + +external tcflow: file_descr -> flow_action -> unit = "unix_tcflow" + +(* High-level process management (system, popen) *) + +let system cmd = + match fork() with + 0 -> execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]; exit 127 + | id -> snd(waitpid [] id) + +type popen_process = + Process of in_channel * out_channel + | Process_in of in_channel + | Process_out of out_channel + +let popen_processes = (Hashtbl.new 7 : (popen_process, int) Hashtbl.t) + +let open_proc cmd proc input output = + match fork() with + 0 -> if input <> stdin then begin dup2 input stdin; close input end; + if output <> stdout then begin dup2 output stdout; close output end; + execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]; + exit 127 + | id -> Hashtbl.add popen_processes proc id + +let open_process_in cmd = + let (in_read, in_write) = pipe() in + let inchan = in_channel_of_descr in_read in + open_proc cmd (Process_in inchan) stdin in_write; inchan + +let open_process_out cmd = + let (out_read, out_write) = pipe() in + let outchan = out_channel_of_descr out_write in + open_proc cmd (Process_out outchan) out_read stdout; outchan + +let open_process cmd = + let (in_read, in_write) = pipe() in + let (out_read, out_write) = pipe() in + let inchan = in_channel_of_descr in_read in + let outchan = out_channel_of_descr out_write in + open_proc cmd (Process(inchan, outchan)) out_read in_write; (inchan, outchan) + +let close_proc fun_name proc = + try + let (_, status) = waitpid [] (Hashtbl.find popen_processes proc) in + Hashtbl.remove popen_processes proc; + status + with Not_found -> + raise(Unix_error(EBADF, fun_name, "")) + +let close_process_in inchan = + close_in inchan; + close_proc "close_process_in" (Process_in inchan) + +let close_process_out outchan = + close_out outchan; + close_proc "close_process_out" (Process_out outchan) + +let close_process (inchan, outchan) = + close_in inchan; close_out outchan; + close_proc "close_process" (Process(inchan, outchan)) + +(* High-level network functions *) + +let open_connection sockaddr = + let domain = + match sockaddr with ADDR_UNIX _ -> PF_UNIX | ADDR_INET(_,_) -> PF_INET in + let sock = + socket domain SOCK_STREAM 0 in + connect sock sockaddr; + (in_channel_of_descr sock, out_channel_of_descr sock) + +let shutdown_connection inchan = + shutdown (descr_of_in_channel inchan) SHUTDOWN_SEND + +let establish_server server_fun sockaddr = + let domain = + match sockaddr with ADDR_UNIX _ -> PF_UNIX | ADDR_INET(_,_) -> PF_INET in + let sock = + socket domain SOCK_STREAM 0 in + bind sock sockaddr; + listen sock 3; + while true do + let (s, caller) = accept sock in + (* The "double fork" trick, the process which calls server_fun will not + leave a zombie process *) + match fork() with + 0 -> if fork() != 0 then exit 0; (* The son exits, the grandson works *) + let inchan = in_channel_of_descr s in + let outchan = out_channel_of_descr s in + server_fun inchan outchan; + close_in inchan; + close_out outchan + | id -> close s; waitpid [] id (* Reclaim the son *); () + done diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli new file mode 100644 index 0000000000..a102e5330c --- /dev/null +++ b/otherlibs/unix/unix.mli @@ -0,0 +1,831 @@ +(* Interface to the Unix system *) + +(*** Error report *) + +type error = + ENOERR + | EPERM (* Not owner *) + | ENOENT (* No such file or directory *) + | ESRCH (* No such process *) + | EINTR (* Interrupted system call *) + | EIO (* I/O error *) + | ENXIO (* No such device or address *) + | E2BIG (* Arg list too long *) + | ENOEXEC (* Exec format error *) + | EBADF (* Bad file number *) + | ECHILD (* No children *) + | EAGAIN (* No more processes *) + | ENOMEM (* Not enough core *) + | EACCES (* Permission denied *) + | EFAULT (* Bad address *) + | ENOTBLK (* Block device required *) + | EBUSY (* Mount device busy *) + | EEXIST (* File exists *) + | EXDEV (* Cross-device link *) + | ENODEV (* No such device *) + | ENOTDIR (* Not a directory*) + | EISDIR (* Is a directory *) + | EINVAL (* Invalid argument *) + | ENFILE (* File table overflow *) + | EMFILE (* Too many open files *) + | ENOTTY (* Not a typewriter *) + | ETXTBSY (* Text file busy *) + | EFBIG (* File too large *) + | ENOSPC (* No space left on device *) + | ESPIPE (* Illegal seek *) + | EROFS (* Read-only file system *) + | EMLINK (* Too many links *) + | EPIPE (* Broken pipe *) + | EDOM (* Argument too large *) + | ERANGE (* Result too large *) + | EWOULDBLOCK (* Operation would block *) + | EINPROGRESS (* Operation now in progress *) + | EALREADY (* Operation already in progress *) + | ENOTSOCK (* Socket operation on non-socket *) + | EDESTADDRREQ (* Destination address required *) + | EMSGSIZE (* Message too long *) + | EPROTOTYPE (* Protocol wrong type for socket *) + | ENOPROTOOPT (* Protocol not available *) + | EPROTONOSUPPORT (* Protocol not supported *) + | ESOCKTNOSUPPORT (* Socket type not supported *) + | EOPNOTSUPP (* Operation not supported on socket *) + | EPFNOSUPPORT (* Protocol family not supported *) + | EAFNOSUPPORT (* Address family not supported by protocol family *) + | EADDRINUSE (* Address already in use *) + | EADDRNOTAVAIL (* Can't assign requested address *) + | ENETDOWN (* Network is down *) + | ENETUNREACH (* Network is unreachable *) + | ENETRESET (* Network dropped connection on reset *) + | ECONNABORTED (* Software caused connection abort *) + | ECONNRESET (* Connection reset by peer *) + | ENOBUFS (* No buffer space available *) + | EISCONN (* Socket is already connected *) + | ENOTCONN (* Socket is not connected *) + | ESHUTDOWN (* Can't send after socket shutdown *) + | ETOOMANYREFS (* Too many references: can't splice *) + | ETIMEDOUT (* Connection timed out *) + | ECONNREFUSED (* Connection refused *) + | ELOOP (* Too many levels of symbolic links *) + | ENAMETOOLONG (* File name too long *) + | EHOSTDOWN (* Host is down *) + | EHOSTUNREACH (* No route to host *) + | ENOTEMPTY (* Directory not empty *) + | EPROCLIM (* Too many processes *) + | EUSERS (* Too many users *) + | EDQUOT (* Disc quota exceeded *) + | ESTALE (* Stale NFS file handle *) + | EREMOTE (* Too many levels of remote in path *) + | EIDRM (* Identifier removed *) + | EDEADLK (* Deadlock condition. *) + | ENOLCK (* No record locks available. *) + | ENOSYS (* Function not implemented *) + | EUNKNOWNERR + + (* The type of error codes. *) + +exception Unix_error of error * string * string + (* Raised by the system calls below when an error is encountered. + The first component is the error code; the second component + is the function name; the third component is the string parameter + to the function, if it has one, or the empty string otherwise. *) + +external error_message : error -> string = "unix_error_message" + (* Return a string describing the given error code. *) + +val handle_unix_error : ('a -> 'b) -> 'a -> 'b + (* [handle_unix_error f x] applies [f] to [x] and returns the result. + If the exception [Unix_error] is raised, it prints a message + describing the error and exits with code 2. *) + + +(*** Interface with the parent process *) + +external environment : unit -> string array = "unix_environment" + (* Return the process environment, as an array of strings + with the format ``variable=value''. See also [sys__getenv]. *) + +(*** Process handling *) + +type process_status = + WEXITED of int + | WSIGNALED of int * bool + | WSTOPPED of int + + (* The termination status of a process. [WEXITED] means that the + process terminated normally by [exit]; the argument is the return + code. [WSIGNALED] means that the process was killed by a signal; + the first argument is the signal number, the second argument + indicates whether a ``core dump'' was performed. [WSTOPPED] means + that the process was stopped by a signal; the argument is the + signal number. *) + +type wait_flag = + WNOHANG + | WUNTRACED + + (* Flags for [waitopt] and [waitpid]. + [WNOHANG] means do not block if no child has + died yet, but immediately return with a pid equal to 0. + [WUNTRACED] means report also the children that receive stop + signals. *) + +external execv : string -> string array -> unit = "unix_execv" + (* [execv prog args] execute the program in file [prog], with + the arguments [args], and the current process environment. *) +external execve : string -> string array -> string array -> unit = "unix_execve" + (* Same as [execv], except that the third argument provides the + environment to the program executed. *) +external execvp : string -> string array -> unit = "unix_execvp" + (* Same as [execv], except that the program is searched in the path. *) +external fork : unit -> int = "unix_fork" + (* Fork a new process. The returned integer is 0 for the child + process, the pid of the child process for the parent process. *) +external wait : unit -> int * process_status = "unix_wait" + (* Wait until one of the children processes die, and return its pid + and termination status. *) +external waitpid : wait_flag list -> int -> int * process_status + = "unix_waitpid" + (* Same as [waitopt], but waits for the process whose pid is given. + Negative pid arguments represent process groups. *) +val system : string -> process_status + (* Execute the given command, wait until it terminates, and return + its termination status. The string is interpreted by the shell + [/bin/sh] and therefore can contain redirections, quotes, variables, + etc. The result [WEXITED 127] indicates that the shell couldn't + be executed. *) +external getpid : unit -> int = "unix_getpid" + (* Return the pid of the process. *) +external getppid : unit -> int = "unix_getppid" + (* Return the pid of the parent process. *) +external nice : int -> int = "unix_nice" + (* Change the process priority. The integer argument is added to the + ``nice'' value. (Higher values of the ``nice'' value mean + lower priorities.) Return the new nice value. *) + + +(*** Basic file input/output *) + +type file_descr + (* The abstract type of file descriptors. *) + +val stdin : file_descr +val stdout : file_descr +val stderr : file_descr + (* File descriptors for standard input, standard output and + standard error. *) + + +type open_flag = + O_RDONLY (* Open for reading *) + | O_WRONLY (* Open for writing *) + | O_RDWR (* Open for reading and writing *) + | O_NDELAY (* Open in non-blocking mode *) + | O_APPEND (* Open for append *) + | O_CREAT (* Create if nonexistent *) + | O_TRUNC (* Truncate to 0 length if existing *) + | O_EXCL (* Fail if existing *) + + (* The flags to [open]. *) + +type file_perm = int + (* The type of file access rights. *) + +external openfile : string -> open_flag list -> file_perm -> file_descr + = "unix_open" + (* Open the named file with the given flags. Third argument is + the permissions to give to the file if it is created. Return + a file descriptor on the named file. *) +external close : file_descr -> unit = "unix_close" + (* Close a file descriptor. *) +external read : file_descr -> string -> int -> int -> int = "unix_read" + (* [read fd buff start len] reads [len] characters from descriptor + [fd], storing them in string [buff], starting at position [ofs] + in string [buff]. Return the number of characters actually read. *) +external write : file_descr -> string -> int -> int -> int = "unix_write" + (* [write fd buff start len] writes [len] characters to descriptor + [fd], taking them from string [buff], starting at position [ofs] + in string [buff]. Return the number of characters actually + written. *) + + +(*** Interfacing with the standard input/output library (module io). *) + +external in_channel_of_descr : file_descr -> in_channel = "open_descriptor" + (* Create an input channel reading from the given descriptor. *) +external out_channel_of_descr : file_descr -> out_channel = "open_descriptor" + (* Create an output channel writing on the given descriptor. *) +external descr_of_in_channel : in_channel -> file_descr = "channel_descriptor" + (* Return the descriptor corresponding to an input channel. *) +external descr_of_out_channel : out_channel -> file_descr = "channel_descriptor" + (* Return the descriptor corresponding to an output channel. *) + + +(*** Seeking and truncating *) + +type seek_command = + SEEK_SET + | SEEK_CUR + | SEEK_END + + (* Positioning modes for [lseek]. [SEEK_SET] indicates positions + relative to the beginning of the file, [SEEK_CUR] relative to + the current position, [SEEK_END] relative to the end of the + file. *) + +external lseek : file_descr -> int -> seek_command -> int = "unix_lseek" + (* Set the current position for a file descriptor *) +external truncate : string -> int -> unit = "unix_truncate" + (* Truncates the named file to the given size. *) +external ftruncate : file_descr -> int -> unit = "unix_ftruncate" + (* Truncates the file corresponding to the given descriptor + to the given size. *) + + +(*** File statistics *) + +type file_kind = + S_REG (* Regular file *) + | S_DIR (* Directory *) + | S_CHR (* Character device *) + | S_BLK (* Block device *) + | S_LNK (* Symbolic link *) + | S_FIFO (* Named pipe *) + | S_SOCK (* Socket *) + +type stats = + { st_dev : int; (* Device number *) + st_ino : int; (* Inode number *) + st_kind : file_kind; (* Kind of the file *) + st_perm : file_perm; (* Access rights *) + st_nlink : int; (* Number of links *) + st_uid : int; (* User id of the owner *) + st_gid : int; (* Group id of the owner *) + st_rdev : int; (* Device minor number *) + st_size : int; (* Size in bytes *) + st_atime : int; (* Last access time *) + st_mtime : int; (* Last modification time *) + st_ctime : int } (* Last status change time *) + + (* The informations returned by the [stat] calls. *) + +external stat : string -> stats = "unix_stat" + (* Return the information for the named file. *) +external lstat : string -> stats = "unix_lstat" + (* Same as [stat], but in case the file is a symbolic link, + return the information for the link itself. *) +external fstat : file_descr -> stats = "unix_fstat" + (* Return the information for the file associated with the given + descriptor. *) + + +(*** Operations on file names *) + +external unlink : string -> unit = "unix_unlink" + (* Removes the named file *) +external rename : string -> string -> unit = "unix_rename" + (* [rename old new] changes the name of a file from [old] to [new]. *) +external link : string -> string -> unit = "unix_link" + (* [link source dest] creates a hard link named [dest] to the file + named [new]. *) + + +(*** File permissions and ownership *) + +type access_permission = + R_OK (* Read permission *) + | W_OK (* Write permission *) + | X_OK (* Execution permission *) + | F_OK (* File exists *) + + (* Flags for the [access] call. *) + +external chmod : string -> file_perm -> unit = "unix_chmod" + (* Change the permissions of the named file. *) +external fchmod : file_descr -> file_perm -> unit = "unix_fchmod" + (* Change the permissions of an opened file. *) +external chown : string -> int -> int -> unit = "unix_chown" + (* Change the owner uid and owner gid of the named file. *) +external fchown : file_descr -> int -> int -> unit = "unix_fchown" + (* Change the owner uid and owner gid of an opened file. *) +external umask : int -> int = "unix_umask" + (* Set the process creation mask, and return the previous mask. *) +external access : string -> access_permission list -> unit = "unix_access" + (* Check that the process has the given permissions over the named + file. Raise [Unix_error] otherwise. *) + + +(*** File descriptor hacking *) + +external fcntl_int : file_descr -> int -> int -> int = "unix_fcntl_int" + (* Interface to [fcntl] in the case where the argument is an + integer. The first integer argument is the command code; + the second is the integer parameter. *) +external fcntl_ptr : file_descr -> int -> string -> int = "unix_fcntl_ptr" + (* Interface to [fcntl] in the case where the argument is a pointer. + The integer argument is the command code. A pointer to the string + argument is passed as argument to the command. The string argument + is usually set up with the functions from modules [peek] and + [poke]. *) + + +(*** Directories *) + +external mkdir : string -> file_perm -> unit = "unix_mkdir" + (* Create a directory with the given permissions. *) +external rmdir : string -> unit = "unix_rmdir" + (* Remove an empty directory. *) +external chdir : string -> unit = "unix_chdir" + (* Change the process working directory. *) +external getcwd : unit -> string = "unix_getcwd" + (* Return the name of the current working directory. *) + + +type dir_handle + + (* The type of descriptors over opened directories. *) + +external opendir : string -> dir_handle = "unix_opendir" + (* Open a descriptor on a directory *) +external readdir : dir_handle -> string = "unix_readdir" + (* Return the next entry in a directory. + Raise [End_of_file] when the end of the directory has been + reached. *) +external rewinddir : dir_handle -> unit = "unix_rewinddir" + (* Reposition the descriptor to the beginning of the directory *) +external closedir : dir_handle -> unit = "unix_closedir" + (* Close a directory descriptor. *) + + +(*** Pipes and redirections *) + +external pipe : unit -> file_descr * file_descr = "unix_pipe" + (* Create a pipe. The first component of the result is opened + for reading, that's the exit to the pipe. The second component is + opened for writing, that's the entrace to the pipe. *) +external dup : file_descr -> file_descr = "unix_dup" + (* Duplicate a descriptor. *) +external dup2 : file_descr -> file_descr -> unit = "unix_dup2" + (* [dup2 fd1 fd2] duplicates [fd1] to [fd2], closing [fd2] if already + opened. *) + + +val open_process_in: string -> in_channel +val open_process_out: string -> out_channel +val open_process: string -> in_channel * out_channel + (* High-level pipe and process management. These functions + run the given command in parallel with the program, + and return channels connected to the standard input and/or + the standard output of the command. The command is interpreted + by the shell [/bin/sh] (cf. [system]). Warning: writes on channels + are buffered, hence be careful to call [flush] at the right times + to ensure correct synchronization. *) +val close_process_in: in_channel -> process_status +val close_process_out: out_channel -> process_status +val close_process: in_channel * out_channel -> process_status + (* Close channels opened by [open_process_in], [open_process_out] + and [open_process], respectively, wait for the associated + command to terminate, and return its termination status. *) + + +(*** Symbolic links *) + +external symlink : string -> string -> unit = "unix_symlink" + (* [symlink source dest] creates the file [dest] as a symbolic link + to the file [source]. *) +external readlink : string -> string = "unix_readlink" + (* Read the contents of a link. *) + + +(*** Named pipes *) + +external mkfifo : string -> file_perm -> unit = "unix_mkfifo" + (* Create a named pipe with the given permissions. *) + + +(*** Special files *) + +external ioctl_int : file_descr -> int -> int -> int = "unix_ioctl_int" + (* Interface to [ioctl] in the case where the argument is an + integer. The first integer argument is the command code; + the second is the integer parameter. *) +external ioctl_ptr : file_descr -> int -> string -> int = "unix_ioctl_ptr" + (* Interface to [ioctl] in the case where the argument is a pointer. + The integer argument is the command code. A pointer to the string + argument is passed as argument to the command. The string argument + is usually set up with the functions from modules [peek] and + [poke]. *) + + +(*** Polling *) + +external select : + file_descr list -> file_descr list -> file_descr list -> float -> + file_descr list * file_descr list * file_descr list = "unix_select" + + (* Wait until some input/output operations become possible on + some channels. The three list arguments are, respectively, a set + of descriptors to check for reading (first argument), for writing + (second argument), or for exceptional conditions (third argument). + The fourth argument is the maximal timeout, in seconds; a + negative fourth argument means no timeout (unbounded wait). + The result is composed of three sets of descriptors: those ready + for reading (first component), ready for writing (second component), + and over which an exceptional condition is pending (third + component). *) + +(*** Locking *) + +type lock_command = + F_ULOCK (* Unlock a region *) + | F_LOCK (* Lock a region, and block if already locked *) + | F_TLOCK (* Lock a region, or fail if already locked *) + | F_TEST (* Test a region for other process' locks *) + + (* Commands for [lockf]. *) + +external lockf : file_descr -> lock_command -> int -> unit = "unix_lockf" + + (* [lockf fd cmd size] puts a lock on a region of the file opened + as [fd]. The region starts at the current read/write position for + [fd] (as set by [lseek]), and extends [size] bytes forward if + [size] is positive, [size] bytes backwards if [size] is negative, + or to the end of the file if [size] is zero. *) + +(*** Signals *) + +external kill : int -> int -> unit = "unix_kill" + (* [kill pid sig] sends signal number [sig] to the process + with id [pid]. *) +external pause : unit -> unit = "unix_pause" + (* Wait until a non-ignored signal is delivered. *) + + +(*** Time functions *) + +type process_times = + { tms_utime : float; (* User time for the process *) + tms_stime : float; (* System time for the process *) + tms_cutime : float; (* User time for the children processes *) + tms_cstime : float } (* System time for the children processes *) + + (* The execution times (CPU times) of a process. *) + +type tm = + { tm_sec : int; (* Seconds 0..59 *) + tm_min : int; (* Minutes 0..59 *) + tm_hour : int; (* Hours 0..23 *) + tm_mday : int; (* Day of month 1..31 *) + tm_mon : int; (* Month of year 0..11 *) + tm_year : int; (* Year - 1900 *) + tm_wday : int; (* Day of week (Sunday is 0) *) + tm_yday : int; (* Day of year 0..365 *) + tm_isdst : bool } (* Daylight time savings in effect *) + + (* The type representing wallclock time and calendar date. *) + +external time : unit -> int = "unix_time" + (* Return the current time since 00:00:00 GMT, Jan. 1, 1970, + in seconds. *) +external gmtime : int -> tm = "unix_gmtime" + (* Convert a time in seconds, as returned by [time], into a date and + a time. Assumes Greenwich meridian time zone. *) +external localtime : int -> tm = "unix_localtime" + (* Convert a time in seconds, as returned by [time], into a date and + a time. Assumes the local time zone. *) +external alarm : int -> int = "unix_alarm" + (* Schedule a [SIGALRM] signals after the given number of seconds. *) +external sleep : int -> unit = "unix_sleep" + (* Stop execution for the given number of seconds. *) +external times : unit -> process_times = "unix_times" + (* Return the execution times of the process. *) +external utimes : string -> int -> int -> unit = "unix_utimes" + (* Set the last access time (second arg) and last modification time + (third arg) for a file. Times are expressed in seconds from + 00:00:00 GMT, Jan. 1, 1970. *) + + +(*** User id, group id *) + +external getuid : unit -> int = "unix_getuid" + (* Return the user id of the user executing the process. *) +external geteuid : unit -> int = "unix_geteuid" + (* Return the effective user id under which the process runs. *) +external setuid : int -> unit = "unix_setuid" + (* Set the real user id and effective user id for the process. *) +external getgid : unit -> int = "unix_getgid" + (* Return the group id of the user executing the process. *) +external getegid : unit -> int = "unix_getegid" + (* Return the effective group id under which the process runs. *) +external setgid : int -> unit = "unix_setgid" + (* Set the real group id and effective group id for the process. *) +external getgroups : unit -> int array = "unix_getgroups" + (* Return the list of groups to which the user executing the process + belongs. *) + + +type passwd_entry = + { pw_name : string; + pw_passwd : string; + pw_uid : int; + pw_gid : int; + pw_gecos : string; + pw_dir : string; + pw_shell : string } + (* Structure of entries in the [passwd] database. *) + +type group_entry = + { gr_name : string; + gr_passwd : string; + gr_gid : int; + gr_mem : string array } + (* Structure of entries in the [groups] database. *) + +external getlogin : unit -> string = "unix_getlogin" + (* Return the login name of the user executing the process. *) +external getpwnam : string -> passwd_entry = "unix_getpwnam" + (* Find an entry in [passwd] with the given name, or raise + [Not_found]. *) +external getgrnam : string -> group_entry = "unix_getgrnam" + (* Find an entry in [group] with the given name, or raise + [Not_found]. *) +external getpwuid : int -> passwd_entry = "unix_getpwuid" + (* Find an entry in [passwd] with the given user id, or raise + [Not_found]. *) +external getgrgid : int -> group_entry = "unix_getgrgid" + (* Find an entry in [group] with the given group id, or raise + [Not_found]. *) + + +(*** Internet addresses *) + +type inet_addr + (* The abstract type of Internet addresses. *) + +external inet_addr_of_string : string -> inet_addr + = "unix_inet_addr_of_string" +external string_of_inet_addr : inet_addr -> string + = "unix_string_of_inet_addr" + (* Conversions between string with the format [XXX.YYY.ZZZ.TTT] + and Internet addresses. [inet_addr_of_string] raises [Failure] + when given a string that does not match this format. *) + + +(*** Sockets *) + +type socket_domain = + PF_UNIX (* Unix domain *) + | PF_INET (* Internet domain *) + + (* The type of socket domains. *) + +type socket_type = + SOCK_STREAM (* Stream socket *) + | SOCK_DGRAM (* Datagram socket *) + | SOCK_RAW (* Raw socket *) + | SOCK_SEQPACKET (* Sequenced packets socket *) + + (* The type of socket kinds, specifying the semantics of + communications. *) + +type sockaddr = + ADDR_UNIX of string + | ADDR_INET of inet_addr * int + + (* The type of socket addresses. [ADDR_UNIX name] is a socket + address in the Unix domain; [name] is a file name in the file + system. [ADDR_INET(addr,port)] is a socket address in the Internet + domain; [addr] is the Internet address of the machine, and + [port] is the port number. *) + +type shutdown_command = + SHUTDOWN_RECEIVE (* Close for receiving *) + | SHUTDOWN_SEND (* Close for sending *) + | SHUTDOWN_ALL (* Close both *) + + (* The type of commands for [shutdown]. *) + +type msg_flag = + MSG_OOB + | MSG_DONTROUTE + | MSG_PEEK + + (* The flags for [recv], [recvfrom], [send] and [sendto]. *) + +external socket : socket_domain -> socket_type -> int -> file_descr + = "unix_socket" + (* Create a new socket in the given domain, and with the + given kind. The third argument is the protocol type; 0 selects + the default protocol for that kind of sockets. *) +external socketpair : + socket_domain -> socket_type -> int -> file_descr * file_descr + = "unix_socketpair" + (* Create a pair of unnamed sockets, connected together. *) +external accept : file_descr -> file_descr * sockaddr = "unix_accept" + (* Accept connections on the given socket. The returned descriptor + is a socket connected to the client; the returned address is + the address of the connecting client. *) +external bind : file_descr -> sockaddr -> unit = "unix_bind" + (* Bind a socket to an address. *) +external connect : file_descr -> sockaddr -> unit = "unix_connect" + (* Connect a socket to an address. *) +external listen : file_descr -> int -> unit = "unix_listen" + (* Set up a socket for receiving connection requests. The integer + argument is the maximal number of pending requests. *) +external shutdown : file_descr -> shutdown_command -> unit = "unix_shutdown" + (* Shutdown a socket connection. [SHUTDOWN_SEND] as second argument + causes reads on the other end of the connection to return + an end-of-file condition. + [SHUTDOWN_RECEIVE] causes writes on the other end of the connection + to return a closed pipe condition ([SIGPIPE] signal). *) +external recv : file_descr -> string -> int -> int -> msg_flag list -> int + = "unix_recv" +external recvfrom : + file_descr -> string -> int -> int -> msg_flag list -> int * sockaddr + = "unix_recvfrom" + (* Receive data from an unconnected socket. *) +external send : file_descr -> string -> int -> int -> msg_flag list -> int + = "unix_send" +external sendto : + file_descr -> string -> int -> int -> msg_flag list -> sockaddr -> int + = "unix_sendto" + (* Send data over an unconnected socket. *) + + +(*** High-level network connection functions *) + +val open_connection : sockaddr -> in_channel * out_channel + (* Connect to a server at the given address. + Return a pair of buffered channels connected to the server. + Remember to call [flush] on the output channel at the right times + to ensure correct synchronization. *) +val shutdown_connection : in_channel -> unit + (* ``Shut down'' a connection established with [open_connection]; + that is, transmit an end-of-file condition to the server reading + on the other side of the connection. *) +val establish_server : (in_channel -> out_channel -> 'a) -> sockaddr -> unit + (* Establish a server on the given address. + The function given as first argument is called for each connection + with two buffered channels connected to the client. A new process + is created for each connection. The function [establish_server] + never returns normally. *) + + +(*** Host and protocol databases *) + +type host_entry = + { h_name : string; + h_aliases : string array; + h_addrtype : socket_domain; + h_addr_list : inet_addr array } + (* Structure of entries in the [hosts] database. *) + +type protocol_entry = + { p_name : string; + p_aliases : string array; + p_proto : int } + (* Structure of entries in the [protocols] database. *) + +type service_entry = + { s_name : string; + s_aliases : string array; + s_port : int; + s_proto : string } + (* Structure of entries in the [services] database. *) + +external gethostname : unit -> string = "unix_gethostname" + (* Return the name of the local host. *) +external gethostbyname : string -> host_entry = "unix_gethostbyname" + (* Find an entry in [hosts] with the given name, or raise + [Not_found]. *) +external gethostbyaddr : inet_addr -> host_entry = "unix_gethostbyaddr" + (* Find an entry in [hosts] with the given address, or raise + [Not_found]. *) +external getprotobyname : string -> protocol_entry + = "unix_getprotobyname" + (* Find an entry in [protocols] with the given name, or raise + [Not_found]. *) +external getprotobynumber : int -> protocol_entry + = "unix_getprotobynumber" + (* Find an entry in [protocols] with the given protocol number, + or raise [Not_found]. *) +external getservbyname : string -> string -> service_entry + = "unix_getservbyname" + (* Find an entry in [services] with the given name, or raise + [Not_found]. *) +external getservbyport : int -> string -> service_entry + = "unix_getservbyport" + (* Find an entry in [services] with the given service number, + or raise [Not_found]. *) + + +(*** Terminal interface *) + +(* The following functions implement the POSIX standard terminal + interface. They provide control over asynchronous communication ports + and pseudo-terminals. Refer to the [termios] man page for a + complete description. *) + +type terminal_io = { + (* Input modes: *) + mutable c_ignbrk: bool; (* Ignore the break condition. *) + mutable c_brkint: bool; (* Signal interrupt on break condition. *) + mutable c_ignpar: bool; (* Ignore characters with parity errors. *) + mutable c_parmrk: bool; (* Mark parity errors. *) + mutable c_inpck: bool; (* Enable parity check on input. *) + mutable c_istrip: bool; (* Strip 8th bit on input characters. *) + mutable c_inlcr: bool; (* Map NL to CR on input. *) + mutable c_igncr: bool; (* Ignore CR on input. *) + mutable c_icrnl: bool; (* Map CR to NL on input. *) + mutable c_ixon: bool; (* Recognize XON/XOFF characters on input. *) + mutable c_ixoff: bool; (* Emit XON/XOFF chars to control input flow. *) + (* Output modes: *) + mutable c_opost: bool; (* Enable output processing. *) + mutable c_olcuc: bool; (* Map lowercase to uppercase on output. *) + mutable c_onlcr: bool; (* Map NL to CR/NL on output. *) + mutable c_ocrnl: bool; (* Map CR to NL on output. *) + mutable c_onocr: bool; (* No CR output at column 0. *) + mutable c_onlret: bool; (* NL is assumed to perform as CR. *) + mutable c_ofill: bool; (* Use fill characters instead of delays. *) + mutable c_ofdel: bool; (* Fill character is DEL instead of NULL. *) + mutable c_nldly: int; (* Newline delay type (0-1). *) + mutable c_crdly: int; (* Carriage return delay type (0-3). *) + mutable c_tabdly: int; (* Horizontal tab delay type (0-3). *) + mutable c_bsdly: int; (* Backspace delay type (0-1). *) + mutable c_vtdly: int; (* Vertical tab delay type (0-1). *) + mutable c_ffdly: int; (* Form feed delay type (0-1). *) + (* Control modes: *) + mutable c_obaud: int; (* Output baud rate (0 means close connection).*) + mutable c_ibaud: int; (* Input baud rate. *) + mutable c_csize: int; (* Number of bits per character (5-8). *) + mutable c_cstopb: int; (* Number of stop bits (1-2). *) + mutable c_cread: bool; (* Reception is enabled. *) + mutable c_parenb: bool; (* Enable parity generation and detection. *) + mutable c_parodd: bool; (* Specify odd parity instead of even. *) + mutable c_hupcl: bool; (* Hang up on last close. *) + mutable c_clocal: bool; (* Ignore modem status lines. *) + (* Local modes: *) + mutable c_isig: bool; (* Generate signal on INTR, QUIT, SUSP. *) + mutable c_icanon: bool; (* Enable canonical processing + (line buffering and editing) *) + mutable c_noflsh: bool; (* Disable flush after INTR, QUIT, SUSP. *) + mutable c_echo: bool; (* Echo input characters. *) + mutable c_echoe: bool; (* Echo ERASE (to erase previous character). *) + mutable c_echok: bool; (* Echo KILL (to erase the current line). *) + mutable c_echonl: bool; (* Echo NL even if c_echo is not set. *) + (* Control characters: *) + mutable c_vintr: char; (* Interrupt character (usually ctrl-C). *) + mutable c_vquit: char; (* Quit character (usually ctrl-\). *) + mutable c_verase: char; (* Erase character (usually DEL or ctrl-H). *) + mutable c_vkill: char; (* Kill line character (usually ctrl-U). *) + mutable c_veof: char; (* End-of-file character (usually ctrl-D). *) + mutable c_veol: char; (* Alternate end-of-line char. (usually none). *) + mutable c_vmin: int; (* Minimum number of characters to read + before the read request is satisfied. *) + mutable c_vtime: int; (* Maximum read wait (in 0.1s units). *) + mutable c_vstart: char; (* Start character (usually ctrl-Q). *) + mutable c_vstop: char (* Stop character (usually ctrl-S). *) + } + +external tcgetattr: file_descr -> terminal_io = "unix_tcgetattr" + (* Return the status of the terminal referred to by the given + file descriptor. *) + +type setattr_when = TCSANOW | TCSADRAIN | TCSAFLUSH + +external tcsetattr: file_descr -> setattr_when -> terminal_io -> unit + = "unix_tcsetattr" + (* Set the status of the terminal referred to by the given + file descriptor. The second argument indicates when the + status change takes place: immediately ([TCSANOW]), + when all pending output has been transmitted ([TCSADRAIN]), + or after flushing all input that has been received but not + read ([TCSAFLUSH]). [TCSADRAIN] is recommended when changing + the output parameters; [TCSAFLUSH], when changing the input + parameters. *) + +external tcsendbreak: file_descr -> int -> unit = "unix_tcsendbreak" + (* Send a break condition on the given file descriptor. + The second argument is the duration of the break, in 0.1s units; + 0 means standard duration (0.25s). *) + +external tcdrain: file_descr -> unit = "unix_tcdrain" + (* Waits until all output written on the given file descriptor + has been transmitted. *) + +type flush_queue = TCIFLUSH | TCOFLUSH | TCIOFLUSH + +external tcflush: file_descr -> flush_queue -> unit = "unix_tcflush" + (* Discard data written on the given file descriptor but not yet + transmitted, or data received but not yet read, depending on the + second argument: [TCIFLUSH] flushes data received but not read, + [TCOFLUSH] flushes data written but not transmitted, and + [TCIOFLUSH] flushes both. *) + +type flow_action = TCOOFF | TCOON | TCIOFF | TCION + +external tcflow: file_descr -> flow_action -> unit = "unix_tcflow" + (* Suspend or restart reception or transmission of data on + the given file descriptor, depending on the second argument: + [TCOOFF] suspends output, [TCOON] restarts output, + [TCIOFF] transmits a STOP character to suspend input, + and [TCION] transmits a START character to restart input. *) diff --git a/otherlibs/unix/unlink.c b/otherlibs/unix/unlink.c new file mode 100644 index 0000000000..67684f473a --- /dev/null +++ b/otherlibs/unix/unlink.c @@ -0,0 +1,9 @@ +#include <mlvalues.h> +#include "unix.h" + +value unix_unlink(path) /* ML */ + value path; +{ + if (unlink(String_val(path)) == -1) uerror("unlink", path); + return Val_unit; +} diff --git a/otherlibs/unix/utimes.c b/otherlibs/unix/utimes.c new file mode 100644 index 0000000000..2c481829ed --- /dev/null +++ b/otherlibs/unix/utimes.c @@ -0,0 +1,51 @@ +#include <mlvalues.h> +#include "unix.h" + +#ifdef HAS_UTIME + +#include <sys/types.h> +#include <utime.h> + +value unix_utimes(path, atime, mtime) /* ML */ + value path, atime, mtime; +{ + struct utimbuf times, * t; + times.actime = Int_val(atime); + times.modtime = Int_val(mtime); + if (times.actime || times.modtime) + t = × + else + t = (struct utimbuf *) NULL; + if (utime(String_val(path), t) == -1) uerror("utimes", path); + return Val_unit; +} + +#else + +#ifdef HAS_UTIMES + +#include <sys/types.h> +#include <sys/time.h> + +value unix_utimes(path, atime, mtime) /* ML */ + value path, atime, mtime; +{ + struct timeval tv[2], * t; + tv[0].tv_sec = Int_val(atime); + tv[0].tv_usec = 0; + tv[1].tv_sec = Int_val(mtime); + tv[1].tv_usec = 0; + if (tv[0].tv_sec || tv[1].tv_sec) + t = tv; + else + t = (struct timeval *) NULL; + if (utimes(String_val(path), t) == -1) uerror("utime", path); + return Val_unit; +} + +#else + +value unix_utimes() { invalid_argument("utimes not implemented"); } + +#endif +#endif diff --git a/otherlibs/unix/wait.c b/otherlibs/unix/wait.c new file mode 100644 index 0000000000..1f41da9f3d --- /dev/null +++ b/otherlibs/unix/wait.c @@ -0,0 +1,35 @@ +#include <mlvalues.h> +#include <alloc.h> +#include <memory.h> +#include "unix.h" + +value unix_wait() /* ML */ +{ + value res; + int pid, status; + Push_roots(r, 1); +#define st r[0] + pid = wait(&status); + if (pid == -1) uerror("wait", Nothing); + switch (status & 0xFF) { + case 0: + st = alloc(1, 0); + Field(st, 0) = Val_int((status >> 8) & 0xFF); + break; + case 0177: + st = alloc(1, 2); + Field(st, 0) = Val_int((status >> 8) & 0xFF); + break; + default: + st = alloc(2, 1); + Field(st, 0) = Val_int(status & 0x3F); + Field(st, 1) = status & 0200 ? Val_true : Val_false; + break; + } + res = alloc_tuple(2); + Field(res, 0) = Val_int(pid); + Field(res, 1) = st; + Pop_roots(); + return res; +} + diff --git a/otherlibs/unix/waitpid.c b/otherlibs/unix/waitpid.c new file mode 100644 index 0000000000..9761a38520 --- /dev/null +++ b/otherlibs/unix/waitpid.c @@ -0,0 +1,52 @@ +#include <mlvalues.h> +#include <alloc.h> +#include <memory.h> +#include "unix.h" + +#ifdef HAS_WAITPID + +#include <sys/types.h> +#include <sys/wait.h> + +static int wait_flag_table[] = { + WNOHANG, WUNTRACED +}; + +value unix_waitpid(flags, pid_req) + value flags, pid_req; +{ + int pid, status; + value res; + Push_roots(r, 1); +#define st r[0] + + pid = waitpid(Int_val(pid_req), &status, + convert_flag_list(flags, wait_flag_table)); + if (pid == -1) uerror("waitpid", Nothing); + switch (status & 0xFF) { + case 0: + st = alloc(1, 0); + Field(st, 0) = Val_int((status >> 8) & 0xFF); + break; + case 0177: + st = alloc(1, 2); + Field(st, 0) = Val_int((status >> 8) & 0xFF); + break; + default: + st = alloc(2, 1); + Field(st, 0) = Val_int(status & 0x3F); + Field(st, 1) = status & 0200 ? Val_true : Val_false; + break; + } + res = alloc_tuple(2); + Field(res, 0) = Val_int(pid); + Field(res, 1) = st; + Pop_roots(); + return res; +} + +#else + +value unix_waitpid() { invalid_argument("waitpid not implemented"); } + +#endif diff --git a/otherlibs/unix/write.c b/otherlibs/unix/write.c new file mode 100644 index 0000000000..acb6f3331b --- /dev/null +++ b/otherlibs/unix/write.c @@ -0,0 +1,13 @@ +#include <mlvalues.h> +#include "unix.h" + +value unix_write(fd, buf, ofs, len) /* ML */ + value fd, buf, ofs, len; +{ + int ret; + enter_blocking_section(); + ret = write(Int_val(fd), &Byte(buf, Long_val(ofs)), Int_val(len)); + leave_blocking_section(); + if (ret == -1) uerror("write", Nothing); + return Val_int(ret); +} |