(* $Id: netsys_posix.ml 2195 2015-01-01 12:23:39Z gerd $ *)
open Unix
open Printf
module Debug = struct
let enable = ref false
end
let dlog = Netlog.Debug.mk_dlog "Netsys_posix" Debug.enable
let dlogr = Netlog.Debug.mk_dlogr "Netsys_posix" Debug.enable
let () =
Netlog.Debug.register_module "Netsys_posix" Debug.enable
external int64_of_file_descr : Unix.file_descr -> int64
= "netsys_int64_of_file_descr"
let int_of_file_descr =
match Sys.os_type with
| "Unix" | "Cygwin" ->
(fun fd -> (Obj.magic (fd:file_descr) : int))
| _ ->
(fun fd -> invalid_arg "Netsys.int_of_file_descr")
let file_descr_of_int =
match Sys.os_type with
| "Unix" | "Cygwin" ->
(fun n -> (Obj.magic (n:int) : file_descr))
| _ ->
(fun n -> invalid_arg "Netsys.file_descr_of_int")
(* Limits & resources *)
external sysconf_open_max : unit -> int = "netsys_sysconf_open_max";;
(* misc *)
external fchdir : Unix.file_descr -> unit = "netsys_fchdir" ;;
external fdopendir : Unix.file_descr -> Unix.dir_handle = "netsys_fdopendir" ;;
external realpath : string -> string = "netsys_realpath"
external get_nonblock : Unix.file_descr -> bool = "netsys_get_nonblock"
(* Process groups, sessions, terminals *)
external getpgid : int -> int = "netsys_getpgid";;
let getpgrp() = getpgid 0;;
external setpgid : int -> int -> unit = "netsys_setpgid";;
let setpgrp() = setpgid 0 0;;
external tcgetpgrp : file_descr -> int = "netsys_tcgetpgrp";;
external tcsetpgrp : file_descr -> int -> unit = "netsys_tcsetpgrp";;
external ctermid : unit -> string = "netsys_ctermid";;
external ttyname : file_descr -> string = "netsys_ttyname";;
external getsid : int -> int = "netsys_getsid";;
external posix_openpt : bool -> Unix.file_descr = "netsys_posix_openpt"
external grantpt : Unix.file_descr -> unit = "netsys_grantpt"
external unlockpt : Unix.file_descr -> unit = "netsys_unlockpt"
external ptsname : Unix.file_descr -> string = "netsys_ptsname"
let with_tty f =
let fd =
try Unix.openfile (ctermid()) [Unix.O_RDWR] 0
with _ -> failwith "Netsys_posix.with_tty: cannot open terminal" in
try
let r = f fd in
Unix.close fd;
r
with error -> Unix.close fd; raise error
let descr_input_line fd = (* unbuffered! *)
let b = Buffer.create 80 in
let s = String.create 1 in
let rec loop () =
try
let n = Unix.read fd s 0 1 in
if n > 0 && s.[0] <> '\n' then (
Buffer.add_string b s;
raise(Unix.Unix_error(Unix.EINTR,"",""))
)
with
| Unix.Unix_error(Unix.EINTR,_,_) ->
loop()
in
loop();
Buffer.contents b
let tty_read_password ?(tty=Unix.stdin) prompt =
if Unix.isatty tty then (
let cleanup = ref [] in
let f = Unix.out_channel_of_descr tty in
output_string f prompt;
flush f;
Unix.tcdrain tty;
Unix.tcflush tty Unix.TCIFLUSH;
let p = Unix.tcgetattr tty in
try
let p' =
{ p with
Unix.c_echo = false;
Unix.c_echoe = false;
Unix.c_echok = false;
Unix.c_echonl = false
} in
Unix.tcsetattr tty Unix.TCSAFLUSH p';
cleanup := (fun () -> Unix.tcsetattr tty Unix.TCSAFLUSH p) :: !cleanup;
let old_sigint =
Sys.signal Sys.sigint (Sys.Signal_handle(fun _ -> raise Sys.Break)) in
cleanup := (fun () -> Sys.set_signal Sys.sigint old_sigint) :: !cleanup;
let pw = descr_input_line tty in
output_string f "\n";
flush f;
List.iter (fun f -> f()) !cleanup;
pw
with
| error ->
List.iter (fun f -> f()) !cleanup;
if error = Sys.Break then (
output_string f "\n";
flush f
);
raise error
)
else
descr_input_line tty
(* Users and groups *)
external setreuid : int -> int -> unit = "netsys_setreuid";;
external setregid : int -> int -> unit = "netsys_setregid";;
external initgroups : string -> int -> unit = "netsys_initgroups"
(* mknod *)
type node_type =
| S_IFREG
| S_IFCHR of int (* major + minor *)
| S_IFBLK of int (* major + minor *)
| S_IFIFO
| S_IFSOCK
external mknod : string -> int -> node_type -> unit = "netsys_mknod"
(* poll *)
external pollfd_size : unit -> int = "netsys_pollfd_size"
let the_pollfd_size = pollfd_size()
let _have_poll = the_pollfd_size > 0
let have_poll() = _have_poll
type poll_req_events = int
type poll_act_events = int
type poll_cell =
{ mutable poll_fd : Unix.file_descr;
mutable poll_req_events : poll_req_events;
mutable poll_act_events : poll_act_events;
}
type poll_mem
type poll_array =
| Poll_mem of poll_mem * int (*length*)
| Poll_emu of poll_cell array
let null_poll_cell =
{ poll_fd = Unix.stdin;
poll_req_events = 0;
poll_act_events = 0
}
external mk_poll_mem : int -> poll_mem
= "netsys_mk_poll_mem"
external set_poll_mem : poll_mem -> int -> Unix.file_descr -> int -> int -> unit
= "netsys_set_poll_mem"
external get_poll_mem : poll_mem -> int -> (Unix.file_descr * int * int)
= "netsys_get_poll_mem"
external blit_poll_mem : poll_mem -> int -> poll_mem -> int -> int -> unit
= "netsys_blit_poll_mem"
external poll_constants : unit -> int array = "netsys_poll_constants"
let the_poll_constants = poll_constants()
let const_rd_event = the_poll_constants.(0)
let const_pri_event = the_poll_constants.(1)
let const_wr_event = the_poll_constants.(2)
let const_err_event = the_poll_constants.(3)
let const_hup_event = the_poll_constants.(4)
let const_nval_event = the_poll_constants.(5)
let poll_req_events rd wr pri =
(if rd then const_rd_event else 0) lor
(if wr then const_wr_event else 0) lor
(if pri then const_pri_event else 0)
let poll_req_triple p =
(p land const_rd_event <> 0,
p land const_wr_event <> 0,
p land const_pri_event <> 0
)
let poll_null_events() = 0
let poll_result p = p <> 0
let poll_rd_result p = p land const_rd_event <> 0
let poll_wr_result p = p land const_wr_event <> 0
let poll_pri_result p = p land const_pri_event <> 0
let poll_err_result p = p land const_err_event <> 0
let poll_hup_result p = p land const_hup_event <> 0
let poll_nval_result p = p land const_nval_event <> 0
let poll_array_length =
function
| Poll_mem(_,n) -> n
| Poll_emu e -> Array.length e
let set_poll_cell a k c =
if k < 0 || k >= poll_array_length a then
invalid_arg "Netsys.set_poll_cell";
match a with
| Poll_mem(s,_) ->
set_poll_mem s k c.poll_fd c.poll_req_events (* c.poll_revents *) 0
| Poll_emu e ->
e.(k) <- { c with poll_fd = c.poll_fd } (* copy *)
let get_poll_cell a k =
if k < 0 || k >= poll_array_length a then
invalid_arg "Netsys.get_poll_cell";
match a with
| Poll_mem(s,_) ->
let (fd, ev, rev) = get_poll_mem s k in
{ poll_fd = fd; poll_req_events = ev; poll_act_events = rev }
| Poll_emu e ->
let c = e.(k) in
{ c with poll_fd = c.poll_fd } (* copy *)
let blit_poll_array a1 k1 a2 k2 len =
let l1 = poll_array_length a1 in
let l2 = poll_array_length a2 in
if len < 0 || k1 < 0 || k1+len > l1 || k2 < 0 || k2+len > l2 then
invalid_arg "Netsys.get_poll_cell";
match (a1, a2) with
| (Poll_mem(s1,_), Poll_mem(s2,_)) ->
blit_poll_mem s1 k1 s2 k2 len
| (Poll_emu e1, Poll_emu e2) ->
Array.blit e1 k1 e2 k2 len
| _ ->
assert false
let create_poll_array n =
if _have_poll then (
let s = mk_poll_mem n in
Poll_mem(s,n)
)
else (
let e = Array.make n null_poll_cell in
Poll_emu e
)
external netsys_poll : poll_mem -> int -> int -> int = "netsys_poll"
let concat_fd_list l =
String.concat ","
(List.map
(fun fd ->
Int64.to_string(int64_of_file_descr fd))
l
)
(* win32 only: *)
external netsys_real_select :
Unix.file_descr list ->
Unix.file_descr list ->
Unix.file_descr list ->
float ->
(Unix.file_descr list * Unix.file_descr list * Unix.file_descr list)
= "netsys_real_select"
let real_select =
if Sys.os_type = "Win32" then
netsys_real_select
else
Unix.select
let do_poll a k tmo =
match a with
| Poll_mem(s,_) ->
netsys_poll s k tmo
| Poll_emu e ->
(* Emulate poll using Unix.select. This is slow! *)
let tmo' =
if tmo < 0 then (-1.0) else float tmo *. 0.001 in
let l_inp = ref [] in
let l_out = ref [] in
let l_pri = ref [] in
for j = 0 to k-1 do
let c = e.(j) in
let (f_inp, f_out, f_pri) = poll_req_triple c.poll_req_events in
if f_inp then l_inp := c.poll_fd :: !l_inp;
if f_out then l_out := c.poll_fd :: !l_out;
if f_pri then l_pri := c.poll_fd :: !l_pri;
done;
dlogr (fun () ->
sprintf "poll_emulation request in=%s out=%s pri=%s tmo=%f"
(concat_fd_list !l_inp)
(concat_fd_list !l_out)
(concat_fd_list !l_pri)
tmo');
let (o_inp, o_out, o_pri) =
real_select !l_inp !l_out !l_pri tmo' in
dlogr (fun () ->
sprintf "poll_emulation result in=%s out=%s pri=%s"
(concat_fd_list o_inp)
(concat_fd_list o_out)
(concat_fd_list o_pri));
let a_inp = Array.of_list o_inp in
let a_out = Array.of_list o_out in
let a_pri = Array.of_list o_pri in
Array.sort Pervasives.compare a_inp;
Array.sort Pervasives.compare a_out;
Array.sort Pervasives.compare a_pri;
let n = ref 0 in
for j = 0 to k-1 do
let c = e.(j) in
let g_inp = Netsys_impl_util.mem_sorted_array c.poll_fd a_inp in
let g_out = Netsys_impl_util.mem_sorted_array c.poll_fd a_out in
let g_pri = Netsys_impl_util.mem_sorted_array c.poll_fd a_pri in
let rev =
(if g_inp then const_rd_event else 0) lor
(if g_out then const_wr_event else 0) lor
(if g_pri then const_pri_event else 0) in
c.poll_act_events <- rev;
if rev <> 0 then incr n
done;
!n
let poll a k tmo =
if k < 0 || k > poll_array_length a then
invalid_arg "Netsys.poll";
let r =
Netsys_impl_util.slice_time_ms
(fun tmo0 ->
(* tmo0 is now an int in milliseconds *)
let n = do_poll a k tmo0 in
if n = 0 then None else Some n
)
tmo in
match r with
| None -> 0
| Some n -> n
let restarting_poll a k tmo =
Netsys_impl_util.restart_tmo (poll a k) tmo
let poll_single fd r w pri tmo =
let a = create_poll_array 1 in
set_poll_cell a 0 { poll_fd = fd;
poll_req_events = poll_req_events r w pri;
poll_act_events = poll_null_events()
};
poll a 1 tmo > 0
let act_events_of_int n = n
let int_of_act_events n = n
let req_events_of_int n = n
let int_of_req_events n = n
(* poll aggregation *)
type netsys_event_source
type netsys_event_aggreg
type tagged_event =
| EV_FD of Unix.file_descr
type event_push =
{ event_id : int;
event_tag : tagged_event;
event_api_req : int;
}
class type event_source =
object
method event_id : int
method event_tag : tagged_event
method push_record : event_push
method need_push : bool
method post_poll : int -> int -> unit
method upd_kernel_events : int -> unit
method set_post_modify_callback : (int -> unit) -> unit
method clear_post_modify_callback : unit -> unit
method modify_fd_event_source : int -> unit
method act_events : int
end
class fd_event_source fd req : event_source =
let event_id = ref 0 in
let event_api_req = ref req in
let event_kernel_req = ref 0 in
let event_tag = EV_FD fd in
let act_events = ref 0 in
let post_modify_callback = ref None in
object(self)
initializer (
let id = Oo.id self in
event_id := id
)
method event_id = !event_id
method event_tag = event_tag
method push_record =
{ event_id = !event_id;
event_tag = event_tag;
event_api_req= !event_api_req
}
method need_push = !event_api_req <> !event_kernel_req
method upd_kernel_events req =
event_kernel_req := req;
method post_poll mask act =
event_kernel_req := !event_kernel_req land mask;
act_events := act
method set_post_modify_callback f =
match !post_modify_callback with
| None -> post_modify_callback := Some f
| Some _ ->
failwith "Netsys_posix.add_event_source: the source is already \
added to an aggregator"
method clear_post_modify_callback () =
post_modify_callback := None
method modify_fd_event_source req =
event_api_req := req;
match !post_modify_callback with
| Some f -> f !event_id
| None -> ()
method act_events = !act_events
end
let fd_event_source fd req =
new fd_event_source fd req
let modify_fd_event_source es req =
es # modify_fd_event_source req
let get_fd_of_event_source es =
match es # event_tag with
| EV_FD fd -> fd
let act_events_of_event_source es =
es # act_events
external have_event_aggregation : unit -> bool
= "netsys_have_event_aggregation"
external netsys_create_event_aggreg :
bool -> netsys_event_aggreg
= "netsys_create_event_aggreg"
external netsys_destroy_event_aggreg :
netsys_event_aggreg -> unit
= "netsys_destroy_event_aggreg"
external netsys_event_aggreg_fd :
netsys_event_aggreg -> Unix.file_descr
= "netsys_event_aggreg_fd"
external netsys_push_event_sources :
netsys_event_aggreg -> event_push list -> unit
= "netsys_push_event_sources"
external netsys_add_event_source :
netsys_event_aggreg -> event_push -> unit
= "netsys_add_event_source"
external netsys_del_event_source :
netsys_event_aggreg -> int -> tagged_event -> unit
= "netsys_del_event_source"
external netsys_poll_event_sources :
netsys_event_aggreg -> int -> (int * int * int) list
(* The list are triples (event_id, mask, act) *)
= "netsys_poll_event_sources"
external netsys_interrupt_aggreg :
netsys_event_aggreg -> unit
= "netsys_interrupt_aggreg"
class event_aggregator is_interruptible =
let up = ref true in
let all_sources = Hashtbl.create 27 in
let upd_sources = Hashtbl.create 27 in
let netsys = netsys_create_event_aggreg is_interruptible in
let check_up() =
if not !up then
failwith "Netsys_posix: This event_aggregator is already destroyed" in
object(self)
method add_event_source (es : event_source) =
check_up();
es # set_post_modify_callback self#post_modify_callback;
try
netsys_add_event_source netsys es#push_record;
Hashtbl.replace all_sources es#event_id es;
Hashtbl.replace upd_sources es#event_id es
with
| error ->
es # clear_post_modify_callback();
raise error
method del_event_source (es : event_source) =
check_up();
if not(Hashtbl.mem all_sources es#event_id) then
failwith "Netsys_posix.del_event_source: not member of this aggregator";
netsys_del_event_source netsys es#event_id es#event_tag;
es # clear_post_modify_callback();
Hashtbl.remove all_sources es#event_id;
Hashtbl.remove upd_sources es#event_id
method post_modify_callback id =
check_up();
if (Hashtbl.mem all_sources id) then (
let es = Hashtbl.find all_sources id in
Hashtbl.replace upd_sources id es
)
method push_event_updates() =
check_up();
let l =
Hashtbl.fold
(fun _ es acc ->
if es # need_push then
let p = es#push_record in
es # upd_kernel_events p.event_api_req;
p :: acc
else
acc
)
upd_sources
[] in
netsys_push_event_sources netsys l;
Hashtbl.clear upd_sources
method poll_event_sources tmo =
self # push_event_updates();
let v =
Netsys_impl_util.slice_time_ms
(fun millis ->
let evpairs0 = netsys_poll_event_sources netsys millis in
let evpairs1 = (* without spurious events *)
List.filter
(fun (id,_,_) ->
Hashtbl.mem all_sources id
)
evpairs0 in
let evpairs2 =
List.map
(fun (id,mask,act) ->
let es = Hashtbl.find all_sources id in
es#post_poll mask act;
Hashtbl.replace upd_sources id es;
es
)
evpairs1 in
if evpairs2 = [] then
None
else
Some evpairs2
)
tmo in
match v with
| None -> []
| Some l -> l
method event_aggregator_fd =
check_up();
netsys_event_aggreg_fd netsys
method interrupt_event_aggregator() =
netsys_interrupt_aggreg netsys
method destroy_event_aggregator () =
if !up then (
netsys_destroy_event_aggreg netsys;
up := false
)
end
let create_event_aggregator = new event_aggregator
let add_event_source ea = ea # add_event_source
let del_event_source ea = ea # del_event_source
let push_event_updates ea = ea # push_event_updates()
let poll_event_sources (ea : event_aggregator) = ea # poll_event_sources
let event_aggregator_fd ea = ea # event_aggregator_fd
let destroy_event_aggregator ea = ea # destroy_event_aggregator()
let interrupt_event_aggregator ea = ea # interrupt_event_aggregator()
(* events *)
type not_event
external nsys_create_event : bool -> not_event = "netsys_create_not_event"
external set_nonblock_event : not_event -> unit = "netsys_set_nonblock_not_event"
external get_event_fd : not_event -> Unix.file_descr = "netsys_get_not_event_fd"
external set_event : not_event -> unit = "netsys_set_not_event"
external wait_event : not_event -> unit = "netsys_wait_not_event"
external consume_event : not_event -> unit = "netsys_consume_not_event"
external nsys_destroy_event : not_event -> unit = "netsys_destroy_not_event"
external nsys_return_all_event_fd : not_event -> Unix.file_descr list
= "netsys_return_all_not_event_fd"
let create_event() =
let e = nsys_create_event true in
List.iter
(fun fd ->
Netlog.Debug.track_fd
~owner:"Netsys_posix"
~descr:"create_event"
fd;
)
(nsys_return_all_event_fd e);
e
let destroy_event e =
List.iter
(fun fd ->
Netlog.Debug.release_fd fd;
)
(nsys_return_all_event_fd e);
nsys_destroy_event e
let report_signal_as_event ne signum =
(* This is simpler to implement in Ocaml than in C:
- [ne] is kept reachable all the time
- we can pass [ne] to the handler via a closure
- we can run non-async-signal-safe stuff in Ocaml signal handlers,
because they are actually called indirectly
*)
Sys.set_signal
signum
(Sys.Signal_handle
(fun _ ->
set_event ne
)
)
(* post fork handlers *)
class type post_fork_handler =
object
method name : string
method run : unit -> unit
end
module PFH = struct
type t = post_fork_handler
let compare = Pervasives.compare
end
module PFH_Set = Set.Make(PFH)
let post_fork_registry = ref PFH_Set.empty
let post_fork_mutex = !Netsys_oothr.provider # create_mutex()
let register_post_fork_handler pfh =
post_fork_mutex # lock();
post_fork_registry := PFH_Set.add pfh !post_fork_registry;
post_fork_mutex # unlock()
let remove_post_fork_handler pfh =
post_fork_mutex # lock();
post_fork_registry := PFH_Set.remove pfh !post_fork_registry;
post_fork_mutex # unlock()
let run_post_fork_handlers() =
PFH_Set.iter
(fun pfh ->
try pfh#run()
with
| error ->
prerr_endline("Netsys_posix: Exception in post fork handler "
^ pfh#name ^ ": " ^ Netexn.to_string error)
)
!post_fork_registry
(* "at" *)
type at_flag = AT_EACCESS | AT_SYMLINK_NOFOLLOW | AT_SYMLINK_FOLLOW |
AT_REMOVEDIR
(* The stubs assume these type definitions: *)
#ifdef HAVE_O_CLOEXEC
type open_flag1 = Unix.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 | O_SHARE_DELETE
| O_CLOEXEC
#else
#ifdef HAVE_O_SHARE_DELETE
type open_flag1 = Unix.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 | O_SHARE_DELETE
#else
type open_flag1 = Unix.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
#endif
#endif
type access_permission1 = Unix.access_permission =
R_OK | W_OK | X_OK | F_OK
external netsys_at_fdcwd : unit -> Unix.file_descr =
"netsys_at_fdcwd"
let at_fdcwd = netsys_at_fdcwd()
external have_at : unit -> bool
= "netsys_have_at"
external openat : Unix.file_descr -> string -> Unix.open_flag list ->
Unix.file_perm -> Unix.file_descr
= "netsys_openat"
external faccessat : Unix.file_descr -> string -> Unix.access_permission list ->
at_flag list -> unit
= "netsys_faccessat"
external mkdirat : Unix.file_descr -> string -> int -> unit
= "netsys_mkdirat"
external renameat : Unix.file_descr -> string -> Unix.file_descr -> string ->
unit
= "netsys_renameat"
external linkat : Unix.file_descr -> string -> Unix.file_descr -> string ->
at_flag list -> unit
= "netsys_linkat"
external unlinkat : Unix.file_descr -> string -> at_flag list -> unit
= "netsys_unlinkat"
external symlinkat : string -> Unix.file_descr -> string -> unit
= "netsys_symlinkat"
external mkfifoat : Unix.file_descr -> string -> int -> unit
= "netsys_mkfifoat"
external readlinkat : Unix.file_descr -> string -> string
= "netsys_readlinkat"
(* Clocks *)
type timespec = float * int
type clock_id
type clock =
| CLOCK_REALTIME
| CLOCK_MONOTONIC
| CLOCK_ID of clock_id
external nanosleep : timespec -> timespec ref -> unit = "netsys_nanosleep"
external clock_gettime : clock -> timespec = "netsys_clock_gettime"
external clock_settime : clock -> timespec -> unit = "netsys_clock_settime"
external clock_getres : clock -> timespec = "netsys_clock_getres"
external clock_getcpuclockid : int -> clock_id = "netsys_clock_getcpuclockid"
type timer_expiration =
| TEXP_NONE
| TEXP_EVENT of not_event
| TEXP_EVENT_CREATE
| TEXP_SIGNAL of int
type posix_timer
external have_posix_timer : unit -> bool
= "netsys_have_posix_timer"
external nsys_timer_create : clock -> timer_expiration -> posix_timer
= "netsys_timer_create"
external timer_settime : posix_timer -> bool -> timespec -> timespec -> unit
= "netsys_timer_settime"
external timer_gettime : posix_timer -> timespec
= "netsys_timer_gettime"
external timer_delete : posix_timer -> unit
= "netsys_timer_delete"
external timer_event : posix_timer -> not_event
= "netsys_timer_event"
let timer_create clock texp =
let v = nsys_timer_create clock texp in
Gc.finalise timer_delete v;
v
(* Spawn *)
type wd_spec =
| Wd_keep
| Wd_chdir of string
| Wd_fchdir of Unix.file_descr
type pg_spec =
| Pg_keep
| Pg_new_bg_group
| Pg_new_fg_group
| Pg_join_group of int
type fd_action =
| Fda_close of Unix.file_descr
| Fda_close_ignore of Unix.file_descr
| Fda_close_except of bool array
| Fda_dup2 of Unix.file_descr * Unix.file_descr
type sig_action =
| Sig_default of int
| Sig_ignore of int
| Sig_mask of int list
external netsys_spawn : wd_spec -> pg_spec -> fd_action list ->
sig_action list -> string array ->
string -> string array -> int
= "netsys_spawn_byte" "netsys_spawn_nat"
external netsys_posix_spawn : pg_spec -> fd_action list ->
sig_action list -> string array ->
string -> string array -> int
= "netsys_posix_spawn_byte" "netsys_posix_spawn_nat"
external have_posix_spawn : unit -> bool
= "netsys_have_posix_spawn"
let spawn ?(chdir = Wd_keep) ?(pg = Pg_keep) ?(fd_actions = [])
?(sig_actions = []) ?(env = Unix.environment())
?(no_posix_spawn=false) cmd args =
(* Check whether we can use the faster netsys_posix_spawn *)
let use_posix_spawn =
not no_posix_spawn &&
have_posix_spawn() &&
chdir = Wd_keep &&
pg <> Pg_new_fg_group &&
not (List.exists
(fun sa -> match sa with Sig_ignore _ -> true | _ -> false)
sig_actions) in
try
if not use_posix_spawn then
failwith "USE_FORK_EXEC";
netsys_posix_spawn pg fd_actions sig_actions env cmd args
(* may also fail with "USE_FORK_EXEC" in some cases *)
with
| Failure "USE_FORK_EXEC" ->
(* Fixup: if pg = Pg_new_fg_group, we remove any Sig_default for
SIGTTOU from sig_actions. Because of special handling, the effect
of Sig_default is enforced by the implementation, but this must be
done at [execve] time.
*)
let sig_actions =
if pg = Pg_new_fg_group then
List.filter
(fun spec -> spec <> Sig_default Sys.sigttou)
sig_actions
else
sig_actions in
netsys_spawn chdir pg fd_actions sig_actions env cmd args
type watched_subprocess =
{ atom_idx : int;
mutable alive : bool;
mutable allocated : bool;
}
external netsys_watch_subprocess : int -> int -> bool -> Unix.file_descr * int
= "netsys_watch_subprocess"
external netsys_ignore_subprocess : int -> unit
= "netsys_ignore_subprocess"
external netsys_forget_subprocess : int -> unit
= "netsys_forget_subprocess"
external netsys_get_subprocess_status : int -> Unix.process_status option
= "netsys_get_subprocess_status"
external install_subprocess_handler : unit -> unit
= "netsys_install_sigchld_handler"
external subprocess_cleanup_after_fork : unit -> unit
= "netsys_subprocess_cleanup_after_fork"
external netsys_kill_subprocess : int -> int -> unit
= "netsys_kill_subprocess"
external netsys_killpg_subprocess : int -> int -> unit
= "netsys_killpg_subprocess"
external kill_all_subprocesses : int -> bool -> bool -> unit
= "netsys_kill_all_subprocesses"
external killpg_all_subprocesses : int -> bool -> unit
= "netsys_killpg_all_subprocesses"
let forget_subprocess ws =
if ws.allocated then (
netsys_forget_subprocess ws.atom_idx;
ws.allocated <- false;
);
ws.alive <- false
let watch_subprocess pid pgid kill_flag =
if pid <= 0 || pgid < 0 then
invalid_arg "Netsys_posix.watch_subprocess";
let fd, atom_idx = netsys_watch_subprocess pid pgid kill_flag in
let ws = { atom_idx = atom_idx; alive = true; allocated = true } in
Gc.finalise forget_subprocess ws;
(fd, ws)
let ignore_subprocess ws =
if not ws.alive then
failwith "Netsys_posix.ignore_subprocess: stale reference";
netsys_ignore_subprocess ws.atom_idx;
ws.alive <- false
let get_subprocess_status ws =
if not ws.alive then
failwith "Netsys_posix.get_subprocess_status: stale reference";
netsys_get_subprocess_status ws.atom_idx
let kill_subprocess signal ws =
if ws.alive then
netsys_kill_subprocess signal ws.atom_idx
let killpg_subprocess signal ws =
if ws.alive then
netsys_killpg_subprocess signal ws.atom_idx
let () =
register_post_fork_handler
( object
method name = "subprocess_cleanup_after_fork"
method run = subprocess_cleanup_after_fork
end
)
let register_subprocess_handler() =
Netsys_signal.register_exclusive_handler
~name:"Sigchld handler in Netsys_posix"
~signal:Sys.sigchld
~install:install_subprocess_handler
()
(* locales *)
type langinfo =
{ nl_CODESET : string;
nl_D_T_FMT : string;
nl_D_FMT : string;
nl_T_FMT : string;
nl_T_FMT_AMPM : string;
nl_AM_STR : string;
nl_PM_STR : string;
nl_DAY_1 : string;
nl_DAY_2 : string;
nl_DAY_3 : string;
nl_DAY_4 : string;
nl_DAY_5 : string;
nl_DAY_6 : string;
nl_DAY_7 : string;
nl_ABDAY_1 : string;
nl_ABDAY_2 : string;
nl_ABDAY_3 : string;
nl_ABDAY_4 : string;
nl_ABDAY_5 : string;
nl_ABDAY_6 : string;
nl_ABDAY_7 : string;
nl_MON_1 : string;
nl_MON_2 : string;
nl_MON_3 : string;
nl_MON_4 : string;
nl_MON_5 : string;
nl_MON_6 : string;
nl_MON_7 : string;
nl_MON_8 : string;
nl_MON_9 : string;
nl_MON_10 : string;
nl_MON_11 : string;
nl_MON_12 : string;
nl_ABMON_1 : string;
nl_ABMON_2 : string;
nl_ABMON_3 : string;
nl_ABMON_4 : string;
nl_ABMON_5 : string;
nl_ABMON_6 : string;
nl_ABMON_7 : string;
nl_ABMON_8 : string;
nl_ABMON_9 : string;
nl_ABMON_10 : string;
nl_ABMON_11 : string;
nl_ABMON_12 : string;
nl_ERA : string;
nl_ERA_D_FMT : string;
nl_ERA_D_T_FMT : string;
nl_ERA_T_FMT : string;
nl_ALT_DIGITS : string;
nl_RADIXCHAR : string;
nl_THOUSEP : string;
nl_YESEXPR : string;
nl_NOEXPR : string;
nl_CRNCYSTR : string;
}
external netsys_query_langinfo : string -> langinfo = "netsys_query_langinfo"
let cached_langinfo = ref None
let query_langinfo locale =
if locale = "" then (
match !cached_langinfo with
| None ->
let li = netsys_query_langinfo "" in
cached_langinfo := Some li;
li
| Some li -> li
)
else
netsys_query_langinfo locale
(* syslog *)
type level = Netlog.level
type m_level =
| LOG_EMERG | LOG_ALERT | LOG_CRIT | LOG_ERR | LOG_WARNING
| LOG_NOTICE | LOG_INFO | LOG_DEBUG
let trans_level =
[ `Emerg, LOG_EMERG;
`Alert, LOG_ALERT;
`Crit, LOG_CRIT;
`Err, LOG_ERR;
`Warning, LOG_WARNING;
`Notice, LOG_NOTICE;
`Info, LOG_INFO;
`Debug, LOG_DEBUG
]
type syslog_facility =
[ `Authpriv
| `Cron
| `Daemon
| `Ftp
| `Kern
| `Local0
| `Local1
| `Local2
| `Local3
| `Local4
| `Local5
| `Local6
| `Local7
| `Lpr
| `Mail
| `News
| `Syslog
| `User
| `Uucp
| `Default
]
type m_syslog_facility =
| LOG_AUTHPRIV
| LOG_CRON
| LOG_DAEMON
| LOG_FTP
| LOG_KERN
| LOG_LOCAL0
| LOG_LOCAL1
| LOG_LOCAL2
| LOG_LOCAL3
| LOG_LOCAL4
| LOG_LOCAL5
| LOG_LOCAL6
| LOG_LOCAL7
| LOG_LPR
| LOG_MAIL
| LOG_NEWS
| LOG_SYSLOG
| LOG_USER
| LOG_UUCP
| LOG_DEFAULT
let trans_facility =
[ `Authpriv, LOG_AUTHPRIV;
`Cron, LOG_CRON;
`Daemon, LOG_DAEMON;
`Ftp, LOG_FTP;
`Kern, LOG_KERN;
`Local0, LOG_LOCAL0;
`Local1, LOG_LOCAL1;
`Local2, LOG_LOCAL2;
`Local3, LOG_LOCAL3;
`Local4, LOG_LOCAL4;
`Local5, LOG_LOCAL5;
`Local6, LOG_LOCAL6;
`Local7, LOG_LOCAL7;
`Lpr, LOG_LPR;
`Mail, LOG_MAIL;
`News, LOG_NEWS;
`Syslog, LOG_SYSLOG;
`User, LOG_USER;
`Uucp, LOG_UUCP;
`Default, LOG_DEFAULT;
]
type syslog_option =
[ `Cons
| `Ndelay
| `Odelay
| `Nowait
| `Pid
]
type m_syslog_option =
| LOG_CONS
| LOG_NDELAY
| LOG_ODELAY
| LOG_NOWAIT
| LOG_PID
let trans_syslog_option =
[ `Cons, LOG_CONS;
`Ndelay, LOG_NDELAY;
`Odelay, LOG_ODELAY;
`Nowait, LOG_NOWAIT;
`Pid, LOG_PID;
]
external netsys_openlog :
string option -> m_syslog_option list -> m_syslog_facility -> unit
= "netsys_openlog"
external netsys_syslog :
m_syslog_facility -> m_level -> string -> unit
= "netsys_syslog"
external netsys_closelog : unit -> unit = "netsys_closelog"
let openlog id_opt opts fac =
try
netsys_openlog
id_opt
( List.map
(fun p -> List.assoc p trans_syslog_option)
opts
)
( List.assoc fac trans_facility )
with
| Not_found -> assert false
let syslog fac lev msg =
try
netsys_syslog
( List.assoc fac trans_facility )
( List.assoc lev trans_level )
msg
with
| Not_found -> assert false
let closelog = netsys_closelog
(* Sync *)
external fsync : Unix.file_descr -> unit = "netsys_fsync"
external fdatasync : Unix.file_descr -> unit = "netsys_fdatasync"
(* Optional POSIX functions *)
external have_fadvise : unit -> bool = "netsys_have_posix_fadvise"
type advice =
| POSIX_FADV_NORMAL
| POSIX_FADV_SEQUENTIAL
| POSIX_FADV_RANDOM
| POSIX_FADV_NOREUSE
| POSIX_FADV_WILLNEED
| POSIX_FADV_DONTNEED
| FADV_NORMAL
| FADV_SEQUENTIAL
| FADV_RANDOM
| FADV_NOREUSE
| FADV_WILLNEED
| FADV_DONTNEED
external fadvise : Unix.file_descr -> int64 -> int64 -> advice -> unit
= "netsys_fadvise"
external have_fallocate : unit -> bool = "netsys_have_posix_fallocate"
external fallocate : Unix.file_descr -> int64 -> int64 -> unit
= "netsys_fallocate"
(* POSIX shared memory *)
external have_posix_shm : unit -> bool = "netsys_have_posix_shm"
type shm_open_flag =
| SHM_O_RDONLY
| SHM_O_RDWR
| SHM_O_CREAT
| SHM_O_EXCL
| SHM_O_TRUNC
external shm_open : string -> shm_open_flag list -> int -> file_descr
= "netsys_shm_open"
external shm_unlink : string -> unit = "netsys_shm_unlink"
let shm_create prefix size =
let pid = Unix.getpid() in
let t = Unix.gettimeofday() in
let rec loop n =
let id = sprintf "%d/%f/%d" pid t n in
let dg = Digest.to_hex (Digest.string id) in
let dg8 = String.sub dg 0 8 in
let name = sprintf "%s_%s" prefix dg8 in
try
let fd =
shm_open
name [SHM_O_RDWR; SHM_O_CREAT; SHM_O_EXCL ] 0o600 in
( try Unix.fchmod fd 0o600
with Unix.Unix_error(Unix.EINVAL,_,_) -> ()
(* OSX seems to throw EINVAL here *)
);
if size > 0 then
Unix.ftruncate fd size;
(fd, name)
with
| Unix.Unix_error(Unix.EEXIST,_,_) ->
loop (n+1) in
loop 0
type sem_kind = [ `Named | `Anonymous ]
type sem_rep
type 'sem_kind semaphore =
Netsys_types.memory * sem_rep
(* We keep a reference to the bigarray to prevent that it is
collected while a semaphore is stored in it
*)
type named_semaphore = [ `Named ] semaphore
type anon_semaphore = [ `Anonymous ] semaphore
type sem_open_flag =
| SEM_O_CREAT
| SEM_O_EXCL
type sem_wait_behavior =
| SEM_WAIT_BLOCK
| SEM_WAIT_NONBLOCK
let dummy_mem =
Bigarray.Array1.create Bigarray.char Bigarray.c_layout 0
external have_anon_posix_semaphores : unit -> bool
= "netsys_have_sem_anon"
external have_named_posix_semaphores : unit -> bool
= "netsys_have_sem_named"
let have_posix_semaphores() =
have_anon_posix_semaphores() && have_named_posix_semaphores()
external netsys_sem_size : unit -> int
= "netsys_sem_size"
external netsys_sem_value_max : unit -> int
= "netsys_sem_value_max"
let sem_size = netsys_sem_size()
let sem_value_max = netsys_sem_value_max()
external netsys_sem_open :
string -> sem_open_flag list -> int -> int -> sem_rep
= "netsys_sem_open"
let sem_open name flags mode init_value =
if init_value < 0 || init_value > sem_value_max then
invalid_arg "Netsys_posix.sem_open";
let sr = netsys_sem_open name flags mode init_value in
(dummy_mem, sr)
external netsys_sem_close : sem_rep -> unit
= "netsys_sem_close"
let sem_close (_,sr) = netsys_sem_close sr
external sem_unlink : string -> unit
= "netsys_sem_unlink"
let sem_create prefix initval =
let pid = Unix.getpid() in
let t = Unix.gettimeofday() in
let rec loop n =
let id = sprintf "%d/%f/%d" pid t n in
let dg = Digest.to_hex (Digest.string id) in
let dg8 = String.sub dg 0 8 in
let name = sprintf "%s_%s" prefix dg8 in
try
let sem =
sem_open
name [SEM_O_CREAT; SEM_O_EXCL] 0o600 initval in
(sem, name)
with
| Unix.Unix_error(Unix.EEXIST,_,_) ->
loop (n+1) in
loop 0
external netsys_sem_init :
Netsys_types.memory -> int -> bool -> int -> sem_rep
= "netsys_sem_init"
let sem_init mem pos pshared init_value =
if pos < 0 || pos > Bigarray.Array1.dim mem - sem_size then
invalid_arg "Netsys_posix.sem_init";
if init_value < 0 || init_value > sem_value_max then
invalid_arg "Netsys_posix.sem_init";
let sr = netsys_sem_init mem pos pshared init_value in
(mem,sr)
external netsys_as_sem : Netsys_types.memory -> int -> sem_rep
= "netsys_as_sem"
let as_sem mem pos =
if pos < 0 || pos > Bigarray.Array1.dim mem - sem_size then
invalid_arg "Netsys_posix.as_sem";
let sr = netsys_as_sem mem pos in
(mem,sr)
external netsys_sem_destroy : sem_rep -> unit
= "netsys_sem_destroy"
let sem_destroy (_,sr) = netsys_sem_destroy sr
external netsys_sem_getvalue : sem_rep -> int
= "netsys_sem_getvalue"
let sem_getvalue (_,sr) = netsys_sem_getvalue sr
external netsys_sem_post : sem_rep -> unit
= "netsys_sem_post"
let sem_post (_,sr) = netsys_sem_post sr
external netsys_sem_wait : sem_rep -> sem_wait_behavior -> unit
= "netsys_sem_wait"
let sem_wait (_,sr) b = netsys_sem_wait sr b
type ioprio_target =
| Ioprio_process of int
| Ioprio_pgrp of int
| Ioprio_user of int
type ioprio =
| Noprio
| Real_time of int
| Best_effort of int
| Idle
external ioprio_get : ioprio_target -> ioprio = "netsys_ioprio_get"
external ioprio_set : ioprio_target -> ioprio -> unit = "netsys_ioprio_set"
let have_ioprio() =
try let _ = ioprio_get(Ioprio_process(Unix.getpid())) in true
with _ -> false
