path: root/otherlibs/threads/unix.ml

(***********************************************************************)
(*                                                                     *)
(*                           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, with    *)
(*  the special exception on linking described in file ../../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_initialize : unit -> unit = "thread_initialize"
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

(* Make sure that threads are initialized (PR#1516). *)

let _ = thread_initialize()

(* 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
  | EOVERFLOW
  | 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

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
  | O_NOCTTY
  | O_DSYNC
  | O_SYNC
  | O_RSYNC

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 ofs < 0 || len < 0 || ofs > String.length buf - len
    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 ofs < 0 || len < 0 || ofs > String.length buf - len
    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_in"
external out_channel_of_descr : file_descr -> out_channel
                              = "caml_open_descriptor_out"
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"

module LargeFile =
  struct
    external lseek : file_descr -> int64 -> seek_command -> int64 = "unix_lseek_64"
    external truncate : string -> int64 -> unit = "unix_truncate_64"
    external ftruncate : file_descr -> int64 -> unit = "unix_ftruncate_64"
    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 : int64;
        st_atime : float;
        st_mtime : float;
        st_ctime : float;
      }
    external stat : string -> stats = "unix_stat_64"
    external lstat : string -> stats = "unix_lstat_64"
    external fstat : file_descr -> stats = "unix_fstat_64"
  end

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 _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.
   Also restore blocking mode on stdin, stdout and stderr,
   since this is what most programs expect! *)

let safe_clear_nonblock fd =
  try clear_nonblock fd with Unix_error(_,_,_) -> ()
let safe_set_nonblock fd =
  try set_nonblock fd with Unix_error(_,_,_) -> ()

let do_exec fn =
  let oldtimer =
    setitimer ITIMER_VIRTUAL {it_interval = 0.0; it_value = 0.0} in
  safe_clear_nonblock stdin;
  safe_clear_nonblock stdout;
  safe_clear_nonblock stderr;
  try
    fn ()
  with Unix_error(_,_,_) as exn ->
    ignore(setitimer ITIMER_VIRTUAL oldtimer);
    safe_set_nonblock stdin;
    safe_set_nonblock stdout;
    safe_set_nonblock stderr;
    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"

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_bool_option =
    SO_DEBUG
  | SO_BROADCAST
  | SO_REUSEADDR
  | SO_KEEPALIVE
  | SO_DONTROUTE
  | SO_OOBINLINE
  | SO_ACCEPTCONN

type socket_int_option =
    SO_SNDBUF
  | SO_RCVBUF
  | SO_ERROR
  | SO_TYPE
  | SO_RCVLOWAT
  | SO_SNDLOWAT

type socket_optint_option = SO_LINGER

type socket_float_option =
    SO_RCVTIMEO
  | SO_SNDTIMEO

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_bool_option -> bool
                                          = "unix_getsockopt_bool"
external setsockopt : file_descr -> socket_bool_option -> bool -> unit
                                          = "unix_setsockopt_bool"
external getsockopt_int : file_descr -> socket_int_option -> int
                                          = "unix_getsockopt_int"
external setsockopt_int : file_descr -> socket_int_option -> int -> unit
                                          = "unix_setsockopt_int"
external getsockopt_optint : file_descr -> socket_optint_option -> int option
                                          = "unix_getsockopt_optint"
external setsockopt_optint : file_descr -> socket_optint_option -> int option -> unit
                                          = "unix_setsockopt_optint"
external getsockopt_float : file_descr -> socket_float_option -> float
                                          = "unix_getsockopt_float"
external setsockopt_float : file_descr -> socket_float_option -> float -> unit
                                          = "unix_setsockopt_float"

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 ofs < 0 || len < 0 || ofs > String.length buf - len
    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 ofs < 0 || len < 0 || ofs > String.length buf - len
    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 ofs < 0 || len < 0 || ofs > String.length buf - len
    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 ofs < 0 || len < 0 || ofs > String.length buf - len
    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;
  begin try close_out outchan with Sys_error _ -> () end;
  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;
  begin try close_out outchan with Sys_error _ -> () end;
  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 5;
  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_out outchan;
            (* The file descriptor was already closed by close_out.
               close_in inchan;
            *)
            exit 0
    | id -> close s; ignore(waitpid [] id) (* Reclaim the son *)
  done