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

Unix library: better API for "close-on-exec" over file descriptors (#650)

master
Xavier Leroy 2017-02-13 18:05:19 +01:00 committed by Damien Doligez
parent 46676cde6e
commit ab4e3beab1
39 changed files with 1020 additions and 355 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
Changes
View File

@ -133,6 +133,16 @@ Next version (4.05.0):
### Other libraries:
- GPR#650: in the Unix library, add `?cloexec:bool` optional arguments to
functions that create file descriptors (`dup`, `dup2`, `pipe`, `socket`,
`socketpair`, `accept`). Implement these optional arguments in the
most atomic manner provided by the operating system to set (or clear)
the close-on-exec flag at the same time the file descriptor is created,
reducing the risk of race conditions with `exec` or `create_process`
calls running in other threads, and improving security. Also: add a
`O_KEEPEXEC` flag for `openfile` by symmetry with `O_CLOEXEC`.
(Xavier Leroy)
- MPR#7339, GPR#787: Support the '0 dimension' case for bigarrays
(see Bigarray documentation)
(Laurent Mazare,

15
configure vendored
View File

@ -1496,6 +1496,21 @@ if sh ./hasgot nice; then
echo "#define HAS_NICE" >> s.h
fi
if sh ./hasgot dup3; then
inf "dup3() found"
echo "#define HAS_DUP3" >> s.h
fi
if sh ./hasgot pipe2; then
inf "pipe2() found"
echo "#define HAS_PIPE2" >> s.h
fi
if sh ./hasgot accept4; then
inf "accept4() found"
echo "#define HAS_ACCEPT4" >> s.h
fi
# Determine if the debugger is supported
if test -n "$with_debugger"; then

10
otherlibs/systhreads/threadUnix.mli
View File

@ -64,7 +64,7 @@ val select :
(** {6 Pipes and redirections} *)
val pipe : unit -> Unix.file_descr * Unix.file_descr
val pipe : ?cloexec:bool -> unit -> Unix.file_descr * Unix.file_descr
val open_process_in: string -> in_channel
val open_process_out: string -> out_channel
val open_process: string -> in_channel * out_channel
@ -75,9 +75,11 @@ val sleep : int -> unit
(** {6 Sockets} *)
val socket : Unix.socket_domain ->
Unix.socket_type -> int -> Unix.file_descr
val accept : Unix.file_descr -> Unix.file_descr * Unix.sockaddr
val socket :
?cloexec:bool -> Unix.socket_domain -> Unix.socket_type -> int ->
Unix.file_descr
val accept :
?cloexec:bool -> Unix.file_descr -> Unix.file_descr * Unix.sockaddr
val connect : Unix.file_descr -> Unix.sockaddr -> unit
val recv : Unix.file_descr -> bytes ->
int -> int -> Unix.msg_flag list -> int

11
otherlibs/threads/threadUnix.mli
View File

@ -62,7 +62,7 @@ val select :
(** {6 Pipes and redirections} *)
val pipe : unit -> Unix.file_descr * Unix.file_descr
val pipe : ?cloexec:bool -> unit -> Unix.file_descr * Unix.file_descr
val open_process_in : string -> in_channel
val open_process_out : string -> out_channel
val open_process : string -> in_channel * out_channel
@ -75,11 +75,14 @@ val sleep : int -> unit
(** {6 Sockets} *)
val socket : Unix.socket_domain -> Unix.socket_type -> int -> Unix.file_descr
val socket :
?cloexec:bool -> Unix.socket_domain -> Unix.socket_type -> int ->
Unix.file_descr
val socketpair :
Unix.socket_domain -> Unix.socket_type -> int ->
?cloexec:bool -> Unix.socket_domain -> Unix.socket_type -> int ->
Unix.file_descr * Unix.file_descr
val accept : Unix.file_descr -> Unix.file_descr * Unix.sockaddr
val accept :
?cloexec:bool -> Unix.file_descr -> Unix.file_descr * Unix.sockaddr
val connect : Unix.file_descr -> Unix.sockaddr -> unit
val recv :
Unix.file_descr -> bytes -> int -> int -> Unix.msg_flag list -> int

246
otherlibs/threads/unix.ml
View File

@ -199,6 +199,7 @@ type open_flag =
| O_RSYNC
| O_SHARE_DELETE
| O_CLOEXEC
| O_KEEPEXEC
type file_perm = int
@ -345,8 +346,9 @@ 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 dup : ?cloexec: bool -> file_descr -> file_descr = "unix_dup"
external dup2 :
?cloexec: bool -> 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"
@ -365,10 +367,11 @@ 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 _pipe :
?cloexec: bool -> unit -> file_descr * file_descr = "unix_pipe"
let pipe() =
let (out_fd, in_fd as fd_pair) = _pipe() in
let pipe ?cloexec () =
let (out_fd, in_fd as fd_pair) = _pipe ?cloexec () in
set_nonblock in_fd;
set_nonblock out_fd;
fd_pair
@ -573,28 +576,31 @@ type msg_flag =
| MSG_DONTROUTE
| MSG_PEEK
external _socket : socket_domain -> socket_type -> int -> file_descr
= "unix_socket"
external _socket :
?cloexec: bool -> socket_domain -> socket_type -> int -> file_descr
= "unix_socket"
external _socketpair :
socket_domain -> socket_type -> int -> file_descr * file_descr
= "unix_socketpair"
?cloexec: bool -> socket_domain -> socket_type -> int ->
file_descr * file_descr
= "unix_socketpair"
let socket dom typ proto =
let s = _socket dom typ proto in
let socket ?cloexec dom typ proto =
let s = _socket ?cloexec dom typ proto in
set_nonblock s;
s
let socketpair dom typ proto =
let (s1, s2 as spair) = _socketpair dom typ proto in
let socketpair ?cloexec dom typ proto =
let (s1, s2 as spair) = _socketpair ?cloexec dom typ proto in
set_nonblock s1; set_nonblock s2;
spair
external _accept : file_descr -> file_descr * sockaddr = "unix_accept"
external _accept :
?cloexec: bool -> file_descr -> file_descr * sockaddr = "unix_accept"
let rec accept req =
let rec accept ?cloexec req =
wait_read req;
try
let (s, caller as result) = _accept req in
let (s, caller as result) = _accept ?cloexec req in
set_nonblock s;
result
with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> accept req
@ -952,6 +958,10 @@ external setsid : unit -> int = "unix_setsid"
(* High-level process management (system, popen) *)
let rec waitpid_non_intr pid =
try waitpid [] pid
with Unix_error (EINTR, _, _) -> waitpid_non_intr pid
let system cmd =
match fork() with
0 -> begin try
@ -959,31 +969,25 @@ let system cmd =
with _ ->
exit 127
end
| id -> snd(waitpid [] id)
| id -> snd(waitpid_non_intr 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;
(* Make sure [fd] is not one of the standard descriptors 0, 1, 2,
by duplicating it if needed. *)
let rec file_descr_not_standard fd =
if fd >= 3 then fd else begin
let res = file_descr_not_standard (dup fd) in
close 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 new_stdin = file_descr_not_standard new_stdin in
let new_stdout = file_descr_not_standard new_stdout in
let new_stderr = file_descr_not_standard new_stderr in
dup2 ~cloexec:false new_stdin stdin; close new_stdin;
dup2 ~cloexec:false new_stdout stdout; close new_stdout;
dup2 ~cloexec:false new_stderr stderr; close new_stderr
let create_process cmd args new_stdin new_stdout new_stderr =
match fork() with
@ -1015,65 +1019,127 @@ type popen_process =
let popen_processes = (Hashtbl.create 7 : (popen_process, int) Hashtbl.t)
let open_proc cmd proc input output toclose =
let open_proc cmd envopt proc input output error =
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;
begin try execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]
with _ -> exit 127
0 -> begin try
perform_redirections input output error;
let shell = "/bin/sh" in
let argv = [| shell; "-c"; cmd |] in
match envopt with
| Some env -> execve shell argv env
| None -> execv shell argv
with _ ->
exit 127
end
| id -> Hashtbl.add popen_processes proc id
let open_process_in cmd =
let (in_read, in_write) = pipe() in
let (in_read, in_write) = pipe ~cloexec:true () 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
try
open_proc cmd None (Process_in inchan) stdin in_write stderr;
close in_write;
inchan
with e ->
close_in inchan;
close in_write;
raise e
let open_process_out cmd =
let (out_read, out_write) = pipe() in
let (out_read, out_write) = pipe ~cloexec:true () 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
try
open_proc cmd None (Process_out outchan) out_read stdout stderr;
close out_read;
outchan
with e ->
close_out outchan;
close out_read;
raise e
let open_process cmd =
let (in_read, in_write) = pipe() in
let (out_read, out_write) = pipe() in
let (in_read, in_write) = pipe ~cloexec:true () 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;
begin try execve "/bin/sh" [| "/bin/sh"; "-c"; cmd |] env
with _ -> exit 127
end
| id -> Hashtbl.add popen_processes proc id
try
let (out_read, out_write) = pipe ~cloexec:true () in
let outchan = out_channel_of_descr out_write in
try
open_proc cmd None (Process(inchan, outchan)) out_read in_write stderr;
close out_read;
close in_write;
(inchan, outchan)
with e ->
close_out outchan;
close out_read;
raise e
with e ->
close_in inchan;
close in_write;
raise e
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 (in_read, in_write) = pipe ~cloexec:true () 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)
try
let (out_read, out_write) = pipe ~cloexec:true () in
let outchan = out_channel_of_descr out_write in
try
let (err_read, err_write) = pipe ~cloexec:true () in
let errchan = in_channel_of_descr err_read in
try
open_proc cmd (Some env) (Process_full(inchan, outchan, errchan))
out_read in_write err_write;
close out_read;
close in_write;
close err_write;
(inchan, outchan, errchan)
with e ->
close_in errchan;
close err_write;
raise e
with e ->
close_out outchan;
close out_read;
raise e
with e ->
close_in inchan;
close in_write;
raise e
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_non_intr pid)
let close_process_out outchan =
let pid = find_proc_id "close_process_out" (Process_out outchan) in
(* The application may have closed [outchan] already to signal
end-of-input to the process. *)
begin try close_out outchan with Sys_error _ -> () end;
snd(waitpid_non_intr 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_non_intr 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_non_intr pid)
let find_proc_id fun_name proc =
try
@ -1116,7 +1182,7 @@ let close_process_full (inchan, outchan, errchan) =
let open_connection sockaddr =
let sock =
socket (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
socket ~cloexec:true (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
try
connect sock sockaddr;
(in_channel_of_descr sock, out_channel_of_descr sock)
@ -1126,25 +1192,29 @@ let open_connection sockaddr =
let shutdown_connection inchan =
shutdown (descr_of_in_channel inchan) SHUTDOWN_SEND
let rec accept_non_intr s =
try accept ~cloexec:true s
with Unix_error (EINTR, _, _) -> accept_non_intr s
let establish_server server_fun sockaddr =
let sock =
socket (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
socket ~cloexec:true (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
setsockopt sock SO_REUSEADDR true;
bind sock sockaddr;
listen sock 5;
while true do
let (s, caller) = accept sock in
let (s, caller) = accept_non_intr 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 *)
close sock;
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;
*)
(* Do not close inchan nor outchan, as the server_fun could
have done it already, and we are about to exit anyway
(PR#3794) *)
exit 0
| id -> close s; ignore(waitpid [] id) (* Reclaim the son *)
| id -> close s; ignore(waitpid_non_intr id) (* Reclaim the son *)
done

14
otherlibs/unix/accept.c
View File

@ -13,6 +13,7 @@
/* */
/**************************************************************************/
#define _GNU_SOURCE
#include <caml/mlvalues.h>
#include <caml/alloc.h>
#include <caml/fail.h>
@ -24,19 +25,28 @@
#include "socketaddr.h"
CAMLprim value unix_accept(value sock)
CAMLprim value unix_accept(value cloexec, value sock)
{
int retcode;
value res;
value a;
union sock_addr_union addr;
socklen_param_type addr_len;
int clo = unix_cloexec_p(cloexec);
addr_len = sizeof(addr);
caml_enter_blocking_section();
#if defined(HAS_ACCEPT4) && defined(SOCK_CLOEXEC)
retcode = accept4(Int_val(sock), &addr.s_gen, &addr_len,
clo ? SOCK_CLOEXEC : 0);
#else
retcode = accept(Int_val(sock), &addr.s_gen, &addr_len);
#endif
caml_leave_blocking_section();
if (retcode == -1) uerror("accept", Nothing);
#if !(defined(HAS_ACCEPT4) && defined(SOCK_CLOEXEC))
if (clo) unix_set_cloexec(retcode, "accept", Nothing);
#endif
a = alloc_sockaddr(&addr, addr_len, retcode);
Begin_root (a);
res = caml_alloc_small(2, 0);
@ -48,7 +58,7 @@ CAMLprim value unix_accept(value sock)
#else
CAMLprim value unix_accept(value sock)
CAMLprim value unix_accept(value cloexec, value sock)
{ caml_invalid_argument("accept not implemented"); }
#endif

13
otherlibs/unix/dup.c
View File

@ -13,13 +13,24 @@
/* */
/**************************************************************************/
#define _GNU_SOURCE
#include <caml/mlvalues.h>
#include "unixsupport.h"
#include <fcntl.h>
CAMLprim value unix_dup(value fd)
CAMLprim value unix_dup(value cloexec, value fd)
{
int ret;
#ifdef F_DUPFD_CLOEXEC
ret = fcntl(Int_val(fd),
(unix_cloexec_p(cloexec) ? F_DUPFD_CLOEXEC : F_DUPFD),
0);
#else
ret = dup(Int_val(fd));
#endif
if (ret == -1) uerror("dup", Nothing);
#ifndef F_DUPFD_CLOEXEC
if (unix_cloexec_p(cloexec)) unix_set_cloexec(ret, "dup", Nothing);
#endif
return Val_int(ret);
}

49
otherlibs/unix/dup2.c
View File

@ -13,37 +13,32 @@
/* */
/**************************************************************************/
#define _GNU_SOURCE
#include <caml/mlvalues.h>
#include "unixsupport.h"
#include <fcntl.h>
#ifdef HAS_DUP2
CAMLprim value unix_dup2(value fd1, value fd2)
CAMLprim value unix_dup2(value cloexec, value fd1, value fd2)
{
if (dup2(Int_val(fd1), Int_val(fd2)) == -1) uerror("dup2", Nothing);
return Val_unit;
}
if (Int_val(fd2) == Int_val(fd1)) {
/* In this case, dup3 fails and dup2 does nothing. */
/* Just apply the cloexec flag to fd2, if it is given. */
if (Is_block(cloexec)) {
if (Bool_val(Field(cloexec, 0)))
unix_set_cloexec(Int_val(fd2), "dup2", Nothing);
else
unix_clear_cloexec(Int_val(fd2), "dup2", Nothing);
}
} else {
#ifdef HAS_DUP3
if (dup3(Int_val(fd1), Int_val(fd2),
unix_cloexec_p(cloexec) ? O_CLOEXEC : 0) == -1)
uerror("dup2", Nothing);
#else
static int do_dup2(int fd1, int fd2)
{
int fd;
int res;
fd = dup(fd1);
if (fd == -1) return -1;
if (fd == fd2) return 0;
res = do_dup2(fd1, fd2);
close(fd);
return res;
}
CAMLprim value unix_dup2(value fd1, value fd2)
{
close(Int_val(fd2));
if (do_dup2(Int_val(fd1), Int_val(fd2)) == -1) uerror("dup2", Nothing);
if (dup2(Int_val(fd1), Int_val(fd2)) == -1) uerror("dup2", Nothing);
if (unix_cloexec_p(cloexec))
unix_set_cloexec(Int_val(fd2), "dup2", Nothing);
#endif
}
return Val_unit;
}
#endif

24
otherlibs/unix/fcntl.c
View File

@ -45,34 +45,14 @@ CAMLprim value unix_clear_nonblock(value fd)
return Val_unit;
}
#ifdef FD_CLOEXEC
CAMLprim value unix_set_close_on_exec(value fd)
{
int retcode;
retcode = fcntl(Int_val(fd), F_GETFD, 0);
if (retcode == -1 ||
fcntl(Int_val(fd), F_SETFD, retcode | FD_CLOEXEC) == -1)
uerror("set_close_on_exec", Nothing);
unix_set_cloexec(Int_val(fd), "set_close_on_exec", Nothing);
return Val_unit;
}
CAMLprim value unix_clear_close_on_exec(value fd)
{
int retcode;
retcode = fcntl(Int_val(fd), F_GETFD, 0);
if (retcode == -1 ||
fcntl(Int_val(fd), F_SETFD, retcode & ~FD_CLOEXEC) == -1)
uerror("clear_close_on_exec", Nothing);
unix_clear_cloexec(Int_val(fd), "set_close_on_exec", Nothing);
return Val_unit;
}
#else
CAMLprim value unix_set_close_on_exec(value fd)
{ caml_invalid_argument("set_close_on_exec not implemented"); }
CAMLprim value unix_clear_close_on_exec(value fd)
{ caml_invalid_argument("clear_close_on_exec not implemented"); }
#endif

38
otherlibs/unix/open.c
View File

@ -37,35 +37,42 @@
#ifndef O_RSYNC
#define O_RSYNC 0
#endif
#ifndef O_CLOEXEC
#define NEED_CLOEXEC_EMULATION
#define O_CLOEXEC 0
#endif
static int open_flag_table[14] = {
static int open_flag_table[15] = {
O_RDONLY, O_WRONLY, O_RDWR, O_NONBLOCK, O_APPEND, O_CREAT, O_TRUNC, O_EXCL,
O_NOCTTY, O_DSYNC, O_SYNC, O_RSYNC,
0, /* O_SHARE_DELETE, Windows-only */
O_CLOEXEC
0, /* O_CLOEXEC, treated specially */
0 /* O_KEEPEXEC, treated specially */
};
#ifdef NEED_CLOEXEC_EMULATION
static int open_cloexec_table[14] = {
enum { CLOEXEC = 1, KEEPEXEC = 2 };
static int open_cloexec_table[15] = {
0, 0, 0, 0, 0, 0, 0, 0,
0, 0, 0, 0,
0,
1
CLOEXEC, KEEPEXEC
};
#endif
CAMLprim value unix_open(value path, value flags, value perm)
{
CAMLparam3(path, flags, perm);
int fd, cv_flags;
int fd, cv_flags, clo_flags, cloexec;
char * p;
caml_unix_check_path(path, "open");
cv_flags = caml_convert_flag_list(flags, open_flag_table);
clo_flags = caml_convert_flag_list(flags, open_cloexec_table);
if (clo_flags & CLOEXEC)
cloexec = 1;
else if (clo_flags & KEEPEXEC)
cloexec = 0;
else
cloexec = unix_cloexec_default;
#if defined(O_CLOEXEC)
if (cloexec) cv_flags |= O_CLOEXEC;
#endif
p = caml_strdup(String_val(path));
/* open on a named FIFO can block (PR#1533) */
caml_enter_blocking_section();
@ -73,13 +80,8 @@ CAMLprim value unix_open(value path, value flags, value perm)
caml_leave_blocking_section();
caml_stat_free(p);
if (fd == -1) uerror("open", path);
#if defined(NEED_CLOEXEC_EMULATION) && defined(FD_CLOEXEC)
if (caml_convert_flag_list(flags, open_cloexec_table) != 0) {
int flags = fcntl(fd, F_GETFD, 0);
if (flags == -1 ||
fcntl(fd, F_SETFD, flags | FD_CLOEXEC) == -1)
uerror("open", path);
}
#if !defined(O_CLOEXEC)
if (cloexec) unix_set_cloexec(fd, "open", path);
#endif
CAMLreturn (Val_int(fd));
}

13
otherlibs/unix/pipe.c
View File

@ -13,15 +13,26 @@
/* */
/**************************************************************************/
#define _GNU_SOURCE
#include <caml/mlvalues.h>
#include <caml/alloc.h>
#include "unixsupport.h"
#include <fcntl.h>
CAMLprim value unix_pipe(value unit)
CAMLprim value unix_pipe(value cloexec, value vunit)
{
int fd[2];
value res;
#ifdef HAS_PIPE2
if (pipe2(fd, unix_cloexec_p(cloexec) ? O_CLOEXEC : 0) == -1)
uerror("pipe", Nothing);
#else
if (pipe(fd) == -1) uerror("pipe", Nothing);
if (unix_cloexec_p(cloexec)) {
unix_set_cloexec(fd[0], "pipe", Nothing);
unix_set_cloexec(fd[1], "pipe", Nothing);
}
#endif
res = caml_alloc_small(2, 0);
Field(res, 0) = Val_int(fd[0]);
Field(res, 1) = Val_int(fd[1]);

19
otherlibs/unix/socket.c
View File

@ -13,6 +13,7 @@
/* */
/**************************************************************************/
#define _GNU_SOURCE
#include <caml/fail.h>
#include <caml/mlvalues.h>
#include "unixsupport.h"
@ -37,20 +38,28 @@ int socket_type_table[] = {
SOCK_STREAM, SOCK_DGRAM, SOCK_RAW, SOCK_SEQPACKET
};
CAMLprim value unix_socket(value domain, value type, value proto)
CAMLprim value unix_socket(value cloexec, value domain,
value type, value proto)
{
int retcode;
int ty = socket_type_table[Int_val(type)];
#ifdef SOCK_CLOEXEC
if (unix_cloexec_p(cloexec)) ty |= SOCK_CLOEXEC;
#endif
retcode = socket(socket_domain_table[Int_val(domain)],
socket_type_table[Int_val(type)],
Int_val(proto));
ty, Int_val(proto));
if (retcode == -1) uerror("socket", Nothing);
#ifndef SOCK_CLOEXEC
if (unix_cloexec_p(cloexec))
unix_set_cloexec(retcode, "socket", Nothing);
#endif
return Val_int(retcode);
}
#else
CAMLprim value unix_socket(value domain, value type, value proto)
CAMLprim value unix_socket(value cloexec, value domain,
value type,value proto)
{ caml_invalid_argument("socket not implemented"); }
#endif

16
otherlibs/unix/socketpair.c
View File

@ -24,14 +24,24 @@
extern int socket_domain_table[], socket_type_table[];
CAMLprim value unix_socketpair(value domain, value type, value proto)
CAMLprim value unix_socketpair(value cloexec, value domain,
value type, value proto)
{
int sv[2];
value res;
int ty = socket_type_table[Int_val(type)];
#ifdef SOCK_CLOEXEC
if (unix_cloexec_p(cloexec)) ty |= SOCK_CLOEXEC;
#endif
if (socketpair(socket_domain_table[Int_val(domain)],
socket_type_table[Int_val(type)],
Int_val(proto), sv) == -1)
ty, Int_val(proto), sv) == -1)
uerror("socketpair", Nothing);
#ifndef SOCK_CLOEXEC
if (unix_cloexec_p(cloexec)) {
unix_set_cloexec(sv[0], "socketpair", Nothing);
unix_set_cloexec(sv[1], "socketpair", Nothing);
}
#endif
res = caml_alloc_small(2, 0);
Field(res,0) = Val_int(sv[0]);
Field(res,1) = Val_int(sv[1]);

196
otherlibs/unix/unix.ml
View File

@ -231,6 +231,7 @@ type open_flag =
| O_RSYNC
| O_SHARE_DELETE
| O_CLOEXEC
| O_KEEPEXEC
type file_perm = int
@ -369,18 +370,14 @@ 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 dup : ?cloexec: bool -> file_descr -> file_descr = "unix_dup"
external dup2 :
?cloexec: bool -> 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"
(* FD_CLOEXEC should be supported on all Unix systems these days,
but just in case... *)
let try_set_close_on_exec fd =
try set_close_on_exec fd; true with Invalid_argument _ -> false
external mkdir : string -> file_perm -> unit = "unix_mkdir"
external rmdir : string -> unit = "unix_rmdir"
external chdir : string -> unit = "unix_chdir"
@ -394,7 +391,8 @@ 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 pipe :
?cloexec: bool -> unit -> file_descr * file_descr = "unix_pipe"
external symlink : ?to_dir:bool -> string -> string -> unit = "unix_symlink"
external has_symlink : unit -> bool = "unix_has_symlink"
external readlink : string -> string = "unix_readlink"
@ -541,12 +539,15 @@ type msg_flag =
| MSG_DONTROUTE
| MSG_PEEK
external socket : socket_domain -> socket_type -> int -> file_descr
= "unix_socket"
external socket :
?cloexec: bool -> socket_domain -> socket_type -> int -> file_descr
= "unix_socket"
external socketpair :
socket_domain -> socket_type -> int -> file_descr * file_descr
= "unix_socketpair"
external accept : file_descr -> file_descr * sockaddr = "unix_accept"
?cloexec: bool -> socket_domain -> socket_type -> int ->
file_descr * file_descr
= "unix_socketpair"
external accept :
?cloexec: bool -> file_descr -> file_descr * sockaddr = "unix_accept"
external bind : file_descr -> sockaddr -> unit = "unix_bind"
external connect : file_descr -> sockaddr -> unit = "unix_connect"
external listen : file_descr -> int -> unit = "unix_listen"
@ -888,29 +889,23 @@ let system cmd =
end
| id -> snd(waitpid_non_intr 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;
(* Make sure [fd] is not one of the standard descriptors 0, 1, 2,
by duplicating it if needed. *)
let rec file_descr_not_standard fd =
if fd >= 3 then fd else begin
let res = file_descr_not_standard (dup fd) in
close 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 new_stdin = file_descr_not_standard new_stdin in
let new_stdout = file_descr_not_standard new_stdout in
let new_stderr = file_descr_not_standard new_stderr in
dup2 ~cloexec:false new_stdin stdin; close new_stdin;
dup2 ~cloexec:false new_stdout stdout; close new_stdout;
dup2 ~cloexec:false new_stderr stderr; close new_stderr
let create_process cmd args new_stdin new_stdout new_stderr =
match fork() with
@ -942,24 +937,26 @@ type popen_process =
let popen_processes = (Hashtbl.create 7 : (popen_process, int) Hashtbl.t)
let open_proc cmd proc input output toclose =
let cloexec = List.for_all try_set_close_on_exec toclose in
match fork() with
0 -> begin try
if input <> stdin then begin dup2 input stdin; close input end;
if output <> stdout then begin dup2 output stdout; close output end;
if not cloexec then List.iter close toclose;
execv "/bin/sh" [| "/bin/sh"; "-c"; cmd |]
with _ -> sys_exit 127
let open_proc cmd envopt proc input output error =
match fork() with
0 -> perform_redirections input output error;
let shell = "/bin/sh" in
let argv = [| shell; "-c"; cmd |] in
begin try
match envopt with
| Some env -> execve shell argv env
| None -> execv shell argv
with _ ->
sys_exit 127
end
| id -> Hashtbl.add popen_processes proc id
| id -> Hashtbl.add popen_processes proc id
let open_process_in cmd =
let (in_read, in_write) = pipe() in
let (in_read, in_write) = pipe ~cloexec:true () in
let inchan = in_channel_of_descr in_read in
begin
try
open_proc cmd (Process_in inchan) stdin in_write [in_read];
open_proc cmd None (Process_in inchan) stdin in_write stderr
with e ->
close_in inchan;
close in_write;
@ -969,69 +966,64 @@ let open_process_in cmd =
inchan
let open_process_out cmd =
let (out_read, out_write) = pipe() in
let (out_read, out_write) = pipe ~cloexec:true () in
let outchan = out_channel_of_descr out_write in
begin
try
open_proc cmd (Process_out outchan) out_read stdout [out_write];
open_proc cmd None (Process_out outchan) out_read stdout stderr
with e ->
close_out outchan;
close out_read;
raise e
close_out outchan;
close out_read;
raise e
end;
close out_read;
outchan
let open_process cmd =
let (in_read, in_write) = pipe() in
let fds_to_close = ref [in_read;in_write] in
try
let (out_read, out_write) = pipe() in
fds_to_close := [in_read;in_write;out_read;out_write];
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)
with e ->
List.iter close !fds_to_close;
raise e
let open_proc_full cmd env proc input output error toclose =
let cloexec = List.for_all try_set_close_on_exec toclose in
match fork() with
0 -> begin try
dup2 input stdin; close input;
dup2 output stdout; close output;
dup2 error stderr; close error;
if not cloexec then List.iter close toclose;
execve "/bin/sh" [| "/bin/sh"; "-c"; cmd |] env
with _ -> sys_exit 127
end
| id -> Hashtbl.add popen_processes proc id
let (in_read, in_write) = pipe ~cloexec:true () in
let (out_read, out_write) =
try pipe ~cloexec:true ()
with e -> close in_read; close in_write; raise e in
let inchan = in_channel_of_descr in_read in
let outchan = out_channel_of_descr out_write in
begin
try
open_proc cmd None (Process(inchan, outchan)) out_read in_write stderr
with e ->
close out_read; close out_write;
close in_read; close in_write;
raise e
end;
close out_read;
close in_write;
(inchan, outchan)
let open_process_full cmd env =
let (in_read, in_write) = pipe() in
let fds_to_close = ref [in_read;in_write] in
try
let (out_read, out_write) = pipe() in
fds_to_close := out_read::out_write:: !fds_to_close;
let (err_read, err_write) = pipe() in
fds_to_close := err_read::err_write:: !fds_to_close;
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)
with e ->
List.iter close !fds_to_close;
raise e
let (in_read, in_write) = pipe ~cloexec:true () in
let (out_read, out_write) =
try pipe ~cloexec:true ()
with e -> close in_read; close in_write; raise e in
let (err_read, err_write) =
try pipe ~cloexec:true ()
with e -> close in_read; close in_write;
close out_read; close out_write; raise e 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
begin
try
open_proc cmd (Some env) (Process_full(inchan, outchan, errchan))
out_read in_write err_write
with e ->
close out_read; close out_write;
close in_read; close in_write;
close err_read; close err_write;
raise e
end;
close out_read;
close in_write;
close err_write;
(inchan, outchan, errchan)
let find_proc_id fun_name proc =
try
@ -1048,7 +1040,9 @@ let close_process_in inchan =
let close_process_out outchan =
let pid = find_proc_id "close_process_out" (Process_out outchan) in
close_out outchan;
(* The application may have closed [outchan] already to signal
end-of-input to the process. *)
begin try close_out outchan with Sys_error _ -> () end;
snd(waitpid_non_intr pid)
let close_process (inchan, outchan) =
@ -1070,10 +1064,9 @@ let close_process_full (inchan, outchan, errchan) =
let open_connection sockaddr =
let sock =
socket (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
socket ~cloexec:true (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
try
connect sock sockaddr;
ignore(try_set_close_on_exec sock);
(in_channel_of_descr sock, out_channel_of_descr sock)
with exn ->
close sock; raise exn
@ -1082,12 +1075,12 @@ let shutdown_connection inchan =
shutdown (descr_of_in_channel inchan) SHUTDOWN_SEND
let rec accept_non_intr s =
try accept s
try accept ~cloexec:true s
with Unix_error (EINTR, _, _) -> accept_non_intr s
let establish_server server_fun sockaddr =
let sock =
socket (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
socket ~cloexec:true (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
setsockopt sock SO_REUSEADDR true;
bind sock sockaddr;
listen sock 5;
@ -1099,7 +1092,6 @@ let establish_server server_fun sockaddr =
0 -> if fork() <> 0 then sys_exit 0;
(* The son exits, the grandson works *)
close sock;
ignore(try_set_close_on_exec s);
let inchan = in_channel_of_descr s in
let outchan = out_channel_of_descr s in
server_fun inchan outchan;

87
otherlibs/unix/unix.mli
View File

@ -262,7 +262,11 @@ type open_flag =
| O_SHARE_DELETE (** Windows only: allow the file to be deleted
while still open *)
| O_CLOEXEC (** Set the close-on-exec flag on the
descriptor returned by {!openfile} *)
descriptor returned by {!openfile}.
See {!set_close_on_exec} for more
information. *)
| O_KEEPEXEC (** Clear the close-on-exec flag.
This is currently the default. *)
(** The flags to {!Unix.openfile}. *)
@ -574,13 +578,17 @@ val access : string -> access_permission list -> unit
(** {6 Operations on file descriptors} *)
val dup : file_descr -> file_descr
val dup : ?cloexec:bool -> file_descr -> file_descr
(** Return a new file descriptor referencing the same file as
the given descriptor. *)
the given descriptor.
See {!set_close_on_exec} for documentation on the [cloexec]
optional argument. *)
val dup2 : file_descr -> file_descr -> unit
val dup2 : ?cloexec:bool -> file_descr -> file_descr -> unit
(** [dup2 fd1 fd2] duplicates [fd1] to [fd2], closing [fd2] if already
opened. *)
opened.
See {!set_close_on_exec} for documentation on the [cloexec]
optional argument. *)
val set_nonblock : file_descr -> unit
(** Set the ``non-blocking'' flag on the given descriptor.
@ -598,7 +606,48 @@ val set_close_on_exec : file_descr -> unit
(** Set the ``close-on-exec'' flag on the given descriptor.
A descriptor with the close-on-exec flag is automatically
closed when the current process starts another program with
one of the [exec] functions. *)
one of the [exec], [create_process] and [open_process] functions.
It is often a security hole to leak file descriptors opened on, say,
a private file to an external program: the program, then, gets access
to the private file and can do bad things with it. Hence, it is
highly recommended to set all file descriptors ``close-on-exec'',
except in the very few cases where a file descriptor actually needs
to be transmitted to another program.
The best way to set a file descriptor ``close-on-exec'' is to create
it in this state. To this end, the [openfile] function has
[O_CLOEXEC] and [O_KEEPEXEC] flags to enforce ``close-on-exec'' mode
or ``keep-on-exec'' mode, respectively. All other operations in
the Unix module that create file descriptors have an optional
argument [?cloexec:bool] to indicate whether the file descriptor
should be created in ``close-on-exec'' mode (by writing
[~cloexec:true]) or in ``keep-on-exec'' mode (by writing
[~cloexec:false]). For historical reasons, the default file
descriptor creation mode is ``keep-on-exec'', if no [cloexec] optional
argument is given. This is not a safe default, hence it is highly
recommended to pass explicit [cloexec] arguments to operations that
create file descriptors.
The [cloexec] optional arguments and the [O_KEEPEXEC] flag were introduced
in OCaml 4.05. Earlier, the common practice was to create file descriptors
in the default, ``keep-on-exec'' mode, then call [set_close_on_exec]
on those freshly-created file descriptors. This is not as safe as
creating the file descriptor in ``close-on-exec'' mode because, in
multithreaded programs, a window of vulnerability exists between the time
when the file descriptor is created and the time [set_close_on_exec]
completes. If another thread spawns another program during this window,
the descriptor will leak, as it is still in the ``keep-on-exec'' mode.
Regarding the atomicity guarantees given by [~cloexec:true] or by
the use of the [O_CLOEXEC] flag: on all platforms it is guaranteed
that a concurrently-executing Caml thread cannot leak the descriptor
by starting a new process. On Linux, this guarantee extends to
concurrently-executing C threads. As of Feb 2017, other operating
systems lack the necessary system calls and still expose a window
of vulnerability during which a C thread can see the newly-created
file descriptor in ``keep-on-exec'' mode.
*)
val clear_close_on_exec : file_descr -> unit
(** Clear the ``close-on-exec'' flag on the given descriptor.
@ -645,10 +694,12 @@ val closedir : dir_handle -> unit
(** {6 Pipes and redirections} *)
val pipe : unit -> file_descr * file_descr
val pipe : ?cloexec:bool -> 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. *)
opened for writing, that's the entrance to the pipe.
See {!set_close_on_exec} for documentation on the [cloexec]
optional argument. *)
val mkfifo : string -> file_perm -> unit
(** Create a named pipe with the given permissions (see {!umask}).
@ -1146,22 +1197,30 @@ type sockaddr =
domain; [addr] is the Internet address of the machine, and
[port] is the port number. *)
val socket : socket_domain -> socket_type -> int -> file_descr
val socket :
?cloexec:bool -> 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. *)
the default protocol for that kind of sockets.
See {!set_close_on_exec} for documentation on the [cloexec]
optional argument. *)
val domain_of_sockaddr: sockaddr -> socket_domain
(** Return the socket domain adequate for the given socket address. *)
val socketpair :
socket_domain -> socket_type -> int -> file_descr * file_descr
(** Create a pair of unnamed sockets, connected together. *)
?cloexec:bool -> socket_domain -> socket_type -> int ->
file_descr * file_descr
(** Create a pair of unnamed sockets, connected together.
See {!set_close_on_exec} for documentation on the [cloexec]
optional argument. *)
val accept : file_descr -> file_descr * sockaddr
val accept : ?cloexec:bool -> 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. *)
the address of the connecting client.
See {!set_close_on_exec} for documentation on the [cloexec]
optional argument. *)
val bind : file_descr -> sockaddr -> unit
(** Bind a socket to an address. *)

