diff --git a/example/dune b/example/dune new file mode 100644 index 0000000..e4cbe55 --- /dev/null +++ b/example/dune @@ -0,0 +1,3 @@ +(executable + (name main) + (libraries eio_posix)) diff --git a/example/main.ml b/example/main.ml new file mode 100644 index 0000000..e69de29 diff --git a/src/bin/main.ml b/src/bin/main.ml index a8514db..b5ce8ac 100644 --- a/src/bin/main.ml +++ b/src/bin/main.ml @@ -115,7 +115,7 @@ let cmd ~args ~other_flags env = |> List.sort (fun (i, _) (j, _) -> Int.compare i j) |> List.map snd in - let options = Merry.Built_ins.Options.(with_options ~errexit default) in + let options = Merry.Types.Options.(with_options ~errexit default) in sh ~command_flag ~dump ~file ~rest ~options env let main () = diff --git a/src/lib/built_ins.ml b/src/lib/built_ins.ml index 9378f15..9b6cda7 100644 --- a/src/lib/built_ins.ml +++ b/src/lib/built_ins.ml @@ -1,77 +1,16 @@ -module Options = struct - type t = { - noclobber : bool; - pipefail : bool; - errexit : bool; - no_path_expansion : bool; - no_unset : bool; - async : bool; - } - - let default = - { - noclobber = false; - pipefail = false; - errexit = false; - no_path_expansion = false; - no_unset = false; - async = false; - } - - let with_options ?noclobber ?pipefail ?errexit ?async ?no_path_expansion - ?no_unset t = - { - noclobber = Option.value ~default:t.noclobber noclobber; - pipefail = Option.value ~default:t.pipefail pipefail; - errexit = Option.value ~default:t.errexit errexit; - async = Option.value ~default:t.async async; - no_path_expansion = - Option.value ~default:t.no_path_expansion no_path_expansion; - no_unset = Option.value ~default:t.no_unset no_unset; - } - - type posix = [ `Noclobber | `Pipefail | `Noglob | `Nounset | `Errexit ] - type merry = [ `Async ] - type option = [ posix | merry ] - - let posix_to_letter = function `Noclobber -> "C" | _ -> "" - - let to_letters t = - let nc = if t.noclobber then posix_to_letter `Noclobber else "" in - nc ^ "" - - let update t options = - List.fold_left - (fun d -> function - | `Pipefail, pipefail -> with_options ~pipefail d - | `Noclobber, noclobber -> with_options ~noclobber d - | `Noglob, no_path_expansion -> with_options ~no_path_expansion d - | `Errexit, errexit -> with_options ~errexit d - | `Nounset, no_unset -> with_options ~no_unset d - | `Async, async -> with_options ~async d) - t options - - let pp ppf opt = - let pp_option ppf (name, value) = - Fmt.pf ppf "%-12s %s@." name (if value then "on" else "off") - in - let opts = - let { noclobber; pipefail; async; no_path_expansion; no_unset; errexit } = - opt - in - [ - ("pipefail", pipefail); - ("errexit", errexit); - ("noclobber", noclobber); - ("noglob", no_path_expansion); - ("nounset", no_unset); - ("async", async); - ] - in - Fmt.pf ppf "@[%a@]" Fmt.(list pp_option) opts -end +type set = { update : (Types.Options.option * bool) list; print_options : bool } + +let pp_set ppf { update; _ } = + let pp_opt ppf = function + | `Noclobber, true -> Fmt.string ppf "-o noclobber" + | `Pipefail, true -> Fmt.string ppf "-o pipefail" + | `Noglob, true -> Fmt.string ppf "-o noglob" + | `Nounset, true -> Fmt.string ppf "-o nounset" + | `Errexit, true -> Fmt.string ppf "-o errexit" + | _ -> Fmt.nop ppf () + in + Fmt.(list ~sep:(Fmt.any " ") pp_opt) ppf update -type set = { update : (Options.option * bool) list; print_options : bool } type hash = Hash_remove | Hash_stats | Hash_add of string list type trap = Int of int | Action of string | Ignore | Default @@ -90,7 +29,7 @@ type t = | Unalias | Eval of string list | Echo of string list - | Trap of trap * [ `Signal of Eunix.Signals.t | `Exit ] list + | Trap of trap * [ `Signal of Types.Signals.t | `Exit ] list | Return of int | Continue of int | Break of int @@ -132,7 +71,7 @@ let to_string = function | Action a -> a | Ignore -> "ignore" | Default -> "default") - | Set _ -> "set" + | Set set -> Fmt.str "set %a" pp_set set | Read (backslash, vars) -> Fmt.str "read%s %a" (if backslash then " -r" else " ") pp_args vars @@ -423,11 +362,11 @@ module Trap = struct try match int_of_string_opt s with | Some 0 -> Ok `Exit - | Some n -> Ok (`Signal (Eunix.Signals.of_int n)) + | Some n -> Ok (`Signal (Types.Signals.of_int n)) | None -> ( match s with | "exit" -> Ok `Exit - | s -> Ok (`Signal (Eunix.Signals.of_string s))) + | s -> Ok (`Signal (Types.Signals.of_string s))) with Invalid_argument m -> Error m in let pp _ppf _ = () in diff --git a/src/lib/built_ins.mli b/src/lib/built_ins.mli index 9207183..f69e412 100644 --- a/src/lib/built_ins.mli +++ b/src/lib/built_ins.mli @@ -1,36 +1,4 @@ -module Options : sig - type t = { - noclobber : bool; - pipefail : bool; - errexit : bool; - no_path_expansion : bool; - no_unset : bool; - async : bool; - } - - val to_letters : t -> string - - type posix = [ `Noclobber | `Pipefail | `Noglob | `Nounset | `Errexit ] - type merry = [ `Async ] - type option = [ posix | merry ] - - val default : t - - val with_options : - ?noclobber:bool -> - ?pipefail:bool -> - ?errexit:bool -> - ?async:bool -> - ?no_path_expansion:bool -> - ?no_unset:bool -> - t -> - t - - val update : t -> (option * bool) list -> t - val pp : t Fmt.t -end - -type set = { update : (Options.option * bool) list; print_options : bool } +type set = { update : (Types.Options.option * bool) list; print_options : bool } type hash = Hash_remove | Hash_stats | Hash_add of string list type trap = Int of int | Action of string | Ignore | Default @@ -49,7 +17,7 @@ type t = | Unalias | Eval of string list | Echo of string list - | Trap of trap * [ `Signal of Eunix.Signals.t | `Exit ] list + | Trap of trap * [ `Signal of Types.Signals.t | `Exit ] list | Return of int | Continue of int | Break of int diff --git a/src/lib/eunix.ml b/src/lib/eunix.ml index c803b6f..af0e2ed 100644 --- a/src/lib/eunix.ml +++ b/src/lib/eunix.ml @@ -62,6 +62,10 @@ let background () = let fd_of_int (fd : int) : Unix.file_descr = Obj.magic fd +let dup2 ?(cloexec = true) fd1 fd2 = + Eio_unix.Fd.use_exn "dup2-1" fd1 @@ fun ufd1 -> + Eio_unix.Fd.use_exn "dup2-2" fd2 @@ fun ufd2 -> Unix.dup2 ~cloexec ufd1 ufd2 + let with_redirections ?(restore = false) (rdrs : Types.redirect list) fn = let saved_stdin = Safe_fd.dup Unix.stdin in let saved_stdout = Safe_fd.dup Unix.stdout in @@ -69,7 +73,7 @@ let with_redirections ?(restore = false) (rdrs : Types.redirect list) fn = let restore_fds = List.filter_map (function - | Types.Parent_redirect (i, fd, _) -> + | Types.Parent_redirect (i, fd, _) | Types.Child_redirect (i, fd, _) -> Eio_unix.Fd.use_exn "with_redirections" fd @@ fun fd -> let new_fd = fd_of_int i in if (Obj.magic fd : int) <> i then begin @@ -83,8 +87,7 @@ let with_redirections ?(restore = false) (rdrs : Types.redirect list) fn = else None | Types.Close fd -> Eio_unix.Fd.close fd; - None - | Types.Child_redirect _ -> None) + None) (* | Types.Child_redirect _ -> (* None *)) *) rdrs in Fun.protect @@ -161,60 +164,3 @@ let resolve_program ?(update = true) ?path hash name = (hash, Some loc) | false, Some loc -> (hash, Some loc) | _, None -> (hash, None) - -module Signals = struct - type t = - | Interrupt - | Quit - | Abort - | Kill - | Alarm - | Terminate - | Exit - | Stop - | Hup - [@@deriving to_yojson] - - let of_int = function - | i when Int.equal i Sys.sigint -> Interrupt - | i when Int.equal i Sys.sigquit -> Quit - | i when Int.equal i Sys.sigabrt -> Abort - | i when Int.equal i Sys.sigkill -> Kill - | i when Int.equal i Sys.sigalrm -> Alarm - | i when Int.equal i Sys.sigterm -> Terminate - | i when Int.equal i Sys.sigstop -> Stop - | i when Int.equal i Sys.sighup -> Hup - (* From the manpages *) - | 1 -> Hup - | 2 -> Interrupt - | 3 -> Quit - | 6 -> Abort - | 9 -> Kill - | 14 -> Alarm - | 15 -> Terminate - | m -> Fmt.invalid_arg "Signal %i not supported yet." m - - let to_int = function - | Interrupt -> Sys.sigint - | Quit -> Sys.sigquit - | Abort -> Sys.sigabrt - | Kill -> Sys.sigkill - | Alarm -> Sys.sigalrm - | Terminate | Exit -> Sys.sigterm - | Stop -> Sys.sigstop - | Hup -> Sys.sighup - - let of_string s = - match String.uppercase_ascii s with - | "SIGINT" | "INT" -> Interrupt - | "SIGQUIT" | "QUIT" -> Quit - | "SIGABRT" | "ABRT" -> Abort - | "SIGKILL" | "KILL" -> Kill - | "SIGALRM" | "ALRM" -> Alarm - | "SIGTERM" | "TERM" -> Terminate - | "SIGSTOP" | "STOP" -> Stop - | "SIGHUP" | "HUP" -> Hup - | m -> Fmt.invalid_arg "Signal %s not supported or recognised." m - - let raise v = Unix.kill (Unix.getpid ()) (to_int v) -end diff --git a/src/lib/eval.ml b/src/lib/eval.ml index 3f8a615..d92a4b2 100644 --- a/src/lib/eval.ml +++ b/src/lib/eval.ml @@ -29,6 +29,7 @@ let make_child_rdrs_for_parent = (** An evaluator over the AST *) module Make (S : Types.State) (E : Types.Exec) = struct + open Types (* What follows uses the POSIX definition of what a shell does ($ 2.1). It starts from point (4), completing a series of expansions on the AST, @@ -38,33 +39,7 @@ module Make (S : Types.State) (E : Types.Exec) = struct module J = Job.Make (E) module A = Arith.Make (S) - type signal_handler = { run : (unit -> unit) -> unit; sigint_set : bool } - - type ctx = { - interactive : bool; - subshell : bool; - state : S.t; - local_state : (string * string) list; - executor : E.t; - fs : Eio.Fs.dir_ty Eio.Path.t; - options : Built_ins.Options.t; - stdin : Eio_unix.source_ty Eio.Flow.source; - stdout : Eio_unix.sink_ty Eio.Flow.sink; - background_jobs : J.t list; - last_background_process : string; - last_pipeline_status : int option; - async_switch : Eio.Switch.t; - program : string; - argv : string array; - functions : (string * Ast.compound_command) list; - hash : Hash.t; - rdrs : Types.redirect list; - signal_handler : signal_handler; - exit_handler : (unit -> unit) option; - in_double_quotes : bool; - umask : int; - current_pipeline : string option; - } + type ctx = (S.t, E.t, J.t) Types.ctx exception Continue of int * ctx (* Used for the [continue] non-POSIX keyword *) @@ -78,12 +53,12 @@ module Make (S : Types.State) (E : Types.Exec) = struct let make_ctx ?(interactive = false) ?(subshell = false) ?(local_state = []) ?(background_jobs = []) ?(last_background_process = "") ?current_pipeline ?last_pipeline_status ?(functions = []) ?(rdrs = []) ?exit_handler - ?(options = Built_ins.Options.default) ?(hash = Hash.empty) + ?(options = Types.Options.default) ?(hash = Hash.empty) ?(in_double_quotes = false) ?(umask = 0o22) ~fs ~stdin ~stdout ~async_switch ~program ~argv ~signal_handler state executor = - let signal_handler = { run = signal_handler; sigint_set = false } in + let signal_handler = Types.{ run = signal_handler; sigint_set = false } in let state = S.update state ~param:"IFS" " \t\n" |> Result.get_ok in - { + Types.{ interactive; subshell; state; @@ -184,74 +159,82 @@ module Make (S : Types.State) (E : Types.Exec) = struct Option.iter (fun f -> f ()) ctx.exit_handler; exit code - let rec handle_pipeline ~async initial_ctx p : ctx Exit.t = - let set_last_background ~async process ctx = - if async then - { ctx with last_background_process = string_of_int (E.pid process) } - else ctx - in - let on_process ?process ~async ctx = - let ctx = clear_local_state ctx in - match process with - | None -> ctx - | Some process -> set_last_background ~async process ctx - in - let handle_job j = function - | `Process p -> J.add_process p j - | `Rdr p -> J.add_rdr p j - | `Built_in p -> J.add_built_in p j - | `Error p -> J.add_error p j - | `Exit p -> J.add_exit p j - in - let close_stdout ~is_global some_write = - if not is_global then begin - Eio.Flow.close some_write - end - in - let update_stdin ~stdin ctx = - { ctx with stdin = Option.value ~default:ctx.stdin stdin } - in - let exec_process ~sw ctx job ?fds ?stdin ~stdout ?pgid executable args = - let pgid = match pgid with None -> 0 | Some p -> p in - let reap = J.get_reaper job in - let mode = if async then Types.Async else Types.Switched sw in - let fds = ctx.rdrs @ Option.value ~default:[] fds in - let ctx, process = - let hash, prog = - Eunix.resolve_program - ?path:(S.lookup ctx.state ~param:"PATH") - ctx.hash executable - in - let ctx = { ctx with hash } in - match (executable, prog) with - | _, None | "", _ -> - Eio.Flow.copy_string - (Fmt.str "msh: command not found: %s\n" executable) - stdout; - (ctx, Error (127, `Not_found)) - | _, Some full_path -> - Debug.Log.debug (fun f -> - f "executing %a\n%a" - Fmt.(list ~sep:(Fmt.any " ") (quote string)) - (full_path :: args) - Fmt.(list Types.pp_redirect) - fds); - ( ctx, - E.exec ctx.executor ~delay_reap:(fst reap) ~fds ?stdin ~stdout - ~pgid ~mode ~cwd:(cwd_of_ctx ctx) ~pipe:Safe_fd.pipe - ~env:(get_env ~extra:ctx.local_state ctx) - ~executable:full_path (executable :: args) ) - in - match process with - | Error (n, _) -> - let job = handle_job job (`Error n) in - (on_process ~async ctx, job) - | Ok process -> - let pgid = if Int.equal pgid 0 then E.pid process else pgid in - let job = handle_job job (`Process process) |> J.set_id pgid in - (on_process ~async ~process ctx, job) + let close_stdout ~is_global some_write = + if not is_global then begin + Eio.Flow.close some_write + end + + let update_stdin ~stdin ctx = + { ctx with stdin = Option.value ~default:ctx.stdin stdin } + + let handle_job j = function + | `Process p -> J.add_process p j + | `Rdr p -> J.add_rdr p j + | `Built_in p -> J.add_built_in p j + | `Error p -> J.add_error p j + | `Exit p -> J.add_exit p j + + let set_last_background ~async process ctx = + if async then + { ctx with last_background_process = string_of_int (E.pid process) } + else ctx + + let on_process ?process ~async ctx = + let ctx = clear_local_state ctx in + match process with + | None -> ctx + | Some process -> set_last_background ~async process ctx + + let exec_process ~sw ~async ctx job ?fds ~stdin ~stdout ?pgid exec = + let pgid = match pgid with None -> 0 | Some p -> p in + let reap = J.get_reaper job in + let mode = if async then Types.Async else Types.Switched sw in + let fds = ctx.rdrs @ Option.value ~default:[] fds in + let ctx, process = + match exec with + | Types.Function f -> + ( ctx, + E.exec ctx.executor ~delay_reap:(fst reap) ~fds ~stdin ~stdout ~pgid + ~mode ~cwd:(cwd_of_ctx ctx) ~pipe:Safe_fd.pipe + ~env:(get_env ~extra:ctx.local_state ctx) + (Types.Function f) ) + | Types.Args (executable, args) -> ( + let hash, prog = + Eunix.resolve_program + ?path:(S.lookup ctx.state ~param:"PATH") + ctx.hash executable + in + let ctx = { ctx with hash } in + match (executable, prog) with + | _, None | "", _ -> + Eio.Flow.copy_string + (Fmt.str "msh: command not found: %s\n" executable) + stdout; + (ctx, Error (127, `Not_found)) + | _, Some full_path -> + Debug.Log.debug (fun f -> + f "executing %a (rdrs [%a])" + Fmt.(list ~sep:(Fmt.any " ") (quote string)) + (full_path :: args) + Fmt.(list Types.pp_redirect) + fds); + ( ctx, + E.exec ctx.executor ~delay_reap:(fst reap) ~fds ~stdin ~stdout + ~pgid ~mode ~cwd:(cwd_of_ctx ctx) ~pipe:Safe_fd.pipe + ~env:(get_env ~extra:ctx.local_state ctx) + (Types.Args (full_path, executable :: args)) )) in - let job_pgid (t : J.t) = J.get_id t in + match process with + | Error (n, _) -> + let job = handle_job job (`Error n) in + (on_process ~async ctx, job) + | Ok process -> + let pgid = if Int.equal pgid 0 then E.pid process else pgid in + let job = handle_job job (`Process process) |> J.set_id pgid in + (on_process ~async ~process ctx, job) + + let rec handle_pipeline ~async initial_ctx p : ctx Exit.t = + let single_command = match p with [ _ ] -> true | _ -> false in let rec loop pipeline_switch (ctx : ctx) (job : J.t) : Ast.command list -> ctx * J.t = fun c -> @@ -405,7 +388,13 @@ module Make (S : Types.State) (E : Types.Exec) = struct let func_app = if is_command then None else - let ctx = { ctx with stdout = some_write } in + let ctx = + { + ctx with + stdout = some_write; + rdrs = ctx.rdrs @ rdrs; + } + in handle_function_application ctx ~name:executable (ctx.program :: args) in @@ -432,36 +421,23 @@ module Make (S : Types.State) (E : Types.Exec) = struct handle_job job (`Built_in (Exit.nonzero () 1)) ) | Some (Ok bi) -> - let rdrs = - make_child_rdrs_for_parent rdrs - in - let ctx = - handle_built_in ~rdrs ~stdout:some_write - ctx bi + let subshell = not single_command in + let ctx = { ctx with subshell } in + let ctx, job = + run_built_in ~sw:pipeline_switch + ~is_global ~some_write ~some_read ctx + job rdrs bi in let ctx = - ctx >|= fun ctx -> clear_local_state ctx - in - close_stdout ~is_global some_write; - let job = - match bi with - | Built_ins.Exit _ -> - let v_ctx = Exit.value ctx in - if not v_ctx.subshell then - exit v_ctx (Exit.code ctx) - else - handle_job job - (`Exit (Exit.ignore ctx)) - | _ -> - handle_job job - (`Built_in (Exit.ignore ctx)) + { + (Exit.value ctx) with + subshell = false; + } in let ctx = - Exit.map - ~f:(update_stdin ~stdin:some_read) - ctx + update_stdin ~stdin:some_read ctx in - loop (Exit.value ctx) job rest + loop ctx job rest | _ -> ( let ctx, exec_and_args = if is_command then begin @@ -502,10 +478,11 @@ module Make (S : Types.State) (E : Types.Exec) = struct | Exit.Zero (executable, args) -> let ctx, job = exec_process ~sw:pipeline_switch ctx - job ~fds:rdrs ~stdin:ctx.stdin + ~async job ~fds:rdrs + ~stdin:ctx.stdin ~stdout:some_write - ~pgid:(job_pgid job) executable - args + ~pgid:(J.get_id job) + Types.(Args (executable, args)) in close_stdout ~is_global some_write; let ctx = @@ -513,28 +490,17 @@ module Make (S : Types.State) (E : Types.Exec) = struct in loop ctx job rest)))) | Some (Ok bi) -> - let rdrs = make_child_rdrs_for_parent rdrs in - let ctx = - handle_built_in ~rdrs ~stdout:some_write ctx bi - in - let ctx = ctx >|= fun ctx -> clear_local_state ctx in - close_stdout ~is_global some_write; - let job = - match bi with - | Built_ins.Exit _ -> - let v_ctx = Exit.value ctx in - if not v_ctx.subshell then begin - if (Exit.value ctx).interactive then - Fmt.pr "exit\n%!"; - exit v_ctx (Exit.code ctx) - end - else handle_job job (`Exit (Exit.ignore ctx)) - | _ -> handle_job job (`Built_in (Exit.ignore ctx)) + let subshell = not single_command in + let ctx = { ctx with subshell } in + let ctx, job = + run_built_in ~sw:pipeline_switch ~is_global + ~some_write ~some_read ctx job rdrs bi in let ctx = - Exit.map ~f:(update_stdin ~stdin:some_read) ctx + { (Exit.value ctx) with subshell = false } in - loop (Exit.value ctx) job rest)))) + let ctx = update_stdin ~stdin:some_read ctx in + loop ctx job rest)))) | CompoundCommand (c, rdrs) :: rest -> ( let some_read, some_write = stdout_for_pipeline ~sw:pipeline_switch ctx rest @@ -549,7 +515,7 @@ module Make (S : Types.State) (E : Types.Exec) = struct | Ok rdrs -> let saved_rdrs = ctx.rdrs in let saved_stdout = ctx.stdout in - let rdrs = make_child_rdrs_for_parent rdrs in + (* let rdrs = make_child_rdrs_for_parent rdrs in *) (* TODO: No way this is right *) let ctx = { ctx with rdrs = rdrs @ saved_rdrs; stdout = some_write } @@ -583,8 +549,11 @@ module Make (S : Types.State) (E : Types.Exec) = struct let ctx, job = loop sw ctx initial_job p in let ctx = { ctx with stdin = saved_ctx.stdin; state = ctx.state } in match J.size job with - | 0 -> Exit.zero ctx + | 0 -> + Debug.Log.debug (fun f -> f "no jobs"); + Exit.zero ctx | _ -> + Debug.Log.debug (fun f -> f "awaiting %a" J.pp job); if not async then begin let e = J.await_exit ~pipefail:ctx.options.pipefail @@ -603,7 +572,7 @@ module Make (S : Types.State) (E : Types.Exec) = struct end and handle_one_redirection ?(for_parent = false) ~sw ctx v = - let redirect (s, d, b) = + let redirect ?(for_parent = for_parent) (s, d, b) = if for_parent then Types.Parent_redirect (s, d, b) else Types.Child_redirect (s, d, b) in @@ -614,9 +583,10 @@ module Make (S : Types.State) (E : Types.Exec) = struct match op with | Io_op_less -> (* Simple redirection for input *) + Debug.Log.debug (fun f -> f "opening file to read: %s" file); let r = Eio.Path.open_in ~sw (ctx.fs / file) in let fd = Eio_unix.Resource.fd_opt r |> Option.get in - [ redirect (n, fd, `Blocking) ] + [ redirect ~for_parent:false (n, fd, `Blocking) ] | Io_op_lessand -> ( match file with | "-" -> @@ -638,11 +608,12 @@ module Make (S : Types.State) (E : Types.Exec) = struct else `Or_truncate (file_creation_mode ctx) in Debug.Log.debug (fun f -> - f "Creating file (append:%b, %a): %s" append pp_fs_create create + f "creating file (append:%b, %a): %s" append pp_fs_create create file); let w = Eio.Path.open_out ~sw ~append ~create (ctx.fs / file) in let fd = Eio_unix.Resource.fd_opt w |> Option.get in - [ redirect (n, fd, `Blocking) ] + (* Eunix.dup2 ~cloexec:true fd (fd_of_int ~close_unix:true ~sw n); *) + [ redirect ~for_parent:true (n, fd, `Blocking) ] | Io_op_greatand -> ( match file with | "-" -> @@ -671,7 +642,7 @@ module Make (S : Types.State) (E : Types.Exec) = struct (ctx.fs / file) in let fd = Eio_unix.Resource.fd_opt w |> Option.get in - [ redirect (n, fd, `Blocking) ] + [ redirect ~for_parent:true (n, fd, `Blocking) ] | Io_op_lessgreat -> Fmt.failwith "<> not support yet.") | Ast.IoRedirect_IoHere (i, Ast.IoHere (_, v)) -> let _ctx, cst = word_expansion ctx v in @@ -779,7 +750,7 @@ module Make (S : Types.State) (E : Types.Exec) = struct ( Exit.zero ctx, [ [ - Fragment.make (Built_ins.Options.to_letters ctx.options ^ i); + Fragment.make (Types.Options.to_letters ctx.options ^ i); ]; ] ) | Ast.VariableAtom ("@", NoAttribute) -> @@ -1242,7 +1213,7 @@ module Make (S : Types.State) (E : Types.Exec) = struct { ctx with options = - Built_ins.Options.with_options + Types.Options.with_options ~no_path_expansion:true ctx.options; } pattern @@ -1321,7 +1292,7 @@ module Make (S : Types.State) (E : Types.Exec) = struct f "function enter: %s [%a]" name Fmt.(list ~sep:Fmt.(any " ") (quote string)) argv); - let ctx = { ctx with argv = Array.of_list argv } in + let ctx = { ctx with argv = Array.of_list argv; subshell = true } in let v = try Option.some @@ handle_compound_command ctx commands with Return ctx -> Some ctx @@ -1424,217 +1395,262 @@ module Make (S : Types.State) (E : Types.Exec) = struct in (ctx, List.map Ast.Fragment.to_string @@ List.concat fs) - and handle_built_in ~rdrs ~(stdout : Eio_unix.sink_ty Eio.Flow.sink) - (ctx : ctx) v = - let rdrs = ctx.rdrs @ rdrs in - Eunix.with_redirections ~restore:true rdrs @@ fun () -> - Debug.Log.debug (fun f -> f "built-in: %s" (Built_ins.to_string v)); - match v with - | Built_ins.Cd { path } -> - let cwd = S.cwd ctx.state in - let+ state = - match path with - | Some p -> - let fp = Fpath.append cwd (Fpath.v p) in - if Eio.Path.is_directory (ctx.fs / Fpath.to_string fp) then begin - Unix.chdir (Fpath.to_string fp); - Exit.zero @@ S.set_cwd ctx.state fp - end - else - Exit.nonzero_msg ~exit_code:1 ctx.state - "cd: not a directory: %a" Fpath.pp fp - | None -> ( - match Eunix.find_env "HOME" with - | None -> Exit.nonzero_msg ctx.state "HOME not set" - | Some p -> Exit.zero (S.set_cwd ctx.state @@ Fpath.v p)) - in - { ctx with state } - | Pwd -> - let () = - Eio.Flow.copy_string - (Fmt.str "%a\n%!" Fpath.pp (S.cwd ctx.state)) - stdout - in - Exit.zero ctx - | Exit n -> - let should_exit = - { Exit.default_should_exit with interactive = `Yes } - in - Exit.nonzero ~should_exit ctx n - | Return 0 -> raise (Return (Exit.zero ctx)) - | Return n -> raise (Return (Exit.nonzero ctx n)) - | Break n -> raise (Break (n, ctx)) - | Continue n -> raise (Continue (n, ctx)) - | Set { update; print_options } -> - let v = - Exit.zero - { ctx with options = Built_ins.Options.update ctx.options update } - in - if print_options then - Eio.Flow.copy_string - (Fmt.str "%a" Built_ins.Options.pp ctx.options) - stdout; - v - | Wait i -> ( - match Unix.waitpid [] i with - | _, WEXITED 0 -> Exit.zero ctx - | _, (WEXITED n | WSIGNALED n | WSTOPPED n) -> Exit.nonzero ctx n) - | Dot file -> ( - let hash, prog = - Eunix.resolve_program - ?path:(S.lookup ctx.state ~param:"PATH") - ctx.hash file - in - let ctx = { ctx with hash } in - match prog with - | None -> Exit.nonzero ctx 127 - | Some fname -> - Debug.Log.debug (fun f -> f "sourcing..."); - let program = Ast.of_file (ctx.fs / fname) in - let ctx, _ = - run' ~make_process_group:false (Exit.zero ctx) program - in - Debug.Log.debug (fun f -> f "finished sourcing %s" fname); - ctx) - | Unset names -> ( - match names with - | `Variables names -> - let state = - List.fold_left - (fun t param -> S.remove ~param t |> snd) - ctx.state names - in - Exit.zero { ctx with state } - | `Functions names -> - let functions = - List.fold_left - (fun t param -> List.remove_assoc param t) - ctx.functions names - in - Exit.zero { ctx with functions }) - | Hash v -> ( - match v with - | Built_ins.Hash_remove -> Exit.zero { ctx with hash = Hash.empty } - | Built_ins.Hash_stats -> - Eio.Flow.copy_string (Fmt.str "%a" Hash.pp ctx.hash) stdout; - Exit.zero ctx - | _ -> assert false) - | Alias | Unalias -> Exit.zero ctx (* Morbig handles this for us *) - | Eval args -> - let script = String.concat " " args in - let ast = Ast.of_string script in - let ctx, _ = run (Exit.zero ctx) ast in - ctx - | Echo args -> - let str = String.concat " " args ^ "\n" in - Eio.Flow.copy_string str stdout; - Exit.zero ctx - | Trap (action, signals) -> - let saved_ctx = ctx in - let action = - match action with - | Action m -> - let ast = Ast.of_string m in - let f _ = - saved_ctx.signal_handler.run @@ fun () -> - let _, _ = run (Exit.zero saved_ctx) ast in - () + and handle_built_in ~rdrs ~run_in_child job (ctx : ctx) v = + let run_built_in v stdout = + match v with + | Built_ins.Cd { path } -> + let cwd = S.cwd ctx.state in + let+ state = + match path with + | Some p -> + let fp = Fpath.append cwd (Fpath.v p) in + if Eio.Path.is_directory (ctx.fs / Fpath.to_string fp) then begin + Unix.chdir (Fpath.to_string fp); + Exit.zero @@ S.set_cwd ctx.state fp + end + else + Exit.nonzero_msg ~exit_code:1 ctx.state + "cd: not a directory: %a" Fpath.pp fp + | None -> ( + match Eunix.find_env "HOME" with + | None -> Exit.nonzero_msg ctx.state "HOME not set" + | Some p -> Exit.zero (S.set_cwd ctx.state @@ Fpath.v p)) + in + { ctx with state } + | Pwd -> + let () = + Eio.Flow.copy_string + (Fmt.str "%a\n%!" Fpath.pp (S.cwd ctx.state)) + stdout + in + Exit.zero ctx + | Exit n -> + let should_exit = + { Exit.default_should_exit with interactive = `Yes } + in + Exit.nonzero ~should_exit ctx n + | Return 0 -> raise (Return (Exit.zero ctx)) + | Return n -> raise (Return (Exit.nonzero ctx n)) + | Break n -> raise (Break (n, ctx)) + | Continue n -> raise (Continue (n, ctx)) + | Set { update; print_options } -> + let v = + Exit.zero + { ctx with options = Types.Options.update ctx.options update } + in + if print_options then + Eio.Flow.copy_string + (Fmt.str "%a" Types.Options.pp ctx.options) + stdout; + v + | Wait i -> ( + match Unix.waitpid [] i with + | _, WEXITED 0 -> Exit.zero ctx + | _, (WEXITED n | WSIGNALED n | WSTOPPED n) -> Exit.nonzero ctx n) + | Dot file -> ( + let hash, prog = + Eunix.resolve_program + ?path:(S.lookup ctx.state ~param:"PATH") + ctx.hash file + in + let ctx = { ctx with hash } in + match prog with + | None -> Exit.nonzero ctx 127 + | Some fname -> + Debug.Log.debug (fun f -> f "sourcing..."); + let program = Ast.of_file (ctx.fs / fname) in + let ctx, _ = + run' ~make_process_group:false (Exit.zero ctx) program in - Sys.Signal_handle f - | Default -> Sys.Signal_default - | Ignore -> Sys.Signal_ignore - | Int _ -> assert false - in - Exit.zero - @@ List.fold_left - (fun ctx signal -> - match signal with - | `Exit -> - let action = - match action with - | Sys.Signal_default | Sys.Signal_ignore -> None - | Sys.Signal_handle f -> Some (fun () -> f 0) - in - { ctx with exit_handler = action } - | `Signal signal -> - let action = - (* Handle sigint separately for interactive mode *) - match (action, signal) with - | Sys.Signal_default, Eunix.Signals.Interrupt -> - if ctx.interactive then Sys.Signal_ignore else action - | _ -> action - in - let setting_sigint = - ctx.signal_handler.sigint_set = false - && - match action with - | Sys.Signal_handle _ -> true - | _ -> false - in - Sys.set_signal (Eunix.Signals.to_int signal) action; - { - ctx with - signal_handler = - { ctx.signal_handler with sigint_set = setting_sigint }; - }) - ctx signals - | Umask None -> - let str = Fmt.str "0%o\n" ctx.umask in - Eio.Flow.copy_string str stdout; - Exit.zero ctx - | Umask (Some i) -> Exit.zero { ctx with umask = i } - | Shift n -> - let n = Option.value ~default:1 n in - let new_len = Array.length ctx.argv - n in - assert (new_len >= 0); - let argv = Array.init new_len (fun i -> Array.get ctx.argv (i + n)) in - Exit.zero { ctx with argv } - | Read (_backslash, vars) -> ( - let line = - let buf = Cstruct.create 1 in - let rec loop acc = - match - Eio.Flow.read_exact ctx.stdin buf; - Cstruct.to_string buf - with - | "\n" -> Some acc - | c -> loop (acc ^ c) - | exception End_of_file -> - Debug.Log.debug (fun f -> f "Read EOF"); - if String.equal acc "" then None else Some acc + Debug.Log.debug (fun f -> f "finished sourcing %s" fname); + ctx) + | Unset names -> ( + match names with + | `Variables names -> + let state = + List.fold_left + (fun t param -> S.remove ~param t |> snd) + ctx.state names + in + Exit.zero { ctx with state } + | `Functions names -> + let functions = + List.fold_left + (fun t param -> List.remove_assoc param t) + ctx.functions names + in + Exit.zero { ctx with functions }) + | Hash v -> ( + match v with + | Built_ins.Hash_remove -> Exit.zero { ctx with hash = Hash.empty } + | Built_ins.Hash_stats -> + Eio.Flow.copy_string (Fmt.str "%a" Hash.pp ctx.hash) stdout; + Exit.zero ctx + | _ -> assert false) + | Alias | Unalias -> Exit.zero ctx (* Morbig handles this for us *) + | Eval args -> + let script = String.concat " " args in + let ast = Ast.of_string script in + let ctx, _ = run (Exit.zero ctx) ast in + ctx + | Echo args -> + let str = String.concat " " args ^ "\n" in + let stdout = Eio_posix.Flow.of_fd Eio_unix.Fd.stdout in + Eio.Flow.copy_string str stdout; + Exit.zero ctx + | Trap (action, signals) -> + let saved_ctx = ctx in + let action = + match action with + | Action m -> + let ast = Ast.of_string m in + let f _ = + saved_ctx.signal_handler.run @@ fun () -> + let _, _ = run (Exit.zero saved_ctx) ast in + () + in + Sys.Signal_handle f + | Default -> Sys.Signal_default + | Ignore -> Sys.Signal_ignore + | Int _ -> assert false in - loop "" - in - let rec loop acc = function - | v :: vars, Ast.{ txt; _ } :: fs -> loop ((v, txt) :: acc) (vars, fs) - | _, [] -> List.rev acc - | [], lines -> - let last_var, last_line = List.hd acc in - List.rev - ((last_var, last_line ^ Ast.Fragment.join_list ~sep:" " lines) - :: acc) - in - let fields = - Option.map - (fun s -> - field_splitting ctx [ Ast.Fragment.make ~splittable:true s ]) - line - in - match fields with - | None -> Exit.nonzero ctx 1 - | Some fs -> - let vars = loop [] (vars, fs) in - let state = - List.fold_left - (fun st (k, v) -> - S.update ?id:ctx.current_pipeline st ~param:k v - |> Result.get_ok) - ctx.state vars + Exit.zero + @@ List.fold_left + (fun ctx signal -> + match signal with + | `Exit -> + let action = + match action with + | Sys.Signal_default | Sys.Signal_ignore -> None + | Sys.Signal_handle f -> Some (fun () -> f 0) + in + { ctx with exit_handler = action } + | `Signal signal -> + let action = + (* Handle sigint separately for interactive mode *) + match (action, signal) with + | Sys.Signal_default, Types.Signals.Interrupt -> + if ctx.interactive then Sys.Signal_ignore else action + | _ -> action + in + let setting_sigint = + ctx.signal_handler.sigint_set = false + && + match action with + | Sys.Signal_handle _ -> true + | _ -> false + in + Sys.set_signal (Types.Signals.to_int signal) action; + { + ctx with + signal_handler = + { ctx.signal_handler with sigint_set = setting_sigint }; + }) + ctx signals + | Umask None -> + let str = Fmt.str "0%o\n" ctx.umask in + Eio.Flow.copy_string str stdout; + Exit.zero ctx + | Umask (Some i) -> Exit.zero { ctx with umask = i } + | Shift n -> + let n = Option.value ~default:1 n in + let new_len = Array.length ctx.argv - n in + assert (new_len >= 0); + let argv = Array.init new_len (fun i -> Array.get ctx.argv (i + n)) in + Exit.zero { ctx with argv } + | Read (_backslash, vars) -> ( + let line = + let buf = Cstruct.create 1 in + let rec loop acc = + match + Eio.Flow.read_exact ctx.stdin buf; + Cstruct.to_string buf + with + | "\n" -> Some acc + | c -> loop (acc ^ c) + | exception End_of_file -> + Debug.Log.debug (fun f -> f "Read EOF"); + if String.equal acc "" then None else Some acc in - Exit.zero { ctx with state }) - | Command _ -> - (* Handled separately *) - assert false + loop "" + in + let rec loop acc = function + | v :: vars, Ast.{ txt; _ } :: fs -> + loop ((v, txt) :: acc) (vars, fs) + | _, [] -> List.rev acc + | [], lines -> + let last_var, last_line = List.hd acc in + List.rev + ((last_var, last_line ^ Ast.Fragment.join_list ~sep:" " lines) + :: acc) + in + let fields = + Option.map + (fun s -> + field_splitting ctx [ Ast.Fragment.make ~splittable:true s ]) + line + in + match fields with + | None -> Exit.nonzero ctx 1 + | Some fs -> + Debug.Log.debug (fun f -> + f "read line: %a" Fmt.(list ~sep:Fmt.comma Ast.Fragment.pp) fs); + let vars = loop [] (vars, fs) in + let state = + List.fold_left + (fun st (k, v) -> + S.update ?id:ctx.current_pipeline st ~param:k v + |> Result.get_ok) + ctx.state vars + in + Exit.zero { ctx with state }) + | Command _ -> + (* Handled separately *) + assert false + in + let go () = + (* Eunix.with_redirections ~restore:true rdrs @@ fun () -> *) + Debug.Log.debug (fun f -> + f "built-in: %s (rdrs [%a])" (Built_ins.to_string v) + (Fmt.list Types.pp_redirect) + rdrs); + run_built_in v ctx.stdout + in + if ctx.subshell then begin + let ctx, j = + Debug.Log.debug (fun f -> f "built-in will run in child"); + let rdrs = ctx.rdrs @ rdrs in + Eunix.with_redirections ~restore:true rdrs @@ fun () -> + run_in_child @@ fun () -> + let ctx = go () in + Exit.ignore ctx + in + (Exit.zero ctx, j) + end + else + Eunix.with_redirections ~restore:true rdrs @@ fun () -> + let ctx = go () in + (ctx, J.add_built_in (Exit.ignore ctx) job) + + and run_built_in ~sw ~some_write ~some_read ~is_global (ctx : ctx) job rdrs bi + = + let rdrs = ctx.rdrs @ rdrs in + let run_in_child f = + exec_process ~sw ~async:false ctx job ~fds:rdrs ~stdin:ctx.stdin + ~stdout:some_write ~pgid:(J.get_id job) + Types.(Function f) + in + let ctx, job = handle_built_in ~run_in_child ~rdrs job ctx bi in + let ctx = ctx >|= fun ctx -> clear_local_state ctx in + close_stdout ~is_global some_write; + let job = + match bi with + | Built_ins.Exit _ -> + let v_ctx = Exit.value ctx in + if not v_ctx.subshell then exit v_ctx (Exit.code ctx) else job + | _ -> job + in + (Exit.map ~f:(update_stdin ~stdin:some_read) ctx, job) and exec initial_ctx ((command, sep) : Ast.complete_command) = let rec loop : Eio.Switch.t -> ctx -> Ast.clist -> ctx Exit.t = diff --git a/src/lib/eval.mli b/src/lib/eval.mli index aa4cf30..be072df 100644 --- a/src/lib/eval.mli +++ b/src/lib/eval.mli @@ -21,7 +21,7 @@ module Make (S : Types.State) (E : Types.Exec) : sig ?functions:(string * Sast.compound_command) list -> ?rdrs:Types.redirect list -> ?exit_handler:(unit -> unit) -> - ?options:Built_ins.Options.t -> + ?options:Types.Options.t -> ?hash:Hash.t -> ?in_double_quotes:bool -> ?umask:int -> diff --git a/src/lib/interactive.ml b/src/lib/interactive.ml index 4c40e95..7ad2ecd 100644 --- a/src/lib/interactive.ml +++ b/src/lib/interactive.ml @@ -126,7 +126,7 @@ module Make (S : Types.State) (E : Types.Exec) (H : Types.History) = struct loop ctx' | Ctrl_c -> let c = Exit.value ctx in - Eunix.Signals.(raise Interrupt); + Types.Signals.(raise Interrupt); if Eval.sigint_set c then loop (Exit.zero c) else begin Fmt.pr "\n%!"; diff --git a/src/lib/job.ml b/src/lib/job.ml index 8c1120e..7597def 100644 --- a/src/lib/job.ml +++ b/src/lib/job.ml @@ -33,19 +33,38 @@ module Make (E : Types.Exec) = struct let add_exit b t = { t with processes = List.cons (`Exit b) t.processes } let size t = List.length t.processes + let pp_process ppf = function + | `Process p -> Fmt.pf ppf "process %i" (E.pid p) + | `Built_in b -> Fmt.pf ppf "built-in %i" (Exit.code b) + | `Exit b -> Fmt.pf ppf "exit %i" (Exit.code b) + | `Rdr b -> Fmt.pf ppf "rdr %i" (Exit.code b) + | `Error b -> Fmt.pf ppf "error %i" b + + let pp ppf t = + Fmt.pf ppf "@.@[job %i:[@;<1 0>%a@.]" t.id + Fmt.(list ~sep:Fmt.comma pp_process) + t.processes + + let await interactive t = function + | `Process p -> + if interactive then + Eunix.delegate_control ~pgid:t.id @@ fun () -> E.await p + else E.await p + | `Built_in b | `Exit b | `Rdr b -> b + | `Error n -> Exit.nonzero () n + + let await_last t = + match List.hd t.processes with + | v -> + Eio.Promise.resolve (snd t.reap) (); + Eio.Fiber.yield (); + await false t v + (* Section 2.9.2 https://pubs.opengroup.org/onlinepubs/9799919799/ *) let await_exit ~pipefail ~interactive t = Eio.Promise.resolve (snd t.reap) (); Eio.Fiber.yield (); - let await = function - | `Process p -> - if interactive then - Eunix.delegate_control ~pgid:t.id @@ fun () -> E.await p - else E.await p - | `Built_in b | `Exit b | `Rdr b -> b - | `Error n -> Exit.nonzero () n - in match (pipefail, t.processes) with - | false, x :: _ -> await x + | false, x :: _ -> await interactive t x | _ -> Fmt.failwith "TODO: pipefail or no processes" end diff --git a/src/lib/merry_stubs.c b/src/lib/merry_stubs.c index 4102957..4578aa0 100644 --- a/src/lib/merry_stubs.c +++ b/src/lib/merry_stubs.c @@ -4,6 +4,8 @@ #include #include +#include "include/fork_action.h" + #include #include #include @@ -62,3 +64,18 @@ caml_merry_safefd(value v_fd) { return Val_int(newfd); } + +value caml_merry_run_fork_actions_return(value v_errors, value v_actions) { + CAMLparam1(v_actions); + int errors = Int_val(v_errors); + int old_flags = fcntl(errors, F_GETFL, 0); + fcntl(errors, F_SETFL, old_flags & ~O_NONBLOCK); + while (Is_block(v_actions)) { + value v_action = Field(v_actions, 0); + fork_fn *action = (fork_fn *) Nativeint_val(Field(v_action, 0)); + action(errors, v_action); + v_actions = Field(v_actions, 1); + } + CAMLreturn(Val_unit); +} + diff --git a/src/lib/posix/exec.ml b/src/lib/posix/exec.ml index c06e806..00c8fbf 100644 --- a/src/lib/posix/exec.ml +++ b/src/lib/posix/exec.ml @@ -48,6 +48,10 @@ module Process = struct if not (Promise.is_resolved t.exit_status) then Unix.kill t.pid signal (* else process has been reaped and t.pid is invalid *) + external run_actions : + Unix.file_descr -> Eio_unix.Private.Fork_action.c_action list -> unit + = "caml_merry_run_fork_actions_return" + external eio_spawn : Unix.file_descr -> Eio_unix.Private.Fork_action.c_action list -> int = "caml_eio_posix_spawn" @@ -70,7 +74,33 @@ module Process = struct | Merry.Types.Async -> () | Merry.Types.Switched sw -> f sw - let spawn ?delay_reap ~mode actions = + let of_pid ?delay_reap mode ~pid (exit_status, set_exit_status) = + let t = { pid; exit_status; lock = Mutex.create () } in + let () = + iter_switch + ~f:(fun sw -> + let hook = + Switch.on_release_cancellable sw (fun () -> + (* Kill process (if still running) *) + signal t Sys.sigkill; + (* The switch is being released, so either the daemon fiber got + cancelled or it hasn't started yet (and never will start). *) + if not (Promise.is_resolved t.exit_status) then + (* Do a (non-cancellable) waitpid here to reap the child. *) + reap t set_exit_status) + in + Fiber.fork_daemon ~sw (fun () -> + Option.iter Eio.Promise.await delay_reap; + reap t set_exit_status; + Switch.remove_hook hook; + `Stop_daemon)) + mode + in + t + + let fork fn = match Unix.fork () with 0 -> exit (Merry.Exit.code @@ fn ()) | child -> child + + let spawn ?delay_reap ~exec ~mode actions = with_pipe @@ fun errors_r errors_w -> Eio_unix.Private.Fork_action.with_actions actions @@ fun c_actions -> iter_switch ~f:Switch.check mode; @@ -79,7 +109,12 @@ module Process = struct let pid = Eio_unix.Fd.use_exn "errors-w" errors_w @@ fun errors_w -> Eio.Private.Trace.with_span "spawn" @@ fun () -> - eio_spawn errors_w c_actions + match exec with + | Merry.Types.Args _ -> eio_spawn errors_w c_actions + | Merry.Types.Function f -> + fork @@ fun () -> + run_actions errors_w c_actions; + f () in Eio_unix.Fd.close errors_w; { pid; exit_status; lock = Mutex.create () } @@ -208,16 +243,20 @@ let inherit_fds m = Eio_unix.Private.Fork_action. { run = (fun k -> k (Obj.repr (action_dups, plan, blocking))) } -let spawn_unix () ?delay_reap ~mode ~fork_actions ?pgid ?uid ?gid ~env ~fds - ~executable ~cwd args = +let spawn_unix () ?delay_reap ~mode ~fork_actions ?pgid ?uid ?gid ~env ~fds ~cwd + (exec_kind : Merry.Types.exec) = let open Eio_posix in - let actions = - [ - inherit_fds fds; - Low_level.Process.Fork_action.execve executable ~argv:(Array.of_list args) - ~env; - ] + let exec = + match exec_kind with + | Args (executable, args) -> + [ + Low_level.Process.Fork_action.execve executable + ~argv:(Array.of_list args) ~env; + ] + | Function _ -> [] in + + let actions = [ inherit_fds fds ] @ exec in let actions = match pgid with | None -> actions @@ -250,7 +289,7 @@ let spawn_unix () ?delay_reap ~mode ~fork_actions ?pgid ?uid ?gid ~env ~fds fn (Low_level.Process.Fork_action.fchdir cwd :: actions) in with_actions cwd @@ fun actions -> - process (Process.spawn ?delay_reap ~mode actions) + process (Process.spawn ?delay_reap ~exec:exec_kind ~mode actions) let fd_equal_int fd i = Eio_unix.Fd.use ~if_closed:(fun () -> true) fd @@ fun ufd -> @@ -260,7 +299,7 @@ let fd_equal_int fd i = let pp_redirections ppf (i, fd, _) = Fmt.pf ppf "(%i,%a)" i Eio_unix.Fd.pp fd let run ~mode ?delay_reap _ ?stdin ?stdout ?stderr ?(fds = []) - ?(fork_actions = []) ~pgid ~cwd ~pipe ?env ?executable args = + ?(fork_actions = []) ~pgid ~cwd ~pipe ?env (exec : Merry.Types.exec) = with_close_list @@ fun to_close -> let check_fd n = function | Merry.Types.Parent_redirect (m, _, _) -> Int.equal n m @@ -298,14 +337,23 @@ let run ~mode ?delay_reap _ ?stdin ?stdout ?stderr ?(fds = []) List.fold_left (fun (cs, fs) -> function | Merry.Types.Child_redirect (a, b, c) -> (cs, (a, b, c) :: fs) - | Merry.Types.Parent_redirect _ -> (cs, fs) + | Merry.Types.Parent_redirect (_, _, _) -> (cs, fs) | Close fd -> (fd :: cs, fs)) ([], []) fds |> fun (cs, fs) -> (List.rev cs, List.rev fs) in List.iter Eio_unix.Fd.close need_close; let fds = std_fds @ fds in - let executable = get_executable executable ~args in let env = get_env env in - spawn_unix ?delay_reap ~mode ~fork_actions ~cwd ~pgid ~fds ~env ~executable () - args + spawn_unix ?delay_reap ~mode ~fork_actions ~cwd ~pgid ~fds ~env () exec + +let fork ?delay_reap mode fn = + match Unix.fork () with + | 0 -> + let _ : 'a = fn () in + Option.iter Eio.Promise.await delay_reap; + exit 0 + | child -> + let exit_promise = Promise.create () in + let v = Process.of_pid ?delay_reap mode ~pid:child exit_promise in + process v diff --git a/src/lib/posix/merry_posix.ml b/src/lib/posix/merry_posix.ml index 1e379ab..5224fc5 100644 --- a/src/lib/posix/merry_posix.ml +++ b/src/lib/posix/merry_posix.ml @@ -15,8 +15,10 @@ module Exec = struct | `Exited n -> Merry.Exit.nonzero () n | `Signaled n -> Merry.Exit.nonzero () n + let fork = Exec.fork + let exec ?delay_reap ?(fork_actions = []) ?(fds = []) ?stdin ?stdout ?stderr - ?env ~mode ~pgid ~cwd ~pipe ~executable t args = + ?env ~mode ~pgid ~cwd ~pipe t exec = let env = Option.map (fun lst -> List.map (fun (a, b) -> a ^ "=" ^ b) lst |> Array.of_list) @@ -25,7 +27,7 @@ module Exec = struct try Ok (Exec.run ?delay_reap ~pipe ~fork_actions ~mode ~fds ~pgid ~cwd ?stdin - ?stdout ?stderr ?env t ~executable args) + ?stdout ?stderr ?env t exec) with Eio.Io (Eio.Process.E (Eio.Process.Executable_not_found m), _ctx) -> Fmt.epr "msh: command not found: %s\n%!" m; Error (127, `Not_found) diff --git a/src/lib/types.ml b/src/lib/types.ml index 9b83759..f32af1e 100644 --- a/src/lib/types.ml +++ b/src/lib/types.ml @@ -6,6 +6,162 @@ module Parameter = struct | Null (** Possible shell parameters *) end +type redirect = + | Parent_redirect of + int * Eio_unix.Fd.t * Eio_unix.Private.Fork_action.blocking + | Child_redirect of + int * Eio_unix.Fd.t * Eio_unix.Private.Fork_action.blocking + | Close of Eio_unix.Fd.t + +type exec_mode = + | Switched of Eio.Switch.t + | Async + (** How to execute a process. This mainly controls what happens at the end + of the running a script or some commands. When a process is + "switched", we use the same semantics as Eio, we sigkill the process + and cleanup. If the process is complete Async then we do not wait. + This allows us to exit before some of our child processes, which is a + requirement for implementing the semantics of a shell! *) + +type exec = + | Args of string * string list + | Function of (unit -> unit Exit.t) + +let pp_exec ppf = function + | Args (e, args) -> + Fmt.pf ppf "%s: %a" e Fmt.(list ~sep:(Fmt.any " ") string) args + | Function _ -> Fmt.string ppf "function" + +module Signals = struct + type t = + | Interrupt + | Quit + | Abort + | Kill + | Alarm + | Terminate + | Exit + | Stop + | Hup + [@@deriving to_yojson] + + let of_int = function + | i when Int.equal i Sys.sigint -> Interrupt + | i when Int.equal i Sys.sigquit -> Quit + | i when Int.equal i Sys.sigabrt -> Abort + | i when Int.equal i Sys.sigkill -> Kill + | i when Int.equal i Sys.sigalrm -> Alarm + | i when Int.equal i Sys.sigterm -> Terminate + | i when Int.equal i Sys.sigstop -> Stop + | i when Int.equal i Sys.sighup -> Hup + (* From the manpages *) + | 1 -> Hup + | 2 -> Interrupt + | 3 -> Quit + | 6 -> Abort + | 9 -> Kill + | 14 -> Alarm + | 15 -> Terminate + | m -> Fmt.invalid_arg "Signal %i not supported yet." m + + let to_int = function + | Interrupt -> Sys.sigint + | Quit -> Sys.sigquit + | Abort -> Sys.sigabrt + | Kill -> Sys.sigkill + | Alarm -> Sys.sigalrm + | Terminate | Exit -> Sys.sigterm + | Stop -> Sys.sigstop + | Hup -> Sys.sighup + + let of_string s = + match String.uppercase_ascii s with + | "SIGINT" | "INT" -> Interrupt + | "SIGQUIT" | "QUIT" -> Quit + | "SIGABRT" | "ABRT" -> Abort + | "SIGKILL" | "KILL" -> Kill + | "SIGALRM" | "ALRM" -> Alarm + | "SIGTERM" | "TERM" -> Terminate + | "SIGSTOP" | "STOP" -> Stop + | "SIGHUP" | "HUP" -> Hup + | m -> Fmt.invalid_arg "Signal %s not supported or recognised." m + + let raise v = Unix.kill (Unix.getpid ()) (to_int v) +end + +module Options = struct + type t = { + noclobber : bool; + pipefail : bool; + errexit : bool; + no_path_expansion : bool; + no_unset : bool; + async : bool; + } + + let default = + { + noclobber = false; + pipefail = false; + errexit = false; + no_path_expansion = false; + no_unset = false; + async = false; + } + + let with_options ?noclobber ?pipefail ?errexit ?async ?no_path_expansion + ?no_unset t = + { + noclobber = Option.value ~default:t.noclobber noclobber; + pipefail = Option.value ~default:t.pipefail pipefail; + errexit = Option.value ~default:t.errexit errexit; + async = Option.value ~default:t.async async; + no_path_expansion = + Option.value ~default:t.no_path_expansion no_path_expansion; + no_unset = Option.value ~default:t.no_unset no_unset; + } + + type posix = [ `Noclobber | `Pipefail | `Noglob | `Nounset | `Errexit ] + type merry = [ `Async ] + type option = [ posix | merry ] + + let posix_to_letter = function `Noclobber -> "C" | _ -> "" + + let to_letters t = + let nc = if t.noclobber then posix_to_letter `Noclobber else "" in + nc ^ "" + + let update t options = + List.fold_left + (fun d -> function + | `Pipefail, pipefail -> with_options ~pipefail d + | `Noclobber, noclobber -> with_options ~noclobber d + | `Noglob, no_path_expansion -> with_options ~no_path_expansion d + | `Errexit, errexit -> with_options ~errexit d + | `Nounset, no_unset -> with_options ~no_unset d + | `Async, async -> with_options ~async d) + t options + + let pp ppf opt = + let pp_option ppf (name, value) = + Fmt.pf ppf "%-12s %s@." name (if value then "on" else "off") + in + let opts = + let { noclobber; pipefail; async; no_path_expansion; no_unset; errexit } = + opt + in + [ + ("pipefail", pipefail); + ("errexit", errexit); + ("noclobber", noclobber); + ("noglob", no_path_expansion); + ("nounset", no_unset); + ("async", async); + ] + in + Fmt.pf ppf "@[%a@]" Fmt.(list pp_option) opts +end + module type State = sig type t (** State for the shell and operating system that is carried from one @@ -56,60 +212,6 @@ module type State = sig val dump : t Fmt.t end -type redirect = - | Parent_redirect of - int * Eio_unix.Fd.t * Eio_unix.Private.Fork_action.blocking - | Child_redirect of - int * Eio_unix.Fd.t * Eio_unix.Private.Fork_action.blocking - | Close of Eio_unix.Fd.t - -let pp_redirect ppf = function - | Parent_redirect (i, fd, _) -> Fmt.pf ppf "%i <=p=> %a" i Eio_unix.Fd.pp fd - | Child_redirect (i, fd, _) -> Fmt.pf ppf "%i <=c=> %a" i Eio_unix.Fd.pp fd - | Close fd -> Fmt.pf ppf "close %a" Eio_unix.Fd.pp fd - -type exec_mode = - | Switched of Eio.Switch.t - | Async - (** How to execute a process. This mainly controls what happens at the end - of the running a script or some commands. When a process is - "switched", we use the same semantics as Eio, we sigkill the process - and cleanup. If the process is complete Async then we do not wait. - This allows us to exit before some of our child processes, which is a - requirement for implementing the semantics of a shell! *) - -module type Exec = sig - type t - (** An executor for commands *) - - type process - - val signal : process -> int -> unit - val pid : process -> int - - val exec : - ?delay_reap:unit Eio.Promise.t -> - ?fork_actions:Eio_unix__.Fork_action.t list -> - ?fds:redirect list -> - ?stdin:_ Eio.Flow.source -> - ?stdout:_ Eio.Flow.sink -> - ?stderr:_ Eio.Flow.sink -> - ?env:(string * string) list -> - mode:exec_mode -> - pgid:int -> - cwd:Eio.Fs.dir_ty Eio.Path.t -> - pipe: - (Eio.Switch.t -> - Eio_unix.source_ty Eio.Std.r * Eio_unix.sink_ty Eio.Std.r) -> - executable:string -> - t -> - string list -> - (process, int * [ `Not_found ]) result - (** Run a command in a child process *) - - val await : process -> unit Exit.t -end - module type Job = sig type t (** A job for job control *) @@ -128,6 +230,8 @@ module type Job = sig list -> t + val pp : t Fmt.t + val get_id : t -> int (** Get the ID of the job. *) @@ -143,11 +247,85 @@ module type Job = sig val size : t -> int (** Number of processes in this job *) + val await_last : t -> unit Exit.t + (** Just waits for the last command to enter the job. *) + val await_exit : pipefail:bool -> interactive:bool -> t -> unit Exit.t (** Given a job, [await_exit] will wait for the job to finish and return the exit based on the various options passed in. *) end +module type Exec = sig + type t + (** An executor for commands *) + + type process + + val signal : process -> int -> unit + val pid : process -> int + + val exec : + ?delay_reap:unit Eio.Promise.t -> + ?fork_actions:Eio_unix__.Fork_action.t list -> + ?fds:redirect list -> + ?stdin:_ Eio.Flow.source -> + ?stdout:_ Eio.Flow.sink -> + ?stderr:_ Eio.Flow.sink -> + ?env:(string * string) list -> + mode:exec_mode -> + pgid:int -> + cwd:Eio.Fs.dir_ty Eio.Path.t -> + pipe: + (Eio.Switch.t -> + Eio_unix.source_ty Eio.Std.r * Eio_unix.sink_ty Eio.Std.r) -> + t -> + exec -> + (process, int * [ `Not_found ]) result + (** Run a command in a child process *) + + val fork : + ?delay_reap:unit Eio.Promise.t -> exec_mode -> (unit -> 'a) -> process + (** [fork mode fn] runs [fn] in a child process *) + + val await : process -> unit Exit.t +end + +type signal_handler = { run : (unit -> unit) -> unit; sigint_set : bool } +(* type state = State : ((module State with type t = 'a) * 'a) -> state *) +(* type executor = Executor : ((module Exec with type t = 'a) * 'a) -> executor *) +(* type job = Job : ((module Job with type t = 'a) * 'a) -> job *) + +type ('s, 'e, 'j) ctx = { + interactive : bool; + subshell : bool; + state : 's; + executor : 'e; + local_state : (string * string) list; + fs : Eio.Fs.dir_ty Eio.Path.t; + options : Options.t; + stdin : Eio_unix.source_ty Eio.Flow.source; + stdout : Eio_unix.sink_ty Eio.Flow.sink; + background_jobs : 'j list; + last_background_process : string; + last_pipeline_status : int option; + async_switch : Eio.Switch.t; + program : string; + argv : string array; + functions : (string * Ast.compound_command) list; + hash : Hash.t; + rdrs : redirect list; + signal_handler : signal_handler; + exit_handler : (unit -> unit) option; + in_double_quotes : bool; + umask : int; + current_pipeline : string option; +} + +let pp_redirect ppf = function + | Parent_redirect (i, fd, _) -> Fmt.pf ppf "%i <=p=> %a" i Eio_unix.Fd.pp fd + | Child_redirect (i, fd, _) -> Fmt.pf ppf "%i <=c=> %a" i Eio_unix.Fd.pp fd + | Close fd -> Fmt.pf ppf "close %a" Eio_unix.Fd.pp fd + module type History = sig type t (** A history of commands *) diff --git a/test/check_fork.sh b/test/check_fork.sh new file mode 100755 index 0000000..a35cf0c --- /dev/null +++ b/test/check_fork.sh @@ -0,0 +1,7 @@ +#!/bin/sh +cmd="$1" +strace-f(){ strace -f "$@" 2>&1; }; +for sh in bash dash yash zsh ksh ash; do + printf "$(basename $sh)\t" ; strace-f $sh -c "$cmd" | grep -e clone -e fork -c; +done +