From 6919159c42a8b6a5f28aee1819e45fa85c689d16 Mon Sep 17 00:00:00 2001 From: Xavier Leroy Date: Mon, 25 Jun 2001 08:04:00 +0000 Subject: [PATCH] Rendu Unix thread-safe; ThreadUnix est deprecated git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@3542 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 --- otherlibs/threads/Makefile | 26 +- otherlibs/threads/Tests/close.ml | 4 +- otherlibs/threads/Tests/testio.ml | 4 +- otherlibs/threads/Tests/testsocket.ml | 1 - otherlibs/threads/Tests/token2.ml | 8 +- otherlibs/threads/Tests/torture.ml | 8 +- otherlibs/threads/threadUnix.ml | 200 +----- otherlibs/threads/threadUnix.mli | 12 +- otherlibs/threads/unix.ml | 846 ++++++++++++++++++++++++++ 9 files changed, 911 insertions(+), 198 deletions(-) create mode 100644 otherlibs/threads/unix.ml diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile index 77ccb79d7..4af085bb9 100644 --- a/otherlibs/threads/Makefile +++ b/otherlibs/threads/Makefile @@ -15,7 +15,7 @@ include ../../config/Makefile CC=$(BYTECC) -CFLAGS=-I../../byterun -O $(BYTECCCOMPOPTS) +CFLAGS=-I../../byterun -O $(BYTECCCOMPOPTS) -g CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib -I ../unix C_OBJS=scheduler.o @@ -37,7 +37,11 @@ LIB_OBJS=pervasives.cmo \ $(LIB)/lazy.cmo $(LIB)/filename.cmo $(LIB)/int32.cmo $(LIB)/int64.cmo \ $(LIB)/nativeint.cmo -all: libthreads.a threads.cma stdlib.cma +UNIXLIB=../unix + +UNIXLIB_OBJS=unix.cmo + +all: libthreads.a threads.cma stdlib.cma unix.cma allopt: @@ -52,6 +56,9 @@ threads.cma: $(CAML_OBJS) stdlib.cma: $(LIB_OBJS) $(CAMLC) -a -o stdlib.cma $(LIB_OBJS) +unix.cma: $(UNIXLIB_OBJS) + $(CAMLC) -a -linkall -custom -o unix.cma $(UNIXLIB_OBJS) -cclib -lunix + pervasives.cmo: pervasives.mli pervasives.cmi pervasives.ml $(CAMLC) -nopervasives -c pervasives.ml @@ -70,18 +77,27 @@ marshal.mli: $(LIB)/marshal.mli marshal.cmi: $(LIB)/marshal.cmi ln -s $(LIB)/marshal.cmi marshal.cmi +unix.cmo: unix.mli unix.cmi unix.ml + $(CAMLC) -c unix.ml + +unix.mli: $(UNIXLIB)/unix.mli + ln -s $(UNIXLIB)/unix.mli unix.mli + +unix.cmi: $(UNIXLIB)/unix.cmi + ln -s $(UNIXLIB)/unix.cmi unix.cmi + partialclean: rm -f *.cm* clean: partialclean rm -f libthreads.a *.o - rm -f pervasives.mli marshal.mli + rm -f pervasives.mli marshal.mli unix.mli install: cp libthreads.a $(LIBDIR)/libthreads.a cd $(LIBDIR); $(RANLIB) libthreads.a if test -d $(LIBDIR)/threads; then : ; else mkdir $(LIBDIR)/threads; fi - cp thread.cmi mutex.cmi condition.cmi event.cmi threadUnix.cmi threads.cma stdlib.cma $(LIBDIR)/threads + cp thread.cmi mutex.cmi condition.cmi event.cmi threadUnix.cmi threads.cma stdlib.cma unix.cma $(LIBDIR)/threads cp thread.mli mutex.mli condition.mli event.mli threadUnix.mli $(LIBDIR) installopt: @@ -92,7 +108,7 @@ installopt: $(CAMLC) -c $(COMPFLAGS) $< .ml.cmo: - $(CAMLC) -c -g $(COMPFLAGS) $< + $(CAMLC) -c $(COMPFLAGS) $< .ml.cmx: $(CAMLOPT) -c $(COMPFLAGS) $< diff --git a/otherlibs/threads/Tests/close.ml b/otherlibs/threads/Tests/close.ml index 467016b43..21ebb44a6 100644 --- a/otherlibs/threads/Tests/close.ml +++ b/otherlibs/threads/Tests/close.ml @@ -1,5 +1,5 @@ let main () = - let (rd, wr) = ThreadUnix.pipe() in + let (rd, wr) = Unix.pipe() in Thread.create (fun () -> Thread.delay 3.0; @@ -8,7 +8,7 @@ let main () = (); let buf = String.create 10 in prerr_endline "reading..."; - ThreadUnix.read rd buf 0 10; + Unix.read rd buf 0 10; prerr_endline "read returned" let _ = Unix.handle_unix_error main () diff --git a/otherlibs/threads/Tests/testio.ml b/otherlibs/threads/Tests/testio.ml index 3553b28dd..3ed08a88f 100644 --- a/otherlibs/threads/Tests/testio.ml +++ b/otherlibs/threads/Tests/testio.ml @@ -4,14 +4,14 @@ let test msg producer consumer src dst = print_string msg; print_newline(); let ic = open_in_bin src in let oc = open_out_bin dst in - let (in_fd, out_fd) = ThreadUnix.pipe() in + let (in_fd, out_fd) = Unix.pipe() in let ipipe = Unix.in_channel_of_descr in_fd in let opipe = Unix.out_channel_of_descr out_fd in let prod = Thread.create producer (ic, opipe) in let cons = Thread.create consumer (ipipe, oc) in Thread.join prod; Thread.join cons; - if ThreadUnix.system ("cmp " ^ src ^ " " ^ dst) = Unix.WEXITED 0 + if Unix.system ("cmp " ^ src ^ " " ^ dst) = Unix.WEXITED 0 then print_string "passed" else print_string "FAILED"; print_newline() diff --git a/otherlibs/threads/Tests/testsocket.ml b/otherlibs/threads/Tests/testsocket.ml index 62ce5d75f..b8c04a6df 100644 --- a/otherlibs/threads/Tests/testsocket.ml +++ b/otherlibs/threads/Tests/testsocket.ml @@ -1,5 +1,4 @@ open Unix -open ThreadUnix let engine number address = print_int number; print_string "> connecting"; print_newline(); diff --git a/otherlibs/threads/Tests/token2.ml b/otherlibs/threads/Tests/token2.ml index 0c08d174b..32b897dd1 100644 --- a/otherlibs/threads/Tests/token2.ml +++ b/otherlibs/threads/Tests/token2.ml @@ -9,7 +9,7 @@ let token = ref 0 let process (n, ins, outs, nprocs) = let buf = String.create 1 in while true do - ThreadUnix.read ins.(n) buf 0 1; + Unix.read ins.(n) buf 0 1; (* Printf.printf "Thread %d got the token\n" n; *) if n = 0 then begin decr niter; @@ -17,7 +17,7 @@ let process (n, ins, outs, nprocs) = end; let next = if n + 1 >= nprocs then 0 else n + 1 in (* Printf.printf "Thread %d sending token to thread %d\n" n next; *) - ThreadUnix.write outs.(next) buf 0 1 + Unix.write outs.(next) buf 0 1 done let main() = @@ -26,11 +26,11 @@ let main() = let ins = Array.create nprocs Unix.stdin in let outs = Array.create nprocs Unix.stdout in for n = 0 to nprocs - 1 do - let (i, o) = ThreadUnix.pipe() in ins.(n) <- i; outs.(n) <- o + let (i, o) = Unix.pipe() in ins.(n) <- i; outs.(n) <- o done; niter := iter; for i = 0 to nprocs - 1 do Thread.create process (i, ins, outs, nprocs) done; - ThreadUnix.write outs.(0) "X" 0 1; + Unix.write outs.(0) "X" 0 1; Thread.delay 3600. let _ = main() diff --git a/otherlibs/threads/Tests/torture.ml b/otherlibs/threads/Tests/torture.ml index 8d60e6854..701bbac6f 100644 --- a/otherlibs/threads/Tests/torture.ml +++ b/otherlibs/threads/Tests/torture.ml @@ -17,14 +17,14 @@ let writer_thread (oc, size) = while true do (* print_string "writer "; print_int size; print_newline(); *) let buff = String.make size 'a' in - ThreadUnix.write oc buff 0 size + Unix.write oc buff 0 size done let reader_thread (ic, size) = while true do (* print_string "reader "; print_int size; print_newline(); *) let buff = String.create size in - let n = ThreadUnix.read ic buff 0 size in + let n = Unix.read ic buff 0 size in (* print_string "reader "; print_int n; print_newline(); *) for i = 0 to n-1 do if buff.[i] <> 'a' then prerr_endline "error in reader_thread" @@ -33,10 +33,10 @@ let reader_thread (ic, size) = let main() = Thread.create gc_thread (); - let (out1, in1) = ThreadUnix.pipe() in + let (out1, in1) = Unix.pipe() in Thread.create writer_thread (in1, 4096); Thread.create reader_thread (out1, 4096); - let (out2, in2) = ThreadUnix.pipe() in + let (out2, in2) = Unix.pipe() in Thread.create writer_thread (in2, 16); Thread.create reader_thread (out2, 16); stdin_thread() diff --git a/otherlibs/threads/threadUnix.ml b/otherlibs/threads/threadUnix.ml index fc2dda1e2..3ad9b9a76 100644 --- a/otherlibs/threads/threadUnix.ml +++ b/otherlibs/threads/threadUnix.ml @@ -14,55 +14,34 @@ (* Module [ThreadUnix]: thread-compatible system calls *) +let execv = Unix.execv +let execve = Unix.execve +let execvp = Unix.execvp +let wait = Unix.wait +let waitpid = Unix.waitpid +let system = Unix.system +let read = Unix.read +let write = Unix.write +let select = Unix.select +let pipe = Unix.pipe +let open_process_in = Unix.open_process_in +let open_process_out = Unix.open_process_out +let open_process = Unix.open_process +let open_process_full = Unix.open_process_full +let sleep = Unix.sleep +let socket = Unix.socket +let socketpair = Unix.socketpair +let accept = Unix.accept +let connect = Unix.connect +let recv = Unix.recv +let recvfrom = Unix.recvfrom +let send = Unix.send +let sendto = Unix.sendto +let open_connection = Unix.open_connection +let establish_server = Unix.establish_server + open Unix -(*** Process handling *) - -(* Disable the timer interrupt before doing exec, because some OS - keep sending timer interrupts to the exec'ed code. - Make sure we're not preempted just after disabling the timer... *) -let execv proc args = - Thread.critical_section := true; - ignore(Unix.setitimer ITIMER_VIRTUAL {it_interval = 0.0; it_value = 0.0}); - Unix.execv proc args - -let execve proc args env = - Thread.critical_section := true; - ignore(Unix.setitimer ITIMER_VIRTUAL {it_interval = 0.0; it_value = 0.0}); - Unix.execve proc args env - -let execvp proc args = - Thread.critical_section := true; - ignore(Unix.setitimer ITIMER_VIRTUAL {it_interval = 0.0; it_value = 0.0}); - Unix.execvp proc args - -let wait () = - Thread.wait_pid (-1) - -let waitpid flags pid = - if List.mem WNOHANG flags - then Unix.waitpid flags pid - else Thread.wait_pid pid - -let system cmd = - match fork() with - 0 -> execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]; exit 127 - | id -> snd(waitpid [] id) - -(*** File I/O *) - -let rec read fd buff ofs len = - try - Unix.read fd buff ofs len - with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> - Thread.wait_read fd; read fd buff ofs len - -let rec write fd buff ofs len = - try - Unix.write fd buff ofs len - with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> - Thread.wait_write fd; write fd buff ofs len - let rec timed_read fd buff ofs len timeout = if Thread.wait_timed_read fd timeout then begin try Unix.read fd buff ofs len @@ -78,130 +57,3 @@ let rec timed_write fd buff ofs len timeout = timed_write fd buff ofs len timeout end else raise (Unix_error(ETIMEDOUT, "timed_write", "")) - -let select = Thread.select - -(*** Pipes *) - -let pipe() = - let (out_fd, in_fd as fd_pair) = Unix.pipe() in - Unix.set_nonblock in_fd; - Unix.set_nonblock out_fd; - fd_pair - -let open_process_in cmd = - let ic = Unix.open_process_in cmd in - Unix.set_nonblock(Unix.descr_of_in_channel ic); - ic - -let open_process_out cmd = - let oc = Unix.open_process_out cmd in - Unix.set_nonblock(Unix.descr_of_out_channel oc); - oc - -let open_process cmd = - let (ic, oc as channels) = Unix.open_process cmd in - Unix.set_nonblock(Unix.descr_of_in_channel ic); - Unix.set_nonblock(Unix.descr_of_out_channel oc); - channels - -let open_process_full cmd env = - let (ic, oc, ec as channels) = Unix.open_process_full cmd env in - Unix.set_nonblock(Unix.descr_of_in_channel ic); - Unix.set_nonblock(Unix.descr_of_out_channel oc); - Unix.set_nonblock(Unix.descr_of_in_channel ec); - channels - -(*** Time *) - -let sleep secs = - Thread.delay (float secs) - -(*** Sockets *) - -let socket dom typ proto = - let s = Unix.socket dom typ proto in - Unix.set_nonblock s; - s - -let socketpair dom typ proto = - let (s1, s2 as spair) = Unix.socketpair dom typ proto in - Unix.set_nonblock s1; Unix.set_nonblock s2; - spair - -let rec accept req = - Thread.wait_read req; - try - let (s, caller as result) = Unix.accept req in - Unix.set_nonblock s; - result - with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> accept req - -let connect s addr = - try - Unix.connect s addr - with Unix_error((EINPROGRESS | EWOULDBLOCK | EAGAIN), _, _) -> - Thread.wait_write s; - (* Check if it really worked *) - ignore(Unix.getpeername s) - -let rec recv fd buf ofs len flags = - try - Unix.recv fd buf ofs len flags - with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> - Thread.wait_read fd; recv fd buf ofs len flags - -let rec recvfrom fd buf ofs len flags = - try - Unix.recvfrom fd buf ofs len flags - with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> - Thread.wait_read fd; - recvfrom fd buf ofs len flags - -let rec send fd buf ofs len flags = - try - Unix.send fd buf ofs len flags - with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> - Thread.wait_write fd; - send fd buf ofs len flags - -let rec sendto fd buf ofs len flags addr = - try - Unix.sendto fd buf ofs len flags addr - with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> - Thread.wait_write fd; - sendto fd buf ofs len flags addr - -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 - try - connect sock sockaddr; - (in_channel_of_descr sock, out_channel_of_descr sock) - with exn -> - close sock; raise exn - -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; - exit 0 - | id -> close s; ignore(waitpid [] id) (* Reclaim the son *) - done - diff --git a/otherlibs/threads/threadUnix.mli b/otherlibs/threads/threadUnix.mli index aba8ec389..7d816e9fc 100644 --- a/otherlibs/threads/threadUnix.mli +++ b/otherlibs/threads/threadUnix.mli @@ -14,11 +14,11 @@ (* Module [ThreadUnix]: thread-compatible system calls *) -(* This module reimplements some of the functions from [Unix] - so that they only block the calling thread, not all threads - in the program, if they cannot complete immediately. - See the documentation of the [Unix] module for more - precise descriptions of the functions below. *) +(* This module is deprecated: its functionality has been merged back into + the [Unix] module. Threaded programs can now call the functions + from module [Unix] directly, and still get the correct behavior + (block the calling thread, if required, but do not block all threads + in the process). *) (*** Process handling *) @@ -85,5 +85,5 @@ val sendto : Unix.file_descr -> buf:string -> pos:int -> len:int -> mode:Unix.msg_flag list -> addr:Unix.sockaddr -> int val open_connection : Unix.sockaddr -> in_channel * out_channel val establish_server : - (in_channel -> out_channel -> 'a) -> + (in_channel -> out_channel -> unit) -> addr:Unix.sockaddr -> unit diff --git a/otherlibs/threads/unix.ml b/otherlibs/threads/unix.ml new file mode 100644 index 000000000..b53c76b59 --- /dev/null +++ b/otherlibs/threads/unix.ml @@ -0,0 +1,846 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +(* An alternate implementation of the Unix module from ../unix + which is safe in conjunction with bytecode threads. *) + +(* Type definitions that matter for thread operations *) + +type file_descr = int + +type process_status = + WEXITED of int + | WSIGNALED of int + | WSTOPPED of int + +(* We can't call functions from Thread because of type circularities, + so we redefine here the functions that we need *) + +type resumption_status = + Resumed_wakeup + | Resumed_delay + | Resumed_join + | Resumed_io + | Resumed_select of file_descr list * file_descr list * file_descr list + | Resumed_wait of int * process_status + +external thread_wait_read : file_descr -> unit = "thread_wait_read" +external thread_wait_write : file_descr -> unit = "thread_wait_write" +external thread_select : + file_descr list * file_descr list * file_descr list * float + -> resumption_status + = "thread_select" +external thread_wait_pid : int -> resumption_status = "thread_wait_pid" +external thread_delay : float -> unit = "thread_delay" + +let wait_read fd = thread_wait_read fd +let wait_write fd = thread_wait_write fd +let select_aux arg = thread_select arg +let wait_pid_aux pid = thread_wait_pid pid +let delay duration = thread_delay duration + +(* Back to the Unix module *) + +type error = + E2BIG + | EACCES + | EAGAIN + | EBADF + | EBUSY + | ECHILD + | EDEADLK + | EDOM + | EEXIST + | EFAULT + | EFBIG + | EINTR + | EINVAL + | EIO + | EISDIR + | EMFILE + | EMLINK + | ENAMETOOLONG + | ENFILE + | ENODEV + | ENOENT + | ENOEXEC + | ENOLCK + | ENOMEM + | ENOSPC + | ENOSYS + | ENOTDIR + | ENOTEMPTY + | ENOTTY + | ENXIO + | EPERM + | EPIPE + | ERANGE + | EROFS + | ESPIPE + | ESRCH + | EXDEV + | 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 + | EHOSTDOWN + | EHOSTUNREACH + | ELOOP + | EUNKNOWNERR of int + +exception Unix_error of error * string * string + +let _ = Callback.register_exception "Unix.Unix_error" + (Unix_error(E2BIG, "", "")) + +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" +external getenv: string -> string = "sys_getenv" +external putenv: string -> string -> unit = "unix_putenv" + +type interval_timer = + ITIMER_REAL + | ITIMER_VIRTUAL + | ITIMER_PROF + +type interval_timer_status = + { it_interval: float; (* Period *) + it_value: float } (* Current value of the timer *) + +external getitimer: interval_timer -> interval_timer_status = "unix_getitimer" +external setitimer: + interval_timer -> interval_timer_status -> interval_timer_status + = "unix_setitimer" + +type wait_flag = + WNOHANG + | WUNTRACED + +external _execv : string -> string array -> 'a = "unix_execv" +external _execve : string -> string array -> string array -> 'a = "unix_execve" +external _execvp : string -> string array -> 'a = "unix_execvp" +external _execvpe : string -> string array -> string array -> 'a = "unix_execvpe" + +(* Disable the timer interrupt before doing exec, because some OS + keep sending timer interrupts to the exec'ed code. *) + +let do_exec fn = + let oldtimer = + setitimer ITIMER_VIRTUAL {it_interval = 0.0; it_value = 0.0} in + try + fn () + with Unix_error(_,_,_) as exn -> + ignore(setitimer ITIMER_VIRTUAL oldtimer); + raise exn + +let execv proc args = + do_exec (fun () -> _execv proc args) + +let execve proc args env = + do_exec (fun () -> _execve proc args env) + +let execvp proc args = + do_exec (fun () -> _execvp proc args) + +let execvpe proc args = + do_exec (fun () -> _execvpe proc args) + +external fork : unit -> int = "unix_fork" +external _waitpid : wait_flag list -> int -> int * process_status = "unix_waitpid" + +let wait_pid pid = + match wait_pid_aux pid with + Resumed_wait(pid, status) -> (pid, status) + | _ -> invalid_arg "Thread.wait_pid" + +let wait () = wait_pid (-1) + +let waitpid flags pid = + if List.mem WNOHANG flags + then _waitpid flags pid + else wait_pid pid + +external getpid : unit -> int = "unix_getpid" +external getppid : unit -> int = "unix_getppid" +external nice : int -> int = "unix_nice" + +let stdin = 0 +let stdout = 1 +let stderr = 2 + +type open_flag = + O_RDONLY + | O_WRONLY + | O_RDWR + | O_NONBLOCK + | 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 unsafe_read : file_descr -> string -> int -> int -> int = "unix_read" +external unsafe_write : file_descr -> string -> int -> int -> int = "unix_write" + +let rec read fd buf ofs len = + try + if len < 0 or ofs + len > String.length buf + then invalid_arg "Unix.read" + else unsafe_read fd buf ofs len + with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> + wait_read fd; read fd buf ofs len + +let rec write fd buf ofs len = + try + if len < 0 or ofs + len > String.length buf + then invalid_arg "Unix.write" + else unsafe_write fd buf ofs len + with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> + wait_write fd; write fd buf ofs len + +external in_channel_of_descr : file_descr -> in_channel + = "caml_open_descriptor" +external out_channel_of_descr : file_descr -> out_channel + = "caml_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 : float; + st_mtime : float; + st_ctime : float } + +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 dup : file_descr -> file_descr = "unix_dup" +external dup2 : file_descr -> file_descr -> unit = "unix_dup2" +external set_nonblock : file_descr -> unit = "unix_set_nonblock" +external clear_nonblock : file_descr -> unit = "unix_clear_nonblock" +external set_close_on_exec : file_descr -> unit = "unix_set_close_on_exec" +external clear_close_on_exec : file_descr -> unit = "unix_clear_close_on_exec" + +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" +external chroot : string -> unit = "unix_chroot" + +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" + +let pipe() = + let (out_fd, in_fd as fd_pair) = _pipe() in + set_nonblock in_fd; + set_nonblock out_fd; + fd_pair + +external symlink : string -> string -> unit = "unix_symlink" +external readlink : string -> string = "unix_readlink" +external mkfifo : string -> file_perm -> unit = "unix_mkfifo" + +let select readfds writefds exceptfds delay = + match select_aux (readfds, writefds, exceptfds, delay) with + Resumed_select(r, w, e) -> (r, w, e) + | _ -> ([], [], []) + +type lock_command = + F_ULOCK + | F_LOCK + | F_TLOCK + | F_TEST + | F_RLOCK + | F_TRLOCK + +external lockf : file_descr -> lock_command -> int -> unit = "unix_lockf" +external kill : int -> int -> unit = "unix_kill" +type sigprocmask_command = SIG_SETMASK | SIG_BLOCK | SIG_UNBLOCK +external sigprocmask: sigprocmask_command -> int list -> int list + = "unix_sigprocmask" +external sigpending: unit -> int list = "unix_sigpending" +external sigsuspend: int list -> unit = "unix_sigsuspend" + +let pause() = + let sigs = sigprocmask SIG_BLOCK [] in sigsuspend sigs + +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 -> float = "unix_time" +external gettimeofday : unit -> float = "unix_gettimeofday" +external gmtime : float -> tm = "unix_gmtime" +external localtime : float -> tm = "unix_localtime" +external mktime : tm -> float * tm = "unix_mktime" +external alarm : int -> int = "unix_alarm" + +let sleep secs = delay (float secs) + +external times : unit -> process_times = "unix_times" +external utimes : string -> float -> float -> 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" + +let inet_addr_any = inet_addr_of_string "0.0.0.0" + +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 + +type socket_option = + SO_DEBUG + | SO_BROADCAST + | SO_REUSEADDR + | SO_KEEPALIVE + | SO_DONTROUTE + | SO_OOBINLINE + +external _socket : socket_domain -> socket_type -> int -> file_descr + = "unix_socket" +external _socketpair : + socket_domain -> socket_type -> int -> file_descr * file_descr + = "unix_socketpair" + +let socket dom typ proto = + let s = _socket dom typ proto in + set_nonblock s; + s + +let socketpair dom typ proto = + let (s1, s2 as spair) = _socketpair dom typ proto in + set_nonblock s1; set_nonblock s2; + spair + +external _accept : file_descr -> file_descr * sockaddr = "unix_accept" + +let rec accept req = + wait_read req; + try + let (s, caller as result) = _accept req in + set_nonblock s; + result + with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> accept req + +external bind : file_descr -> sockaddr -> unit = "unix_bind" +external listen : file_descr -> int -> unit = "unix_listen" +external shutdown : file_descr -> shutdown_command -> unit = "unix_shutdown" +external getsockname : file_descr -> sockaddr = "unix_getsockname" +external getpeername : file_descr -> sockaddr = "unix_getpeername" +external getsockopt : file_descr -> socket_option -> bool = "unix_getsockopt" +external setsockopt : file_descr -> socket_option -> bool -> unit + = "unix_setsockopt" + +external _connect : file_descr -> sockaddr -> unit = "unix_connect" + +let connect s addr = + try + _connect s addr + with Unix_error((EINPROGRESS | EWOULDBLOCK | EAGAIN), _, _) -> + wait_write s; + (* Check if it really worked *) + ignore(getpeername s) + +external unsafe_recv : + file_descr -> string -> int -> int -> msg_flag list -> int + = "unix_recv" +external unsafe_recvfrom : + file_descr -> string -> int -> int -> msg_flag list -> int * sockaddr + = "unix_recvfrom" +external unsafe_send : + file_descr -> string -> int -> int -> msg_flag list -> int + = "unix_send" +external unsafe_sendto : + file_descr -> string -> int -> int -> msg_flag list -> sockaddr -> int + = "unix_sendto" "unix_sendto_native" + +let rec recv fd buf ofs len flags = + try + if len < 0 or ofs + len > String.length buf + then invalid_arg "Unix.recv" + else unsafe_recv fd buf ofs len flags + with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> + wait_read fd; recv fd buf ofs len flags + +let rec recvfrom fd buf ofs len flags = + try + if len < 0 or ofs + len > String.length buf + then invalid_arg "Unix.recvfrom" + else unsafe_recvfrom fd buf ofs len flags + with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> + wait_read fd; + recvfrom fd buf ofs len flags + +let rec send fd buf ofs len flags = + try + if len < 0 or ofs + len > String.length buf + then invalid_arg "Unix.send" + else unsafe_send fd buf ofs len flags + with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> + wait_write fd; + send fd buf ofs len flags + +let rec sendto fd buf ofs len flags addr = + try + if len < 0 or ofs + len > String.length buf + then invalid_arg "Unix.sendto" + else unsafe_sendto fd buf ofs len flags addr + with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> + wait_write fd; + sendto fd buf ofs len flags addr + +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_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" + +external setsid : unit -> int = "unix_setsid" + +(* High-level process management (system, popen) *) + +let system cmd = + match fork() with + 0 -> begin try + execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |] + with _ -> + exit 127 + end + | id -> snd(waitpid [] id) + +let rec safe_dup fd = + let new_fd = dup fd in + if new_fd >= 3 then + new_fd + else begin + let res = safe_dup fd in + close new_fd; + res + end + +let safe_close fd = + try close fd with Unix_error(_,_,_) -> () + +let perform_redirections new_stdin new_stdout new_stderr = + let newnewstdin = safe_dup new_stdin in + let newnewstdout = safe_dup new_stdout in + let newnewstderr = safe_dup new_stderr in + safe_close new_stdin; + safe_close new_stdout; + safe_close new_stderr; + dup2 newnewstdin stdin; close newnewstdin; + dup2 newnewstdout stdout; close newnewstdout; + dup2 newnewstderr stderr; close newnewstderr + +let create_process cmd args new_stdin new_stdout new_stderr = + match fork() with + 0 -> + begin try + perform_redirections new_stdin new_stdout new_stderr; + execvp cmd args + with _ -> + exit 127 + end + | id -> id + +let create_process_env cmd args env new_stdin new_stdout new_stderr = + match fork() with + 0 -> + begin try + perform_redirections new_stdin new_stdout new_stderr; + execvpe cmd args env + with _ -> + exit 127 + end + | id -> id + +type popen_process = + Process of in_channel * out_channel + | Process_in of in_channel + | Process_out of out_channel + | Process_full of in_channel * out_channel * in_channel + +let popen_processes = (Hashtbl.create 7 : (popen_process, int) Hashtbl.t) + +let open_proc cmd proc input output toclose = + 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; + List.iter close toclose; + 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 [in_read]; + close 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 [out_write]; + close out_read; + 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 + [in_read; out_write]; + close out_read; + close in_write; + (inchan, outchan) + +let open_proc_full cmd env proc input output error toclose = + match fork() with + 0 -> dup2 input stdin; close input; + dup2 output stdout; close output; + dup2 error stderr; close error; + List.iter close toclose; + execve "/bin/sh" [| "/bin/sh"; "-c"; cmd |] env; + exit 127 + | id -> Hashtbl.add popen_processes proc id + +let open_process_full cmd env = + let (in_read, in_write) = pipe() in + let (out_read, out_write) = pipe() in + let (err_read, err_write) = pipe() in + let inchan = in_channel_of_descr in_read in + let outchan = out_channel_of_descr out_write in + let errchan = in_channel_of_descr err_read in + open_proc_full cmd env (Process_full(inchan, outchan, errchan)) + out_read in_write err_write [in_read; out_write; err_read]; + close out_read; + close in_write; + close err_write; + (inchan, outchan, errchan) + +let find_proc_id fun_name proc = + try + let pid = Hashtbl.find popen_processes proc in + Hashtbl.remove popen_processes proc; + pid + with Not_found -> + raise(Unix_error(EBADF, fun_name, "")) + +let close_process_in inchan = + let pid = find_proc_id "close_process_in" (Process_in inchan) in + close_in inchan; + snd(waitpid [] pid) + +let close_process_out outchan = + let pid = find_proc_id "close_process_out" (Process_out outchan) in + close_out outchan; + snd(waitpid [] pid) + +let close_process (inchan, outchan) = + let pid = find_proc_id "close_process" (Process(inchan, outchan)) in + close_in inchan; close_out outchan; + snd(waitpid [] pid) + +let close_process_full (inchan, outchan, errchan) = + let pid = + find_proc_id "close_process_full" + (Process_full(inchan, outchan, errchan)) in + close_in inchan; close_out outchan; close_in errchan; + snd(waitpid [] pid) + +(* 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 + try + connect sock sockaddr; + (in_channel_of_descr sock, out_channel_of_descr sock) + with exn -> + close sock; raise exn + +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 + setsockopt sock SO_REUSEADDR true; + 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; ignore(waitpid [] id) (* Reclaim the son *) + done +