15
otherlibs/unix/unixLabels.mli
View File

@ -248,6 +248,8 @@ type open_flag = Unix.open_flag =
while still open *)
| O_CLOEXEC (** Set the close-on-exec flag on the
descriptor returned by {!openfile} *)
| O_KEEPEXEC (** Clear the close-on-exec flag.
This is currently the default. *)
(** The flags to {!UnixLabels.openfile}. *)
@ -461,11 +463,11 @@ val access : string -> perm:access_permission list -> unit
(** {6 Operations on file descriptors} *)
val dup : file_descr -> file_descr
val dup : ?cloexec:bool -> file_descr -> file_descr
(** Return a new file descriptor referencing the same file as
the given descriptor. *)
val dup2 : src:file_descr -> dst:file_descr -> unit
val dup2 : ?cloexec:bool -> src:file_descr -> dst:file_descr -> unit
(** [dup2 fd1 fd2] duplicates [fd1] to [fd2], closing [fd2] if already
opened. *)
@ -531,7 +533,7 @@ val closedir : dir_handle -> unit
(** {6 Pipes and redirections} *)
val pipe : unit -> file_descr * file_descr
val pipe : ?cloexec:bool -> 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. *)
@ -961,7 +963,8 @@ type sockaddr = Unix.sockaddr =
[port] is the port number. *)
val socket :
domain:socket_domain -> kind:socket_type -> protocol:int -> file_descr
?cloexec:bool -> domain:socket_domain -> kind:socket_type -> protocol: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. *)
@ -970,11 +973,11 @@ val domain_of_sockaddr: sockaddr -> socket_domain
(** Return the socket domain adequate for the given socket address. *)
val socketpair :
domain:socket_domain -> kind:socket_type -> protocol:int ->
?cloexec:bool -> domain:socket_domain -> kind:socket_type -> protocol:int ->
file_descr * file_descr
(** Create a pair of unnamed sockets, connected together. *)
val accept : file_descr -> file_descr * sockaddr
val accept : ?cloexec:bool -> 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. *)

