Ajout de create_process, pour compatibilite avec l'implementation Win32.

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@929 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

2 files changed, 98 insertions, 36 deletions

diff --git a/otherlibs/unix/unix.ml b/otherlibs/unix/unix.ml
index b2d7d124b..1b61cdbba 100644
--- a/otherlibs/unix/unix.ml
+++ b/otherlibs/unix/unix.ml
@@ -133,6 +133,11 @@ let stdin = 0
 let stdout = 1
 let stderr = 2
 
+let max_opened_descr = ref 2
+
+let record_descr fd =
+  if fd > !max_opened_descr then max_opened_descr := fd
+
 type open_flag =
     O_RDONLY
   | O_WRONLY
@@ -146,8 +151,14 @@ type open_flag =
 type file_perm = int
 
 
-external openfile : string -> open_flag list -> file_perm -> file_descr
+external sys_openfile : string -> open_flag list -> file_perm -> file_descr
            = "unix_open"
+
+let openfile name flags perm =
+  let fd = sys_openfile name flags perm in
+  record_descr fd;
+  fd
+
 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"
@@ -218,7 +229,11 @@ 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 sys_dup : file_descr -> file_descr = "unix_dup"
+
+let dup fd =
+  let newfd = sys_dup fd in record_descr newfd; newfd
+
 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"
@@ -236,7 +251,13 @@ external opendir : string -> dir_handle = "unix_opendir"
 external readdir : dir_handle -> string = "unix_readdir"
 external rewinddir : dir_handle -> unit = "unix_rewinddir"
 external closedir : dir_handle -> unit = "unix_closedir"
-external pipe : unit -> file_descr * file_descr = "unix_pipe"
+
+external sys_pipe : unit -> file_descr * file_descr = "unix_pipe"
+
+let pipe () =
+  let (fd1, fd2 as fdpair) = sys_pipe() in
+  record_descr fd1; record_descr fd2; fdpair
+
 external symlink : string -> string -> unit = "unix_symlink"
 external readlink : string -> string = "unix_readlink"
 external mkfifo : string -> file_perm -> unit = "unix_mkfifo"
@@ -369,12 +390,25 @@ type socket_option =
   | SO_DONTROUTE
   | SO_OOBINLINE
 
-external socket : socket_domain -> socket_type -> int -> file_descr
+external sys_socket : socket_domain -> socket_type -> int -> file_descr
                                   = "unix_socket"
-external socketpair :
+let socket domain typ proto =
+  let fd = sys_socket domain typ proto in
+  record_descr fd; fd
+
+external sys_socketpair :
         socket_domain -> socket_type -> int -> file_descr * file_descr
                                   = "unix_socketpair"
-external accept : file_descr -> file_descr * sockaddr = "unix_accept"
+let socketpair domain typ proto =
+  let (fd1, fd2 as fdpair) = sys_socketpair domain typ proto in
+  record_descr fd1; record_descr fd2; fdpair
+
+external sys_accept : file_descr -> file_descr * sockaddr = "unix_accept"
+
+let accept fd =
+  let (newfd, addr as result) = sys_accept fd in
+  record_descr newfd; result
+
 external bind : file_descr -> sockaddr -> unit = "unix_bind"
 external connect : file_descr -> sockaddr -> unit = "unix_connect"
 external listen : file_descr -> int -> unit = "unix_listen"
@@ -503,11 +537,27 @@ external tcflow: file_descr -> flow_action -> unit = "unix_tcflow"
 
 (* High-level process management (system, popen) *)
 
+let closeall () =
+  for i = 3 to !max_opened_descr do close i done
+
 let system cmd =
   match fork() with
-     0 -> execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]; exit 127
+     0 -> closeall();
+          execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |];
+          exit 127
   | id -> snd(waitpid [] id)
 
+let create_process cmd args new_stdin new_stdout new_stderr =
+  match fork() with
+    0 ->
+      if new_stdin  <> stdin  then dup2 new_stdin stdin;
+      if new_stdout <> stdout then dup2 new_stdout stdout;
+      if new_stderr <> stderr then dup2 new_stderr stderr;
+      closeall();
+      execvp cmd args;
+      exit 127
+  | id -> id
+
 type popen_process =
     Process of in_channel * out_channel
   | Process_in of in_channel
@@ -515,26 +565,22 @@ type popen_process =
 
 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_proc cmd proc input output =
+  let pid =
+    create_process "/bin/sh" [| "/bin/sh"; "-c"; cmd |] input output stderr in
+  Hashtbl.add popen_processes proc pid
 
 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];
+  open_proc cmd (Process_in inchan) stdin in_write;
   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];
