Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Rendu Unix thread-safe; ThreadUnix est deprecated 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@3542 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Xavier Leroy 2001-06-25 08:04:00 +00:00
parent a1692e5d36
commit 6919159c42
9 changed files with 911 additions and 198 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
otherlibs/threads/Makefile
View File

@ -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) $<

4
otherlibs/threads/Tests/close.ml
View File

@ -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 ()

4
otherlibs/threads/Tests/testio.ml
View File

@ -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()

1
otherlibs/threads/Tests/testsocket.ml
View File

@ -1,5 +1,4 @@
open Unix
open ThreadUnix
let engine number address =
print_int number; print_string "> connecting"; print_newline();

8
otherlibs/threads/Tests/token2.ml
View File

@ -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()

8
otherlibs/threads/Tests/torture.ml
View File

@ -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()

200
otherlibs/threads/threadUnix.ml
View File

@ -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

12
otherlibs/threads/threadUnix.mli
View File

@ -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

846
otherlibs/threads/unix.ml Normal file
View File

@ -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