31
otherlibs/unix/unixsupport.c
View File

@ -21,6 +21,10 @@
#include "unixsupport.h"
#include "cst2constr.h"
#include <errno.h>
#ifdef HAS_UNISTD
#include <unistd.h>
#endif
#include <fcntl.h>
#ifndef E2BIG
#define E2BIG (-1)
@ -314,3 +318,30 @@ void caml_unix_check_path(value path, char * cmdname)
{
if (! caml_string_is_c_safe(path)) unix_error(ENOENT, cmdname, path);
}
int unix_cloexec_default = 0;
int unix_cloexec_p(value cloexec)
{
/* [cloexec] is a [bool option]. */
if (Is_block(cloexec))
return Bool_val(Field(cloexec, 0));
else
return unix_cloexec_default;
}
void unix_set_cloexec(int fd, char *cmdname, value cmdarg)
{
int flags = fcntl(fd, F_GETFD, 0);
if (flags == -1 ||
fcntl(fd, F_SETFD, flags | FD_CLOEXEC) == -1)
uerror(cmdname, cmdarg);
}
void unix_clear_cloexec(int fd, char *cmdname, value cmdarg)
{
int flags = fcntl(fd, F_GETFD, 0);
if (flags == -1 ||
fcntl(fd, F_SETFD, flags & ~FD_CLOEXEC) == -1)
uerror(cmdname, cmdarg);
}

