patrick.sirref.org
Shells in OCaml
1let cwd () = Eio_unix.run_in_systhread ~label:"cwd" @@ fun () -> Unix.getcwd ()
2
3let env () =
4 Eio_unix.run_in_systhread ~label:"env" @@ fun () ->
5 Unix.environment ()
6 |> Array.map (Astring.String.cut ~sep:"=")
7 |> Array.to_list |> List.filter_map Fun.id
8
9let find_env k = env () |> List.assoc_opt k
10
11let put_env ~key ~value =
12 Eio_unix.run_in_systhread ~label:"put_env" @@ fun () -> Unix.putenv key value
13
14let get_user_and_host fs =
15 let passwd =
16 Eio.Path.(load (fs / "/etc/passwd"))
17 |> String.split_on_char '\n'
18 |> List.map (String.split_on_char ':')
19 in
20 let uid = Unix.getuid () in
21 let username =
22 List.find_map
23 (function
24 | name :: _ :: m :: _ ->
25 if int_of_string m = uid then Some name else None
26 | _ -> None)
27 passwd
28 in
29 let name = Option.value ~default:"?" username in
30 let host = Unix.gethostname () in
31 Fmt.str "%s@%s" name host
32
33external getpgrp : unit -> int = "caml_merry_getpgrp"
34external tcgetpgrp : Unix.file_descr -> int = "caml_merry_tcgetpgrp"
35external tcsetpgrp : int -> int -> int = "caml_merry_tcsetpgrp"
36
37let delegate_control ~pgid fn =
38 let shell_pid = Unix.getpid () in
39 Fun.protect
40 ~finally:(fun () ->
41 let _ : int = tcsetpgrp 0 shell_pid in
42 ())
43 (fun () ->
44 match tcsetpgrp (Obj.magic Unix.stdin : int) pgid with
45 | 0 -> fn ()
46 | n -> Fmt.failwith "tcsetpgrp: %i" n)
47
48external setpgrp : int -> int -> int = "caml_merry_setpgid"
49
50let make_process_group () =
51 let pgrp = getpgrp () in
52 let fg_prgp = tcgetpgrp Unix.stdin in
53 if Int.equal pgrp fg_prgp then
54 match setpgrp 0 0 with
55 | 0 -> ()
56 | _ -> assert false
57 | exception Unix.Unix_error (Unix.EPERM, _, _) -> ()
58
59let background () =
60 let _pgrid = Unix.getpid () in
61 ()
62
63let fd_of_int (fd : int) : Unix.file_descr = Obj.magic fd
64
65let with_redirections (rdrs : Types.redirect list) fn =
66 let saved_stdin = Unix.dup Unix.stdin in
67 let saved_stdout = Unix.dup Unix.stdout in
68 let saved_stderr = Unix.dup Unix.stderr in
69 List.iter
70 (function
71 | Types.Redirect (i, fd, _) ->
72 Eio_unix.Fd.use_exn "with_redirections" fd @@ fun fd ->
73 if (Obj.magic fd : int) <> i then Unix.dup2 fd (fd_of_int i)
74 | Types.Close fd -> Eio_unix.Fd.close fd)
75 rdrs;
76 Fun.protect
77 ~finally:(fun () ->
78 Unix.dup2 saved_stdin (fd_of_int 0);
79 Unix.dup2 saved_stdout (fd_of_int 1);
80 Unix.dup2 saved_stderr (fd_of_int 2);
81 Unix.close saved_stdin;
82 Unix.close saved_stdout;
83 Unix.close saved_stderr)
84 fn
85
86let with_stdin_in_raw_mode fn =
87 let saved_tio = Unix.tcgetattr Unix.stdin in
88 let tio =
89 {
90 saved_tio with
91 (* input modes *)
92 c_ignpar = true;
93 c_istrip = false;
94 c_inlcr = false;
95 c_igncr = false;
96 c_ixon = false;
97 (* c_ixany = false; *)
98 (* c_iuclc = false; *)
99 c_ixoff = false;
100 (* output modes *)
101 c_opost = true;
102 (* control modes *)
103 c_isig = false;
104 c_icanon = false;
105 c_echo = false;
106 c_echoe = false;
107 c_echok = false;
108 c_echonl = false;
109 (* c_iexten = false; *)
110
111 (* special characters *)
112 c_vmin = 1;
113 c_vtime = 0;
114 }
115 in
116 Unix.tcsetattr Unix.stdin TCSADRAIN tio;
117 Fun.protect
118 ~finally:(fun () -> Unix.tcsetattr Unix.stdin TCSADRAIN saved_tio)
119 fn
120
121module Signals = struct
122 type t =
123 | Interrupt
124 | Quit
125 | Abort
126 | Kill
127 | Alarm
128 | Terminate
129 | Exit
130 | Stop
131 | Hup
132 [@@deriving to_yojson]
133
134 let of_int = function
135 | i when Int.equal i Sys.sigint -> Interrupt
136 | i when Int.equal i Sys.sigquit -> Quit
137 | i when Int.equal i Sys.sigabrt -> Abort
138 | i when Int.equal i Sys.sigkill -> Kill
139 | i when Int.equal i Sys.sigalrm -> Alarm
140 | i when Int.equal i Sys.sigterm -> Terminate
141 | i when Int.equal i Sys.sigstop -> Stop
142 | i when Int.equal i Sys.sighup -> Hup
143 (* From the manpages *)
144 | 1 -> Hup
145 | 2 -> Interrupt
146 | 3 -> Quit
147 | 6 -> Abort
148 | 9 -> Kill
149 | 14 -> Alarm
150 | 15 -> Terminate
151 | m -> Fmt.invalid_arg "Signal %i not supported yet." m
152
153 let to_int = function
154 | Interrupt -> Sys.sigint
155 | Quit -> Sys.sigquit
156 | Abort -> Sys.sigabrt
157 | Kill -> Sys.sigkill
158 | Alarm -> Sys.sigalrm
159 | Terminate | Exit -> Sys.sigterm
160 | Stop -> Sys.sigstop
161 | Hup -> Sys.sighup
162
163 let of_string s =
164 match String.uppercase_ascii s with
165 | "SIGINT" | "INT" -> Interrupt
166 | "SIGQUIT" | "QUIT" -> Quit
167 | "SIGABRT" | "ABRT" -> Abort
168 | "SIGKILL" | "KILL" -> Kill
169 | "SIGALRM" | "ALRM" -> Alarm
170 | "SIGTERM" | "TERM" -> Terminate
171 | "SIGSTOP" | "STOP" -> Stop
172 | "SIGHUP" | "HUP" -> Hup
173 | m -> Fmt.invalid_arg "Signal %s not supported or recognised." m
174
175 let raise v = Unix.kill (Unix.getpid ()) (to_int v)
176end