(* $Id: netsys_posix.ml 1998 2014-08-24 20:41:09Z 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_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