5
otherlibs/unix/unixsupport.h
View File

@ -45,6 +45,11 @@ extern void caml_unix_check_path(value path, char * cmdname);
extern char ** cstringvect(value arg, char * cmdname);
extern int unix_cloexec_default;
extern int unix_cloexec_p(value cloexec);
extern void unix_set_cloexec(int fd, char * cmdname, value arg);
extern void unix_clear_cloexec(int fd, char * cmdname, value arg);
#ifdef __cplusplus
}
#endif

7
otherlibs/win32unix/accept.c
View File

@ -20,8 +20,7 @@
#include "unixsupport.h"
#include "socketaddr.h"
CAMLprim value unix_accept(sock)
value sock;
CAMLprim value unix_accept(value cloexec, value sock)
{
SOCKET sconn = Socket_val(sock);
SOCKET snew;
@ -39,6 +38,10 @@ CAMLprim value unix_accept(sock)
win32_maperr(err);
uerror("accept", Nothing);
}
/* This is a best effort, not guaranteed to work, so don't fail on error */
SetHandleInformation((HANDLE) snew,
HANDLE_FLAG_INHERIT,
unix_cloexec_p(cloexec) ? 0 : HANDLE_FLAG_INHERIT);
Begin_roots2 (fd, adr)
fd = win_alloc_socket(snew);
adr = alloc_sockaddr(&addr, addr_len, snew);