+  open_proc cmd (Process_out outchan) out_read stdout;
   close out_read;
   outchan
 
@@ -543,8 +589,9 @@ let open_process cmd =
   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];
+  open_proc cmd (Process(inchan, outchan)) out_read in_write;
+  close in_write;
+  close out_read;
   (inchan, outchan)
 
 let find_proc_id fun_name proc =
diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli
index 01875b497..c0fe064b6 100644
--- a/otherlibs/unix/unix.mli
+++ b/otherlibs/unix/unix.mli
@@ -201,8 +201,7 @@ type open_flag =
 type file_perm = int
         (* The type of file access rights. *)
 
-external openfile : string -> open_flag list -> file_perm -> file_descr
-           = "unix_open"
+val openfile : string -> open_flag list -> file_perm -> file_descr
         (* Open the named file with the given flags. Third argument is
            the permissions to give to the file if it is created. Return
            a file descriptor on the named file. *)
@@ -327,8 +326,9 @@ external access : string -> access_permission list -> unit = "unix_access"
 
 (*** Operations on file descriptors *)
 
-external dup : file_descr -> file_descr = "unix_dup"
-        (* Duplicate a descriptor. *)
+val dup : file_descr -> file_descr
+        (* Return a new file descriptor referencing the same file as
+           the given descriptor. *)
 external dup2 : file_descr -> file_descr -> unit = "unix_dup2"
         (* [dup2 fd1 fd2] duplicates [fd1] to [fd2], closing [fd2] if already
            opened. *)
@@ -378,11 +378,35 @@ external closedir : dir_handle -> unit = "unix_closedir"
 
 (*** Pipes and redirections *)
 
-external pipe : unit -> file_descr * file_descr = "unix_pipe"
+val pipe : unit -> file_descr * file_descr
         (* Create a pipe. The first component of the result is opened
            for reading, that's the exit to the pipe. The second component is
            opened for writing, that's the entrance to the pipe. *) 
 
+external mkfifo : string -> file_perm -> unit = "unix_mkfifo"
+        (* Create a named pipe with the given permissions. *)
+
+
+(*** High-level process and redirection management *)
+
+val create_process :
+  string -> string array -> file_descr -> file_descr -> file_descr -> int
+        (* [create_process prog args new_stdin new_stdout new_stderr]
+           forks a new process that executes the program
+           in file [prog], with arguments [args]. The pid of the new 
+           process is returned immediately; the new process executes
+           concurrently with the current process.
+           The standard input and outputs of the new process are connected
+           to the descriptors [new_stdin], [new_stdout] and [new_stderr].
+           Passing e.g. [stdout] for [new_stdout] prevents the redirection
+           and causes the new process to have the same standard output
+           as the current process.
+           The executable file [prog] is searched in the path.
+           The new process has the same environment as the current process.
+           All file descriptors of the current process are closed in the
+           new process, except those redirected to standard input and
+           outputs. *)
+
 val open_process_in: string -> in_channel
 val open_process_out: string -> out_channel
 val open_process: string -> in_channel * out_channel
@@ -400,7 +424,6 @@ val close_process: in_channel * out_channel -> process_status
            and [open_process], respectively, wait for the associated
            command to terminate, and return its termination status. *)
 
-
 (*** Symbolic links *)
 
 external symlink : string -> string -> unit = "unix_symlink"
@@ -410,12 +433,6 @@ external readlink : string -> string = "unix_readlink"
         (* Read the contents of a link. *)
 
 
-(*** Named pipes *)
-
-external mkfifo : string -> file_perm -> unit = "unix_mkfifo"
-        (* Create a named pipe with the given permissions. *)
-
-
 (*** Special files *)
 
 external ioctl_int : file_descr -> int -> int -> int = "unix_ioctl_int"
@@ -651,16 +668,14 @@ type sockaddr =
            domain; [addr] is the Internet address of the machine, and
            [port] is the port number. *)
 
-external socket : socket_domain -> socket_type -> int -> file_descr
-                                  = "unix_socket"
+val socket : socket_domain -> socket_type -> int -> file_descr
         (* Create a new socket in the given domain, and with the
            given kind. The third argument is the protocol type; 0 selects
            the default protocol for that kind of sockets. *)
-external socketpair :
+val socketpair :
         socket_domain -> socket_type -> int -> file_descr * file_descr
-                                  = "unix_socketpair"
         (* Create a pair of unnamed sockets, connected together. *)
-external accept : file_descr -> file_descr * sockaddr = "unix_accept"
+val accept : file_descr -> file_descr * sockaddr
         (* Accept connections on the given socket. The returned descriptor
            is a socket connected to the client; the returned address is
            the address of the connecting client. *)