38
otherlibs/win32unix/createprocess.c
View File

@ -30,13 +30,15 @@ value win_create_process_native(value cmd, value cmdline, value env,
PROCESS_INFORMATION pi;
STARTUPINFO si;
char * exefile, * envp;
int flags;
DWORD flags, err;
HANDLE hp;
caml_unix_check_path(cmd, "create_process");
if (! caml_string_is_c_safe(cmdline))
unix_error(EINVAL, "create_process", cmdline);
/* [env] is checked for null bytes at construction time, see unix.ml */
err = ERROR_SUCCESS;
exefile = caml_search_exe_in_path(String_val(cmd));
if (env != Val_int(0)) {
envp = String_val(Field(env, 0));
@ -47,9 +49,20 @@ value win_create_process_native(value cmd, value cmdline, value env,
ZeroMemory(&si, sizeof(STARTUPINFO));
si.cb = sizeof(STARTUPINFO);
si.dwFlags = STARTF_USESTDHANDLES;
si.hStdInput = Handle_val(fd1);
si.hStdOutput = Handle_val(fd2);
si.hStdError = Handle_val(fd3);
/* Duplicate the handles fd1, fd2, fd3 to make sure they are inheritable */
hp = GetCurrentProcess();
if (! DuplicateHandle(hp, Handle_val(fd1), hp, &(si.hStdInput),
0, TRUE, DUPLICATE_SAME_ACCESS)) {
err = GetLastError(); goto ret1;
}
if (! DuplicateHandle(hp, Handle_val(fd2), hp, &(si.hStdOutput),
0, TRUE, DUPLICATE_SAME_ACCESS)) {
err = GetLastError(); goto ret2;
}
if (! DuplicateHandle(hp, Handle_val(fd3), hp, &(si.hStdError),
0, TRUE, DUPLICATE_SAME_ACCESS)) {
err = GetLastError(); goto ret3;
}
/* If we do not have a console window, then we must create one
before running the process (keep it hidden for apparence).
If we are starting a GUI application, the newly created
@ -64,12 +77,21 @@ value win_create_process_native(value cmd, value cmdline, value env,
/* Create the process */
if (! CreateProcess(exefile, String_val(cmdline), NULL, NULL,
TRUE, flags, envp, NULL, &si, &pi)) {
caml_stat_free(exefile);
win32_maperr(GetLastError());
err = GetLastError(); goto ret4;
}
CloseHandle(pi.hThread);
ret4:
CloseHandle(si.hStdError);
ret3:
CloseHandle(si.hStdOutput);
ret2:
CloseHandle(si.hStdInput);
ret1:
caml_stat_free(exefile);
if (err != ERROR_SUCCESS) {
win32_maperr(err);
uerror("create_process", cmd);
}
caml_stat_free(exefile);
CloseHandle(pi.hThread);
/* Return the process handle as pseudo-PID
(this is consistent with the wait() emulation in the MSVC C library */
return Val_long(pi.hProcess);

6
otherlibs/win32unix/dup.c
View File

@ -16,14 +16,16 @@
#include <caml/mlvalues.h>
#include "unixsupport.h"
CAMLprim value unix_dup(value fd)
CAMLprim value unix_dup(value cloexec, value fd)
{
HANDLE newh;
value newfd;
int kind = Descr_kind_val(fd);
if (! DuplicateHandle(GetCurrentProcess(), Handle_val(fd),
GetCurrentProcess(), &newh,
0L, TRUE, DUPLICATE_SAME_ACCESS)) {
0L,
unix_cloexec_p(cloexec) ? FALSE : TRUE,
DUPLICATE_SAME_ACCESS)) {
win32_maperr(GetLastError());
return -1;
}

6
otherlibs/win32unix/dup2.c
View File

@ -16,14 +16,16 @@
#include <caml/mlvalues.h>
#include "unixsupport.h"
CAMLprim value unix_dup2(value fd1, value fd2)
CAMLprim value unix_dup2(value cloexec, value fd1, value fd2)
{
HANDLE oldh, newh;
oldh = Handle_val(fd2);
if (! DuplicateHandle(GetCurrentProcess(), Handle_val(fd1),
GetCurrentProcess(), &newh,
0L, TRUE, DUPLICATE_SAME_ACCESS)) {
0L,
unix_cloexec_p(cloexec) ? FALSE : TRUE,
DUPLICATE_SAME_ACCESS)) {
win32_maperr(GetLastError());
return -1;
}

23
otherlibs/win32unix/open.c
View File

@ -18,21 +18,23 @@
#include "unixsupport.h"
#include <fcntl.h>
static int open_access_flags[14] = {
static int open_access_flags[15] = {
GENERIC_READ, GENERIC_WRITE, GENERIC_READ|GENERIC_WRITE,
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0
};
static int open_create_flags[14] = {
0, 0, 0, 0, 0, O_CREAT, O_TRUNC, O_EXCL, 0, 0, 0, 0, 0, 0
static int open_create_flags[15] = {
0, 0, 0, 0, 0, O_CREAT, O_TRUNC, O_EXCL, 0, 0, 0, 0, 0, 0, 0
};
static int open_share_flags[14] = {
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, FILE_SHARE_DELETE, 0
static int open_share_flags[15] = {
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, FILE_SHARE_DELETE, 0, 0
};
static int open_cloexec_flags[14] = {
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1
enum { CLOEXEC = 1, KEEPEXEC = 2 };
static int open_cloexec_flags[15] = {
0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, CLOEXEC, KEEPEXEC
};
CAMLprim value unix_open(value path, value flags, value perm)
@ -66,7 +68,10 @@ CAMLprim value unix_open(value path, value flags, value perm)
cloexec = caml_convert_flag_list(flags, open_cloexec_flags);
attr.nLength = sizeof(attr);
attr.lpSecurityDescriptor = NULL;
attr.bInheritHandle = cloexec ? FALSE : TRUE;
attr.bInheritHandle =
cloexec & CLOEXEC ? FALSE
: cloexec & KEEPEXEC ? TRUE
: !unix_cloexec_default;
h = CreateFile(String_val(path), fileaccess,
sharemode, &attr,

4
otherlibs/win32unix/pipe.c
View File

@ -22,7 +22,7 @@
/* PR#4749: pick a size that matches that of I/O buffers */
#define SIZEBUF 4096
CAMLprim value unix_pipe(value unit)
CAMLprim value unix_pipe(value cloexec, value unit)
{
SECURITY_ATTRIBUTES attr;
HANDLE readh, writeh;
@ -30,7 +30,7 @@ CAMLprim value unix_pipe(value unit)
attr.nLength = sizeof(attr);
attr.lpSecurityDescriptor = NULL;
attr.bInheritHandle = TRUE;
attr.bInheritHandle = unix_cloexec_p(cloexec) ? FALSE : TRUE;
if (! CreatePipe(&readh, &writeh, &attr, SIZEBUF)) {
win32_maperr(GetLastError());
uerror("pipe", Nothing);

7
otherlibs/win32unix/socket.c
View File

@ -29,8 +29,7 @@ int socket_type_table[] = {
SOCK_STREAM, SOCK_DGRAM, SOCK_RAW, SOCK_SEQPACKET
};
CAMLprim value unix_socket(domain, type, proto)
value domain, type, proto;
CAMLprim value unix_socket(value cloexec, value domain, value type, value proto)
{
SOCKET s;
@ -49,5 +48,9 @@ CAMLprim value unix_socket(domain, type, proto)
win32_maperr(WSAGetLastError());
uerror("socket", Nothing);
}
/* This is a best effort, not guaranteed to work, so don't fail on error */
SetHandleInformation((HANDLE) s,
HANDLE_FLAG_INHERIT,
unix_cloexec_p(cloexec) ? 0 : HANDLE_FLAG_INHERIT);
return win_alloc_socket(s);
}

98
otherlibs/win32unix/unix.ml
View File

@ -172,6 +172,7 @@ type open_flag =
| O_RSYNC
| O_SHARE_DELETE
| O_CLOEXEC
| O_KEEPEXEC
type file_perm = int
@ -328,8 +329,9 @@ external access : string -> access_permission list -> unit = "unix_access"
(* Operations on file descriptors *)
external dup : file_descr -> file_descr = "unix_dup"
external dup2 : file_descr -> file_descr -> unit = "unix_dup2"
external dup : ?cloexec: bool -> file_descr -> file_descr = "unix_dup"
external dup2 :
?cloexec: bool -> 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"
@ -386,7 +388,8 @@ let rewinddir d =
(* Pipes *)
external pipe : unit -> file_descr * file_descr = "unix_pipe"
external pipe :
?cloexec: bool -> unit -> file_descr * file_descr = "unix_pipe"
let mkfifo _name _perm = invalid_arg "Unix.mkfifo not implemented"
@ -564,10 +567,12 @@ type msg_flag =
| MSG_DONTROUTE
| MSG_PEEK
external socket : socket_domain -> socket_type -> int -> file_descr
= "unix_socket"
let socketpair _dom _ty _proto = invalid_arg "Unix.socketpair not implemented"
external accept : file_descr -> file_descr * sockaddr = "unix_accept"
external socket :
?cloexec: bool -> socket_domain -> socket_type -> int -> file_descr
= "unix_socket"
let socketpair ?cloexec:_ _dom _ty _proto = invalid_arg "Unix.socketpair not implemented"
external accept :
?cloexec: bool -> file_descr -> file_descr * sockaddr = "unix_accept"
external bind : file_descr -> sockaddr -> unit = "unix_bind"
external connect : file_descr -> sockaddr -> unit = "unix_connect"
external listen : file_descr -> int -> unit = "unix_listen"
@ -882,46 +887,78 @@ let open_proc cmd optenv proc input output error =
Hashtbl.add popen_processes proc pid
let open_process_in cmd =
let (in_read, in_write) = pipe() in
set_close_on_exec in_read;
let (in_read, in_write) = pipe ~cloexec:true () in
let inchan = in_channel_of_descr in_read in
open_proc cmd None (Process_in inchan) stdin in_write stderr;
begin
try
open_proc cmd None (Process_in inchan) stdin in_write stderr
with e ->
close_in inchan;
close in_write;
raise e
end;
close in_write;
inchan
let open_process_out cmd =
let (out_read, out_write) = pipe() in
set_close_on_exec out_write;
let (out_read, out_write) = pipe ~cloexec:true () in
let outchan = out_channel_of_descr out_write in
open_proc cmd None (Process_out outchan) out_read stdout stderr;
begin
try
open_proc cmd None (Process_out outchan) out_read stdout stderr
with e ->
close_out outchan;
close out_read;
raise e
end;
close out_read;
outchan
let open_process cmd =
let (in_read, in_write) = pipe() in
let (out_read, out_write) = pipe() in
set_close_on_exec in_read;
set_close_on_exec out_write;
let (in_read, in_write) = pipe ~cloexec:true () in
let (out_read, out_write) =
try pipe ~cloexec:true ()
with e -> close in_read; close in_write; raise e in
let inchan = in_channel_of_descr in_read in
let outchan = out_channel_of_descr out_write in
open_proc cmd None (Process(inchan, outchan)) out_read in_write stderr;
close out_read; close in_write;
begin
try
open_proc cmd None (Process(inchan, outchan)) out_read in_write stderr
with e ->
close out_read; close out_write;
close in_read; close in_write;
raise e
end;
close out_read;
close in_write;
(inchan, outchan)
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
set_close_on_exec in_read;
set_close_on_exec out_write;
set_close_on_exec err_read;
let (in_read, in_write) = pipe ~cloexec:true () in
let (out_read, out_write) =
try pipe ~cloexec:true ()
with e -> close in_read; close in_write; raise e in
let (err_read, err_write) =
try pipe ~cloexec:true ()
with e -> close in_read; close in_write;
close out_read; close out_write; raise e 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 cmd (Some(make_process_env env))
(Process_full(inchan, outchan, errchan))
out_read in_write err_write;
close out_read; close in_write; close err_write;
begin
try
open_proc cmd (Some (make_process_env env))
(Process_full(inchan, outchan, errchan))
out_read in_write err_write
with e ->
close out_read; close out_write;
close in_read; close in_write;
close err_read; close err_write;
raise e
end;
close out_read;
close in_write;
close err_write;
(inchan, outchan, errchan)
let find_proc_id fun_name proc =
@ -964,10 +1001,9 @@ external select :
let open_connection sockaddr =
let sock =
socket (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
socket ~cloexec:true (domain_of_sockaddr sockaddr) SOCK_STREAM 0 in
try
connect sock sockaddr;
set_close_on_exec sock;
(in_channel_of_descr sock, out_channel_of_descr sock)
with exn ->
close sock; raise exn

11
otherlibs/win32unix/unixsupport.c
View File

@ -314,3 +314,14 @@ void caml_unix_check_path(value path, char * cmdname)
{
if (! caml_string_is_c_safe(path)) unix_error(ENOENT, cmdname, path);
}
int unix_cloexec_default = 0;
int unix_cloexec_p(value cloexec)
{
/* [cloexec] is a [bool option]. */
if (Is_block(cloexec))
return Bool_val(Field(cloexec, 0));
else
return unix_cloexec_default;
}

3
otherlibs/win32unix/unixsupport.h
View File

@ -72,6 +72,9 @@ extern void caml_unix_check_path(value path, char * cmdname);
extern value unix_freeze_buffer (value);
extern char ** cstringvect(value arg, char * cmdname);
extern int unix_cloexec_default;
extern int unix_cloexec_p(value cloexec);
/* Information stored in flags_fd, describing more precisely the socket
* and its status. The whole flags_fd is initialized to 0.
*/

7
testsuite/tests/lib-unix/Makefile
View File

@ -23,5 +23,12 @@ ifeq ($(OS),Windows_NT)
ADD_BYTERUN_FLAGS="-I $(OTOPDIR)/otherlibs/win32unix"
endif
default: reflector.exe fdstatus.exe
$(MAKE) check
include $(BASEDIR)/makefiles/Makefile.several
include $(BASEDIR)/makefiles/Makefile.common
%.exe: %.c
@$(BYTECC) -o $*.exe $*.c > /dev/null

48
testsuite/tests/lib-unix/cloexec.ml Normal file
View File

@ -0,0 +1,48 @@
(* This is a terrible hack that plays on the internal representation
of file descriptors. The result is a number (as a string)
that the fdstatus.exe auxiliary program can use to check whether
the fd is open. *)
let string_of_fd (fd: Unix.file_descr) : string =
match Sys.os_type with
| "Unix" | "Cygwin" -> string_of_int (Obj.magic fd : int)
| "Win32" -> Int32.to_string (Obj.magic fd : int32)
| _ -> assert false
let _ =
let f0 = Unix.(openfile "tmp.txt" [O_WRONLY; O_CREAT; O_TRUNC] 0o600) in
let f1 = Unix.(openfile "tmp.txt" [O_RDONLY; O_KEEPEXEC] 0) in
let f2 = Unix.(openfile "tmp.txt" [O_RDONLY; O_CLOEXEC] 0) in
let d0 = Unix.dup f0 in
let d1 = Unix.dup ~cloexec:false f1 in
let d2 = Unix.dup ~cloexec:true f2 in
let (p0, p0') = Unix.pipe () in
let (p1, p1') = Unix.pipe ~cloexec:false () in
let (p2, p2') = Unix.pipe ~cloexec:true () in
let s0 = Unix.(socket PF_INET SOCK_STREAM 0) in
let s1 = Unix.(socket ~cloexec:false PF_INET SOCK_STREAM 0) in
let s2 = Unix.(socket ~cloexec:true PF_INET SOCK_STREAM 0) in
let (x0, x0') =
try Unix.(socketpair PF_UNIX SOCK_STREAM 0)
with Invalid_argument _ -> (p0, p0') in
(* socketpair not available under Win32; keep the same output *)
let (x1, x1') =
try Unix.(socketpair ~cloexec:false PF_UNIX SOCK_STREAM 0)
with Invalid_argument _ -> (p1, p1') in
let (x2, x2') =
try Unix.(socketpair ~cloexec:true PF_UNIX SOCK_STREAM 0)
with Invalid_argument _ -> (p2, p2') in
let fds = [| f0;f1;f2; d0;d1;d2;
p0;p0';p1;p1';p2;p2';
s0;s1;s2;
x0;x0';x1;x1';x2;x2' |] in
let pid =
Unix.create_process
(Filename.concat Filename.current_dir_name "fdstatus.exe")
(Array.append [| "fdstatus" |] (Array.map string_of_fd fds))
Unix.stdin Unix.stdout Unix.stderr in
ignore (Unix.waitpid [] pid);
Array.iter (fun fd -> try Unix.close fd with Unix.Unix_error _ -> ()) fds;
Sys.remove "tmp.txt"

21
testsuite/tests/lib-unix/cloexec.reference Normal file
View File

@ -0,0 +1,21 @@
#1: open
#2: open
#3: closed
#4: open
#5: open
#6: closed
#7: open
#8: open
#9: open
#10: open
#11: closed
#12: closed
#13: open
#14: open
#15: closed
#16: open
#17: open
#18: open
#19: open
#20: closed
#21: closed

5
testsuite/tests/lib-unix/dup.ml Normal file
View File

@ -0,0 +1,5 @@
let _ =
let f = Unix.dup ~cloexec:true Unix.stdout in
let txt = "Some output\n" in
ignore (Unix.write_substring f txt 0 (String.length txt));
Unix.close f

1
testsuite/tests/lib-unix/dup.reference Normal file
View File

@ -0,0 +1 @@
Some output

24
testsuite/tests/lib-unix/dup2.ml Normal file
View File

@ -0,0 +1,24 @@
let cat file =
let fd = Unix.openfile file [Unix.O_RDONLY] 0 in
let buf = Bytes.create 1024 in
let rec cat () =
let n = Unix.read fd buf 0 (Bytes.length buf) in
if n > 0 then (ignore(Unix.write Unix.stdout buf 0 n); cat ())
in cat (); Unix.close fd
let out fd txt =
ignore (Unix.write_substring fd txt 0 (String.length txt))
let _ =
let fd =
Unix.(openfile "./tmp.txt"
[O_WRONLY;O_TRUNC;O_CREAT;O_SHARE_DELETE]
0o600) in
out fd "---\n";
Unix.dup2 ~cloexec:true fd Unix.stderr;
Unix.close fd;
out Unix.stderr "Some output\n";
cat "./tmp.txt";
Sys.remove "./tmp.txt"

2
testsuite/tests/lib-unix/dup2.reference Normal file
View File

@ -0,0 +1,2 @@
---
Some output

69
testsuite/tests/lib-unix/fdstatus.c Normal file
View File

@ -0,0 +1,69 @@
/* Check if file descriptors are open or not */
#include <stdio.h>
#include <stdlib.h>
#ifdef _WIN32
#define WIN32_LEAN_AND_MEAN
#include <wtypes.h>
#include <winbase.h>
#include <winerror.h>
void process_fd(char * s)
{
int fd;
HANDLE h;
DWORD flags;
h = (HANDLE) atoi(s);
if (GetHandleInformation(h, &flags)) {
printf("open\n");
} else if (GetLastError() == ERROR_INVALID_HANDLE) {
printf("closed\n");
} else {
printf("error %d\n", GetLastError());
}
}
#else
#include <limits.h>
#include <string.h>
#include <errno.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <unistd.h>
void process_fd(char * s)
{
long n;
int fd;
char * endp;
struct stat st;
n = strtol(s, &endp, 0);
if (*endp != 0 || n < 0 || n > (long) INT_MAX) {
printf("parsing error\n");
return;
}
fd = (int) n;
if (fstat(fd, &st) != -1) {
printf("open\n");
} else if (errno == EBADF) {
printf("closed\n");
} else {
printf("error %s\n", strerror(errno));
}
}
#endif
int main(int argc, char ** argv)
{
int i;
for (i = 1; i < argc; i++) {
printf("#%d: ", i);
process_fd(argv[i]);
}
return 0;
}

87
testsuite/tests/lib-unix/redirections.ml Normal file
View File

@ -0,0 +1,87 @@
let cat file =
let fd = Unix.openfile file [Unix.O_RDONLY] 0 in
let buf = Bytes.create 1024 in
let rec cat () =
let n = Unix.read fd buf 0 (Bytes.length buf) in
if n > 0 then (ignore(Unix.write Unix.stdout buf 0 n); cat ())
in cat (); Unix.close fd
let out fd txt =
ignore (Unix.write_substring fd txt 0 (String.length txt))
let refl =
Filename.concat Filename.current_dir_name "reflector.exe"
let test_createprocess () =
let f_out =
Unix.(openfile "./tmpout.txt" [O_WRONLY;O_TRUNC;O_CREAT;O_CLOEXEC] 0o600) in
let f_err =
Unix.(openfile "./tmperr.txt" [O_WRONLY;O_TRUNC;O_CREAT;O_CLOEXEC] 0o600) in
let (p_exit, p_entrance) =
Unix.pipe ~cloexec:true () in
let pid =
Unix.create_process_env
refl
[| refl; "i2o"; "i2e"; "o"; "123"; "e"; "456"; "i2o"; "v"; "XVAR" |]
[| "XVAR=xvar" |]
p_exit f_out f_err in
out p_entrance "aaaa\n";
out p_entrance "bbbb\n";
Unix.close p_entrance;
let (_, status) = Unix.waitpid [] pid in
Unix.close p_exit; Unix.close f_out; Unix.close f_err;
if status <> Unix.WEXITED 0 then
out Unix.stdout "!!! reflector exited with an error\n";
out Unix.stdout "---- File tmpout.txt\n";
cat "./tmpout.txt";
out Unix.stdout "---- File tmperr.txt\n";
cat "./tmperr.txt";
Sys.remove "./tmpout.txt";
Sys.remove "./tmperr.txt"
let test_open_process_in () =
let ic = Unix.open_process_in (refl ^ " o 123 o 456") in
out Unix.stdout (input_line ic ^ "\n");
out Unix.stdout (input_line ic ^ "\n");
let status = Unix.close_process_in ic in
if status <> Unix.WEXITED 0 then
out Unix.stdout "!!! reflector exited with an error\n"
let test_open_process_out () =
let oc = Unix.open_process_out (refl ^ " i2o i2o i2o") in
output_string oc "aa\nbbbb\n"; close_out oc;
let status = Unix.close_process_out oc in
if status <> Unix.WEXITED 0 then
out Unix.stdout "!!! reflector exited with an error\n"
let test_open_process_full () =
let ((o, i, e) as res) =
Unix.open_process_full
(refl ^ " o 123 i2o e 456 i2e v XVAR")
[|"XVAR=xvar"|] in
output_string i "aa\nbbbb\n"; close_out i;
for _i = 1 to 3 do
out Unix.stdout (input_line o ^ "\n")
done;
for _i = 1 to 2 do
out Unix.stdout (input_line e ^ "\n")
done;
let status = Unix.close_process_full res in
if status <> Unix.WEXITED 0 then
out Unix.stdout "!!! reflector exited with an error\n"
let _ =
(* The following 'close' makes things more difficult.
Under Unix it works fine, but under Win32 create_process
gives an error if one of the standard handles is closed. *)
(* Unix.close Unix.stdin; *)
out Unix.stdout "** create_process\n";
test_createprocess();
out Unix.stdout "** open_process_in\n";
test_open_process_in();
out Unix.stdout "** open_process_out\n";
test_open_process_out();
out Unix.stdout "** open_process_full\n";
test_open_process_full()

22
testsuite/tests/lib-unix/redirections.reference Normal file
View File

@ -0,0 +1,22 @@
** create_process
---- File tmpout.txt
aaaa
123
<end of file>
xvar
---- File tmperr.txt
bbbb
456
** open_process_in
123
456
** open_process_out
aa
bbbb
<end of file>
** open_process_full
123
aa
xvar
456
bbbb

74
testsuite/tests/lib-unix/reflector.c Normal file
View File

@ -0,0 +1,74 @@
#include <stdio.h>
#include <string.h>
#include <stdlib.h>
#if defined(_WIN32)
#include <fcntl.h>
#include <io.h>
#endif
/* A tool to read data from standard input and send it to standard
output or standard error. */
void copyline(FILE * in, FILE * out)
{
int c;
do {
c = getc(in);
if (c == EOF) {
fputs("<end of file>\n", out);
break;
}
putc(c, out);
} while (c != '\n');
fflush(out);
}
/* Command language:
i2o copy one line from stdin to stdout
i2e copy one line from stdin to stderr
o <txt> write <txt> plus newline to stdout
e <txt> write <txt> plus newline to stderr
v <var> write value of environment variable <env> to stdout
*/
int main(int argc, char ** argv)
{
int i;
char * cmd;
#if defined(_WIN32)
_setmode(_fileno(stdin), _O_BINARY);
_setmode(_fileno(stdout), _O_BINARY);
_setmode(_fileno(stderr), _O_BINARY);
#endif
i = 1;
while (i < argc) {
cmd = argv[i];
if (strcmp(cmd, "i2o") == 0) {
copyline(stdin, stdout);
i++;
} else if (strcmp(cmd, "i2e") == 0) {
copyline(stdin, stderr);
i++;
} else if (strcmp(cmd, "o") == 0 && i + 1 < argc) {
fputs(argv[i + 1], stdout);
fputc('\n', stdout);
fflush(stdout);
i += 2;
} else if (strcmp(cmd, "e") == 0 && i + 1 < argc) {
fputs(argv[i + 1], stderr);
fputc('\n', stderr);
fflush(stderr);
i += 2;
} else if (strcmp(cmd, "v") == 0 && i + 1 < argc) {
char * v = getenv(argv[i + 1]);
fputs((v == NULL ? "<no such variable>" : v), stdout);
fputc('\n', stdout);
fflush(stdout);
i += 2;
} else {
fputs("<bad argument>\n", stderr);
return 2;
}
}
return 0;
}