(*----------------------------------------------------------------- Copyright (c) 2025 The merry programmers. All rights reserved. SPDX-License-Identifier: ISC -----------------------------------------------------------------*) open Eio.Std open Import open Exit.Syntax (** An evaluator over the AST *) module Make (S : Types.State) (E : Types.Exec) = struct (* 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, then redirection is setup, and finally functions/built-ins/commands are executed. *) 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; 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; } let _stdin ctx = ctx.stdin let make_ctx ?(interactive = false) ?(subshell = false) ?(local_state = []) ?(background_jobs = []) ?(last_background_process = "") ?(functions = []) ?(rdrs = []) ?exit_handler ?(options = Built_ins.Options.default) ?(hash = Hash.empty) ~fs ~stdin ~stdout ~async_switch ~program ~argv ~signal_handler state executor = let signal_handler = { run = signal_handler; sigint_set = false } in { interactive; subshell; state; local_state; executor; fs; options; stdin; stdout; background_jobs; last_background_process; async_switch; program; argv; functions; hash; rdrs; signal_handler; exit_handler; } let state ctx = ctx.state let sigint_set ctx = ctx.signal_handler.sigint_set let fs ctx = ctx.fs let clear_local_state ctx = { ctx with local_state = [] } let rec tilde_expansion ctx = function | [] -> [] | Ast.WordTildePrefix _ :: rest -> Ast.WordName (S.expand ctx.state `Tilde) :: tilde_expansion ctx rest | v :: rest -> v :: tilde_expansion ctx rest let arithmetic_expansion ctx expr = let rec fold (ctx, cst) = function | [] -> (ctx, cst) | Ast.WordArithmeticExpression word :: rest -> let expr = Ast.word_components_to_string word in let aexpr = Arith_parser.main Arith_lexer.read (Lexing.from_string expr) in let state, i = A.eval ctx.state aexpr in fold ({ ctx with state }, Ast.WordLiteral (string_of_int i) :: cst) rest | Ast.WordDoubleQuoted dq :: rest -> let ctx, v = fold (ctx, []) dq in fold (ctx, Ast.WordDoubleQuoted (List.rev v) :: cst) rest | Ast.WordSingleQuoted dq :: rest -> let ctx, v = fold (ctx, []) dq in fold (ctx, Ast.WordSingleQuoted (List.rev v) :: cst) rest | v :: rest -> fold (ctx, v :: cst) rest in let state, cst = fold (ctx, []) expr in (state, List.rev cst) let stdout_for_pipeline ~sw ctx = function | [] -> (None, `Global ctx.stdout) | _ -> let r, w = Eio_unix.pipe sw in (Some r, `Local (w :> Eio_unix.sink_ty Eio.Flow.sink)) let fd_of_int ?(close_unix = true) ~sw n = Eio_unix.Fd.of_unix ~close_unix ~sw (Obj.magic n : Unix.file_descr) let handle_one_redirection ~sw ctx = function | Ast.IoRedirect_IoFile (n, (op, file)) -> ( match op with | Io_op_less -> (* Simple redirection for input *) let r = Eio.Path.open_in ~sw (ctx.fs / Ast.word_components_to_string file) in let fd = Eio_unix.Resource.fd_opt r |> Option.get in [ Types.Redirect (n, fd, `Blocking) ] | Io_op_lessand -> ( match file with | [ WordLiteral "-" ] -> if n = 0 then [ Types.Close Eio_unix.Fd.stdin ] else let fd = fd_of_int ~sw n in [ Types.Close fd ] | [ WordLiteral m ] when Option.is_some (int_of_string_opt m) -> let m = int_of_string m in [ Types.Redirect (n, fd_of_int ~close_unix:false ~sw m, `Blocking); ] | _ -> []) | (Io_op_great | Io_op_dgreat) as v -> (* Simple file creation *) let append = v = Io_op_dgreat in let create = if append then `Never else if ctx.options.noclobber then `Exclusive 0o644 else `Or_truncate 0o644 in let w = Eio.Path.open_out ~sw ~append ~create (ctx.fs / Ast.word_components_to_string file) in let fd = Eio_unix.Resource.fd_opt w |> Option.get in [ Types.Redirect (n, fd, `Blocking) ] | Io_op_greatand -> ( match file with | [ WordLiteral "-" ] -> if n = 0 then [ Types.Close Eio_unix.Fd.stdout ] else let fd = fd_of_int ~sw n in [ Types.Close fd ] | [ WordLiteral m ] when Option.is_some (int_of_string_opt m) -> let m = int_of_string m in [ Types.Redirect (n, fd_of_int ~close_unix:false ~sw m, `Blocking); ] | _ -> []) | Io_op_andgreat -> (* Yesh, not very POSIX *) (* Simple file creation *) let w = Eio.Path.open_out ~sw ~create:(`If_missing 0o644) (ctx.fs / Ast.word_components_to_string file) in let fd = Eio_unix.Resource.fd_opt w |> Option.get in [ Types.Redirect (1, fd, `Blocking); Types.Redirect (2, fd, `Blocking); ] | Io_op_clobber -> let w = Eio.Path.open_out ~sw ~create:(`Or_truncate 0o644) (ctx.fs / Ast.word_components_to_string file) in let fd = Eio_unix.Resource.fd_opt w |> Option.get in [ Types.Redirect (n, fd, `Blocking) ] | Io_op_lessgreat -> Fmt.failwith "<> not support yet.") | Ast.IoRedirect_IoHere _ -> Fmt.failwith "HERE documents not yet implemented!" let handle_redirections ~sw ctx rdrs = try Ok (List.concat_map (handle_one_redirection ~sw ctx) rdrs) with Eio.Io (Eio.Fs.E (Already_exists _), _) -> Fmt.epr "msh: cannot overwrite existing file\n%!"; Error ctx let cwd_of_ctx ctx = S.cwd ctx.state |> Fpath.to_string |> ( / ) ctx.fs let needs_glob_expansion : Ast.word_component -> bool = function | WordGlobAll | WordGlobAny -> true | _ -> false let resolve_program ?(update = true) ctx name = let v = if not (String.contains name '/') then begin S.lookup ctx.state ~param:"PATH" |> Option.map Ast.word_components_to_string |> Option.value ~default:"/bin:/usr/bin" |> String.split_on_char ':' |> List.find_map (fun dir -> let p = Filename.concat dir name in if Sys.file_exists p then Some p else None) end else if Sys.file_exists name then Some name else None in match (update, v) with | true, Some loc -> let hash = Hash.add ~utility:name ~loc ctx.hash in ({ ctx with hash }, Some loc) | false, Some loc -> (ctx, Some loc) | _, None -> (ctx, None) let get_env ?(extra = []) ctx = let extra = extra @ List.map (fun (k, v) -> (k, Ast.word_components_to_string v)) @@ S.exports ctx.state in let env = Eunix.env () in List.fold_left (fun acc (k, _) -> List.remove_assoc k acc) env extra |> List.append extra let update ?export ?readonly ctx ~param v = match S.update ?export ?readonly ctx.state ~param v with | Ok state -> Exit.zero { ctx with state } | Error msg -> Fmt.epr "%s\n%!" msg; Exit.nonzero ctx 1 let remove_quotes s = let s_len = String.length s in if s.[0] = '"' && s.[s_len - 1] = '"' then String.sub s 1 (s_len - 2) else s let exit ctx code = 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 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 = match (executable, resolve_program ctx executable) with | _, (ctx, None) | "", (ctx, _) -> Eunix.with_redirections fds (fun () -> Eio.Flow.copy_string (Fmt.str "msh: command not found: %s\n" executable) stdout); (ctx, Error (127, `Not_found)) | _, (ctx, Some full_path) -> ( ctx, E.exec ctx.executor ~delay_reap:(fst reap) ~fds ?stdin ~stdout ~pgid ~mode ~cwd:(cwd_of_ctx ctx) ~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) in let job_pgid (t : J.t) = J.get_id t in let rec loop pipeline_switch (ctx : ctx) (job : J.t) (stdout_of_previous : Eio_unix.source_ty Eio_unix.source option) : Ast.command list -> ctx * J.t = fun c -> let loop = loop pipeline_switch in match c with | Ast.SimpleCommand (Prefixed (prefix, None, _suffix)) :: rest -> let ctx = collect_assignments ctx prefix in let job = handle_job job (`Built_in (Exit.ignore ctx)) in loop (Exit.value ctx) job stdout_of_previous rest | Ast.SimpleCommand (Prefixed (prefix, Some executable, suffix)) :: rest -> let ctx = collect_assignments ~update:false ctx prefix in let job = handle_job job (`Built_in (Exit.ignore ctx)) in loop (Exit.value ctx) job stdout_of_previous (Ast.SimpleCommand (Named (executable, suffix)) :: rest) | Ast.SimpleCommand (Named (executable, suffix)) :: rest -> ( let ctx, executable = expand_cst ctx executable in match ctx with | Exit.Nonzero _ as ctx -> let job = handle_job job (`Built_in (Exit.ignore ctx)) in loop (Exit.value ctx) job stdout_of_previous rest | Exit.Zero ctx -> ( let executable = handle_word_cst_subshell ctx executable in let executable, extra_args = (* This is a side-effect of the alias command with something like alias ls="ls -la" *) match executable with | [ Ast.WordLiteral s ] as v -> ( match String.split_on_char ' ' (remove_quotes s) with | exec :: args -> ( [ Ast.WordName exec ], List.map (fun w -> Ast.Suffix_word [ Ast.WordName w ]) args ) | _ -> (v, [])) | v -> (v, []) in let executable = Ast.word_components_to_string executable in let ctx, suffix = match suffix with | None -> (ctx, []) | Some suffix -> expand_redirects (ctx, []) suffix in let ctx, args = args ctx (extra_args @ suffix) in match ctx with | Exit.Nonzero _ as ctx -> let job = handle_job job (`Built_in (Exit.ignore ctx)) in loop (Exit.value ctx) job stdout_of_previous rest | Exit.Zero ctx -> ( let args_as_strings = List.map Ast.word_components_to_string args in let some_read, some_write = stdout_for_pipeline ~sw:pipeline_switch ctx rest in let is_global, some_write = match some_write with | `Global p -> (true, p) | `Local p -> (false, p) in let rdrs = List.fold_left (fun acc -> function | Ast.Suffix_word _ -> acc | Ast.Suffix_redirect rdr -> rdr :: acc) [] suffix |> List.rev in match handle_redirections ~sw:pipeline_switch ctx rdrs with | Error ctx -> (ctx, handle_job job (`Rdr (Exit.nonzero () 1))) | Ok rdrs -> ( match Built_ins.of_args (executable :: args_as_strings) with | Some (Error _) -> (ctx, handle_job job (`Built_in (Exit.nonzero () 1))) | (None | Some (Ok (Command _))) as v -> ( let is_command, command_args, print_command = match v with | Some (Ok (Command { print_command; args })) -> (true, args, print_command) | _ -> (false, [], false) in (* We handle the [export] built_in explicitly as we need access to the raw CST *) match executable with | "export" -> let updated = handle_export_or_readonly `Export ctx args in let job = handle_job job (`Built_in (updated >|= fun _ -> ())) in loop (Exit.value updated) job stdout_of_previous rest | "readonly" -> let updated = handle_export_or_readonly `Readonly ctx args in let job = handle_job job (`Built_in (updated >|= fun _ -> ())) in loop (Exit.value updated) job stdout_of_previous rest | _ -> ( let saved_ctx = ctx in let func_app = if is_command then None else let ctx = { ctx with stdout = some_write } in handle_function_application ctx ~name:executable (ctx.program :: args_as_strings) in match func_app with | Some ctx -> close_stdout ~is_global some_write; (* TODO: Proper job stuff and redirects etc. *) let job = handle_job job (`Built_in (Exit.ignore ctx)) in loop saved_ctx job some_read rest | None -> ( match Built_ins.of_args command_args with | Some (Error _) -> ( ctx, handle_job job (`Built_in (Exit.nonzero () 1)) ) | Some (Ok bi) -> 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 exit v_ctx (Exit.code ctx) else handle_job job (`Exit (Exit.ignore ctx)) | _ -> handle_job job (`Built_in (Exit.ignore ctx)) in loop (Exit.value ctx) job some_read rest | _ -> ( let exec_and_args = if is_command then begin match command_args with | [] -> assert false | x :: xs -> ( Eunix.with_redirections rdrs @@ fun () -> match resolve_program ~update:false ctx x with | _, None -> Exit.nonzero ("", []) 1 | _, Some prog -> if print_command then Exit.zero ("echo", [ prog ]) else Exit.zero (x, xs)) end else Exit.zero (executable, args_as_strings) in match exec_and_args with | Exit.Nonzero _ as v -> let job = handle_job job (`Built_in (Exit.ignore v)) in loop ctx job some_read rest | Exit.Zero (executable, args) -> ( match stdout_of_previous with | None -> let ctx, job = exec_process ~sw:pipeline_switch ctx job ~fds:rdrs ~stdout:some_write ~pgid:(job_pgid job) executable args in close_stdout ~is_global some_write; loop ctx job some_read rest | Some stdout -> let ctx, job = exec_process ~sw:pipeline_switch ctx job ~fds:rdrs ~stdin:stdout ~stdout:some_write ~pgid:(job_pgid job) executable args_as_strings in close_stdout ~is_global some_write; loop ctx job some_read rest))))) | Some (Ok bi) -> 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)) in loop (Exit.value ctx) job some_read rest)))) | CompoundCommand (c, rdrs) :: rest -> ( match handle_redirections ~sw:pipeline_switch ctx rdrs with | Error ctx -> (ctx, handle_job job (`Rdr (Exit.nonzero () 1))) | Ok rdrs -> (* TODO: No way this is right *) let ctx = { ctx with rdrs } in let ctx = handle_compound_command ctx c in let job = handle_job job (`Built_in (ctx >|= fun _ -> ())) in let actual_ctx = Exit.value ctx in loop { actual_ctx with rdrs = [] } job None rest) | FunctionDefinition (name, (body, _rdrs)) :: rest -> let ctx = { ctx with functions = (name, body) :: ctx.functions } in loop ctx job None rest | [] -> (clear_local_state ctx, job) in Eio.Switch.run @@ fun sw -> let initial_job = J.make 0 [] in let saved_ctx = initial_ctx in let subshell = saved_ctx.subshell || List.length p > 1 in let ctx = { initial_ctx with subshell } in let ctx, job = loop sw ctx initial_job None p in match J.size job with | 0 -> Exit.zero ctx | _ -> if not async then begin J.await_exit ~pipefail:ctx.options.pipefail ~interactive:ctx.interactive job >|= fun () -> { ctx with subshell = saved_ctx.subshell } end else begin Exit.zero { ctx with background_jobs = job :: ctx.background_jobs; subshell = saved_ctx.subshell; } end and parameter_expansion' ctx ast = let get_prefix ~pattern ~kind param = let _, prefix = String.fold_left (fun (so_far, acc) c -> match acc with | Some s when kind = `Smallest -> (so_far, Some s) | _ -> ( let s = so_far ^ String.make 1 c in match Glob.tests ~pattern [ s ] with | [ s ] -> (s, Some s) | _ -> (s, acc))) ("", None) param in prefix in let get_suffix ~pattern ~kind param = let _, prefix = String.fold_left (fun (so_far, acc) c -> match acc with | Some s when kind = `Smallest -> (so_far, Some s) | _ -> ( let s = String.make 1 c ^ so_far in match Glob.tests ~pattern [ s ] with | [ s ] -> (s, Some s) | _ -> (s, acc))) ("", None) (String.fold_left (fun acc c -> String.make 1 c ^ acc) "" param) in prefix in let rec expand acc ctx = function | [] -> (Exit.zero ctx, List.rev acc |> List.concat) | Ast.WordVariable v :: rest -> ( match v with | Ast.VariableAtom ("!", NoAttribute) -> expand ([ Ast.WordName ctx.last_background_process ] :: acc) ctx rest | Ast.VariableAtom (n, NoAttribute) when Option.is_some (int_of_string_opt n) -> ( let n = int_of_string n in match Array.get ctx.argv n with | v -> expand ([ Ast.WordName v ] :: acc) ctx rest | exception Invalid_argument _ -> expand ([ Ast.WordName "" ] :: acc) ctx rest) | Ast.VariableAtom (s, NoAttribute) -> ( match S.lookup ctx.state ~param:s with | None -> if ctx.options.no_unset then begin ( Exit.nonzero_msg ctx ~exit_code:1 "%s: unbound variable" s, List.rev acc |> List.concat ) end else expand ([ Ast.WordName "" ] :: acc) ctx rest | Some cst -> expand (cst :: acc) ctx rest) | Ast.VariableAtom (s, ParameterLength) -> ( match S.lookup ctx.state ~param:s with | None -> expand ([ Ast.WordLiteral "0" ] :: acc) ctx rest | Some cst -> expand ([ Ast.WordLiteral (string_of_int (String.length (Ast.word_components_to_string cst))); ] :: acc) ctx rest) | Ast.VariableAtom (s, UseDefaultValues (_, cst)) -> ( match S.lookup ctx.state ~param:s with | None -> expand (cst :: acc) ctx rest | Some cst -> expand (cst :: acc) ctx rest) | Ast.VariableAtom ( s, (( RemoveSmallestPrefixPattern cst | RemoveLargestPrefixPattern cst ) as v) ) -> ( let ctx, spp = expand_cst ctx cst in match ctx with | Exit.Nonzero _ as ctx -> (ctx, List.rev acc |> List.concat) | Exit.Zero ctx -> ( let pattern = Ast.word_components_to_string spp in match S.lookup ctx.state ~param:s with | None -> expand (cst :: acc) ctx rest | Some cst -> ( let kind = match v with | RemoveSmallestPrefixPattern _ -> `Smallest | RemoveLargestPrefixPattern _ -> `Largest | _ -> assert false in let param = Ast.word_components_to_string cst in let prefix = get_prefix ~pattern ~kind param in match prefix with | None -> expand ([ Ast.WordName param ] :: acc) ctx rest | Some s -> ( match String.cut_prefix ~prefix:s param with | Some s -> expand ([ Ast.WordName s ] :: acc) ctx rest | None -> expand ([ Ast.WordName param ] :: acc) ctx rest))) ) | Ast.VariableAtom ( s, (( RemoveSmallestSuffixPattern cst | RemoveLargestSuffixPattern cst ) as v) ) -> ( let ctx, spp = expand_cst ctx cst in let pattern = Ast.word_components_to_string spp in match ctx with | Exit.Nonzero _ as ctx -> (ctx, List.rev acc |> List.concat) | Exit.Zero ctx -> ( match S.lookup ctx.state ~param:s with | None -> expand (cst :: acc) ctx rest | Some cst -> ( let kind = match v with | RemoveSmallestSuffixPattern _ -> `Smallest | RemoveLargestSuffixPattern _ -> `Largest | _ -> assert false in let param = Ast.word_components_to_string cst in let suffix = get_suffix ~pattern ~kind param in match suffix with | None -> expand ([ Ast.WordName param ] :: acc) ctx rest | Some s -> ( match String.cut_suffix ~suffix:s param with | Some s -> expand ([ Ast.WordName s ] :: acc) ctx rest | None -> expand ([ Ast.WordName param ] :: acc) ctx rest))) ) | Ast.VariableAtom (s, UseAlternativeValue (_, alt)) -> ( match S.lookup ctx.state ~param:s with | Some _ -> expand (alt :: acc) ctx rest | None -> expand ([ Ast.WordEmpty ] :: acc) ctx rest) | Ast.VariableAtom (s, AssignDefaultValues (_, value)) -> ( match S.lookup ctx.state ~param:s with | Some cst -> expand (cst :: acc) ctx rest | None -> ( match S.update ctx.state ~param:s value with | Ok state -> let new_ctx = { ctx with state } in expand (value :: acc) new_ctx rest | Error m -> ( Exit.nonzero_msg ~exit_code:1 ctx "%s" m, List.rev acc |> List.concat ))) | Ast.VariableAtom (_, IndicateErrorifNullorUnset (_, _)) -> Fmt.failwith "TODO: Indicate Error") | Ast.WordDoubleQuoted cst :: rest -> ( let new_ctx, cst_acc = expand [] ctx cst in match new_ctx with | Exit.Nonzero _ -> (new_ctx, cst_acc) | Exit.Zero new_ctx -> expand ([ Ast.WordDoubleQuoted cst_acc ] :: acc) new_ctx rest) | Ast.WordSingleQuoted cst :: rest -> ( let new_ctx, cst_acc = expand [] ctx cst in match new_ctx with | Exit.Nonzero _ -> (new_ctx, cst_acc) | Exit.Zero new_ctx -> expand ([ Ast.WordSingleQuoted cst_acc ] :: acc) new_ctx rest) | Ast.WordAssignmentWord (n, w) :: rest -> ( let new_ctx, cst_acc = expand [] ctx w in match new_ctx with | Exit.Nonzero _ -> (new_ctx, cst_acc) | Exit.Zero new_ctx -> expand ([ Ast.WordAssignmentWord (n, cst_acc) ] :: acc) new_ctx rest) | v :: rest -> expand ([ v ] :: acc) ctx rest in expand [] ctx ast and handle_export_or_readonly kind ctx (assignments : Ast.word_cst list) = let flags, assignments = List.fold_left (fun (fs, args) -> function | [ Ast.WordName v ] | [ Ast.WordLiteral v ] -> ( match Astring.String.cut ~sep:"-" v with | Some ("", f) -> (f :: fs, args) | _ -> (fs, [ Ast.WordName v ] :: args)) | v -> (fs, v :: args)) ([], []) assignments in let update = match kind with | `Export -> update ~export:true ~readonly:false | `Readonly -> update ~export:false ~readonly:true in let rec loop acc_ctx = function | [] -> Exit.zero acc_ctx | Ast.WordAssignmentWord (Name param, v) :: rest -> update acc_ctx ~param v >>= fun new_ctx -> loop new_ctx rest | Ast.WordName param :: rest -> ( match S.lookup acc_ctx.state ~param with | Some v -> update acc_ctx ~param v >>= fun new_ctx -> loop new_ctx rest | None -> loop acc_ctx rest) | c :: _ -> Exit.nonzero_msg acc_ctx "export weird arguments: %s\n" (Ast.word_component_to_string c) in match flags with | [] -> List.fold_left (fun ctx w -> match ctx with Exit.Zero ctx -> loop ctx w | _ -> ctx) (Exit.zero ctx) assignments | fs -> if List.mem "p" fs then begin match kind with | `Readonly -> S.pp_readonly Fmt.stdout ctx.state | `Export -> S.pp_export Fmt.stdout ctx.state end; Exit.zero ctx and expand_cst (ctx : ctx) cst : ctx Exit.t * Ast.word_cst = let cst = tilde_expansion ctx cst in let ctx, cst = parameter_expansion' ctx cst in match ctx with | Exit.Nonzero _ as ctx -> (ctx, cst) | Exit.Zero ctx -> (* TODO: Propagate errors *) let ctx, ast = arithmetic_expansion ctx cst in (Exit.zero ctx, ast) and expand_redirects ((ctx, acc) : ctx * Ast.cmd_suffix_item list) (c : Ast.cmd_suffix_item list) = match c with | [] -> (ctx, List.rev acc) | Ast.Suffix_redirect (IoRedirect_IoFile (num, (op, file))) :: rest -> ( let ctx, cst = expand_cst ctx file in match ctx with | Exit.Nonzero _ -> assert false | Exit.Zero ctx -> let cst = handle_subshell ctx cst in let v = Ast.Suffix_redirect (IoRedirect_IoFile (num, (op, cst))) in expand_redirects (ctx, v :: acc) rest) | (Ast.Suffix_redirect _ as v) :: rest -> expand_redirects (ctx, v :: acc) rest | s :: rest -> expand_redirects (ctx, s :: acc) rest and handle_and_or ~sw:_ ~async ctx c = let pipeline = function | Ast.Pipeline p -> (Fun.id, p) | Ast.Pipeline_Bang p -> (Exit.not, p) in let rec fold : Ast.and_or * ctx Exit.t -> Ast.pipeline Ast.and_or_list -> ctx Exit.t = fun (sep, exit_so_far) pipe -> match (sep, pipe) with | And, Nlist.Singleton (p, _) -> ( match exit_so_far with | Exit.Zero ctx -> let f, p = pipeline p in f @@ handle_pipeline ~async ctx p | v -> v) | Or, Nlist.Singleton (p, _) -> ( match exit_so_far with | Exit.Zero _ as ctx -> ctx | _ -> let f, p = pipeline p in f @@ handle_pipeline ~async ctx p) | Noand_or, Nlist.Singleton (p, _) -> let f, p = pipeline p in f @@ handle_pipeline ~async ctx p | Noand_or, Nlist.Cons ((p, next_sep), rest) -> let f, p = pipeline p in let exit_status = f (handle_pipeline ~async ctx p) in fold (next_sep, exit_status) rest | And, Nlist.Cons ((p, next_sep), rest) -> ( match exit_so_far with | Exit.Zero ctx -> let f, p = pipeline p in fold (next_sep, f (handle_pipeline ~async ctx p)) rest | Exit.Nonzero _ as v -> v) | Or, Nlist.Cons ((p, next_sep), rest) -> ( match exit_so_far with | Exit.Zero _ as exit_so_far -> fold (next_sep, exit_so_far) rest | Exit.Nonzero _ -> let f, p = pipeline p in fold (next_sep, f (handle_pipeline ~async ctx p)) rest) in fold (Noand_or, Exit.zero ctx) c and handle_for_clause ctx v : ctx Exit.t = match v with | Ast.For_Name_DoGroup (_, (term, sep)) -> exec ctx (term, Some sep) | Ast.For_Name_In_WordList_DoGroup (Name name, wdlist, (term, sep)) -> let wdlist = Nlist.flatten @@ Nlist.map (word_glob_expand ctx) wdlist in Nlist.fold_left (fun _ word -> update ctx ~param:name word >>= fun ctx -> exec ctx (term, Some sep)) (Exit.zero ctx) wdlist and handle_if_clause ctx = function | Ast.If_then ((e1, sep1), (e2, sep2)) -> ( let ctx = exec ctx (e1, Some sep1) in match ctx with | Exit.Zero ctx -> exec ctx (e2, Some sep2) | Exit.Nonzero { value = ctx; _ } -> Exit.zero ctx) | Ast.If_then_else ((e1, sep1), (e2, sep2), else_part) -> ( let ctx = exec ctx (e1, Some sep1) in match ctx with | Exit.Zero ctx -> exec ctx (e2, Some sep2) | Exit.Nonzero { value = ctx; _ } -> handle_else_part ctx else_part) and handle_else_part ctx = function | Ast.Else (c, sep) -> exec ctx (c, Some sep) | Ast.Elif_then ((e1, sep1), (e2, sep2)) -> ( let ctx = exec ctx (e1, Some sep1) in match ctx with | Exit.Zero ctx -> exec ctx (e2, Some sep2) | Exit.Nonzero { value = ctx; _ } -> Exit.zero ctx) | Ast.Elif_then_else ((e1, sep1), (e2, sep2), else_part) -> ( let ctx = exec ctx (e1, Some sep1) in match ctx with | Exit.Zero ctx -> exec ctx (e2, Some sep2) | Exit.Nonzero { value = ctx; _ } -> handle_else_part ctx else_part) and handle_case_clause ctx = function | Ast.Case _ -> Exit.zero ctx | Cases (word, case_list) -> ( let ctx, word = expand_cst ctx word in match ctx with | Exit.Nonzero _ as ctx -> ctx | Exit.Zero ctx -> ( let scrutinee = Ast.word_components_to_string word in let res = Nlist.fold_left (fun acc pat -> match acc with | Some _ as ctx -> ctx | None -> ( match pat with | Ast.Case_pattern (p, sub) -> Nlist.fold_left (fun inner_acc pattern -> match inner_acc with | Some _ as v -> v | None -> ( let ctx, pattern = expand_cst ctx pattern in match ctx with | Exit.Nonzero _ as ctx -> Some ctx | Exit.Zero ctx -> let pattern = Ast.word_components_to_string pattern in if Glob.test ~pattern scrutinee then begin match sub with | Some sub -> Some (exec_subshell ctx sub) | None -> Some (Exit.zero ctx) end else inner_acc)) None p)) None case_list in match res with Some ctx -> ctx | None -> Exit.zero ctx)) and exec_subshell ctx (term, sep) = let saved_ctx = ctx in let e = exec ctx (term, Some sep) in let v = e >|= fun _ -> saved_ctx in v and handle_while_clause ctx (While ((term, sep), (term', sep')) : Ast.while_clause) = let rec loop exit_so_far = let running_ctx = Exit.value exit_so_far in match exec running_ctx (term, Some sep) with | Exit.Nonzero _ -> exit_so_far (* TODO: Context? *) | Exit.Zero ctx -> loop (exec ctx (term', Some sep')) in loop (Exit.zero ctx) and handle_until_clause ctx (Until ((term, sep), (term', sep')) : Ast.until_clause) = let rec loop exit_so_far = let running_ctx = Exit.value exit_so_far in match exec running_ctx (term, Some sep) with | Exit.Zero _ -> exit_so_far (* TODO: Context? *) | Exit.Nonzero { value = ctx; _ } -> loop (exec ctx (term', Some sep')) in loop (Exit.zero ctx) and handle_compound_command ctx v : ctx Exit.t = match v with | Ast.ForClause fc -> handle_for_clause ctx fc | Ast.IfClause if_ -> handle_if_clause ctx if_ | Ast.BraceGroup (term, sep) -> exec ctx (term, Some sep) | Ast.Subshell s -> exec_subshell ctx s | Ast.CaseClause cases -> handle_case_clause ctx cases | Ast.WhileClause while_ -> handle_while_clause ctx while_ | Ast.UntilClause until -> handle_until_clause ctx until and handle_function_application (ctx : ctx) ~name argv : ctx Exit.t option = match List.assoc_opt name ctx.functions with | None -> None | Some commands -> let ctx = { ctx with argv = Array.of_list argv } in Option.some @@ (handle_compound_command ctx commands >|= fun _ -> ctx) and needs_subshelling = function | [] -> false | Ast.WordSubshell _ :: _ -> true | Ast.WordDoubleQuoted word :: rest -> needs_subshelling word || needs_subshelling rest | Ast.WordSingleQuoted word :: rest -> needs_subshelling word || needs_subshelling rest | _ -> false and handle_subshell (ctx : ctx) wcs = let exec_subshell ~sw ctx s = let buf = Buffer.create 16 in let stdout = Eio.Flow.buffer_sink buf in let r, w = Eio_unix.pipe sw in Eio.Fiber.fork ~sw (fun () -> Eio.Flow.copy r stdout); let subshell_ctx = { ctx with stdout = w; subshell = true } in let sub_ctx, _ = run (Exit.zero subshell_ctx) s in Eio.Flow.close w; ((sub_ctx >|= fun _ -> ctx), Buffer.contents buf) in let rec run_subshells ~sw ran_subshell = function | [] -> [] | Ast.WordSubshell s :: rest -> let _ctx, std = exec_subshell ~sw ctx s in ran_subshell := true; Ast.WordName (String.trim std) :: run_subshells ~sw ran_subshell rest | Ast.WordDoubleQuoted word :: rest -> let subshell_q = ref false in let res = run_subshells ~sw subshell_q word in if !subshell_q then res @ run_subshells ~sw subshell_q rest else Ast.WordDoubleQuoted res :: run_subshells ~sw subshell_q rest | Ast.WordSingleQuoted word :: rest -> let subshell_q = ref false in let res = run_subshells ~sw subshell_q word in if !subshell_q then res @ run_subshells ~sw subshell_q rest else Ast.WordSingleQuoted res :: run_subshells ~sw subshell_q rest | v :: rest -> v :: run_subshells ~sw ran_subshell rest in Eio.Switch.run @@ fun sw -> run_subshells ~sw (ref false) wcs and handle_word_cst_subshell (ctx : ctx) wcs : Ast.word_cst = if needs_subshelling wcs then begin let wcs = handle_subshell ctx wcs in wcs end else wcs and glob_expand ctx wc = let wc = handle_word_cst_subshell ctx wc in if Ast.has_glob wc && not ctx.options.no_path_expansion then Ast.word_components_to_string wc |> fun pattern -> Glob.glob_dir ~pattern (cwd_of_ctx ctx) |> List.map (fun w -> [ Ast.WordName w ]) else [ wc ] and word_glob_expand (ctx : ctx) wc : Ast.word_cst list = if List.exists needs_glob_expansion wc then glob_expand ctx wc else [ handle_word_cst_subshell ctx wc ] and collect_assignments ?(update = true) ctx vs : ctx Exit.t = List.fold_left (fun ctx prefix -> match ctx with | Exit.Nonzero _ -> ctx | Exit.Zero ctx -> ( match prefix with | Ast.Prefix_assignment (Name param, v) -> ( (* Expand the values *) let ctx, v = expand_cst ctx v in match ctx with | Exit.Nonzero _ as ctx -> ctx | Exit.Zero ctx -> ( let v = handle_subshell ctx v in let state = if update then S.update ctx.state ~param v else Ok ctx.state in match state with | Error message -> Exit.nonzero ~message ctx 1 | Ok state -> Exit.zero { ctx with state; local_state = (param, Ast.word_components_to_string v) :: ctx.local_state; })) | _ -> Exit.zero ctx)) (Exit.zero ctx) vs and args ctx swc : ctx Exit.t * Ast.word_cst list = List.fold_left (fun (ctx, acc) -> function | Ast.Suffix_redirect _ -> (ctx, acc) | Suffix_word wc -> ( match ctx with | Exit.Nonzero _ as ctx -> (ctx, acc) | Exit.Zero ctx -> ( let ctx, cst = expand_cst ctx wc in match ctx with | Exit.Nonzero _ as ctx -> (ctx, acc) | Exit.Zero c as ctx -> (ctx, acc @ word_glob_expand c cst)))) (Exit.zero ctx, []) swc 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 rdrs @@ fun () -> 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 Exit.zero @@ S.set_cwd ctx.state fp 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 | 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 -> ( match resolve_program ctx file with | ctx, None -> Exit.nonzero ctx 127 | ctx, Some f -> let program = Ast.of_file (ctx.fs / f) in let ctx, _ = run (Exit.zero ctx) program in 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 () 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 | Command _ -> (* Handled separately *) assert false and exec initial_ctx ((command, sep) : Ast.complete_command) = let rec loop : Eio.Switch.t -> ctx -> Ast.clist -> ctx Exit.t = fun sw ctx -> function | Nlist.Singleton (c, sep) -> let async = match sep with Semicolon -> false | Ampersand -> true in handle_and_or ~sw ~async ctx c | Nlist.Cons ((c, sep), cs) -> ( let async = match sep with Semicolon -> false | Ampersand -> true in match handle_and_or ~sw ~async ctx c with | Exit.Zero ctx -> loop sw ctx cs | v -> v) in match sep with | Some Semicolon | None -> Eio.Switch.run @@ fun sw -> loop sw initial_ctx command | Some Ampersand -> Fiber.fork ~sw:initial_ctx.async_switch (fun () -> Fiber.yield (); let _ : ctx Exit.t = loop initial_ctx.async_switch initial_ctx command in ()); Exit.zero initial_ctx and execute ctx ast = exec ctx ast and run ctx ast = (* Make the shell its own process group *) Eunix.make_process_group (); let ctx, cs = let rec loop_commands (ctx, cs) (c : Ast.complete_commands) = match c with | [] -> (ctx, cs) | command :: commands -> ( let ctx = Exit.value ctx in (* For our sanity *) let has_async = Ast.has_async command in if has_async && not ctx.options.async then begin Fmt.epr "You are using asynchronous operators and [set -o async] has \ not been called.\n\ %!"; exit ctx 1 end; let exit = try execute ctx command with | Eio.Io (Eio.Process.E (Eio.Process.Executable_not_found m), _ctx) -> Exit.nonzero_msg ctx ~exit_code:127 "command not found: %s" m in match exit with | Exit.Nonzero { exit_code; message; should_exit; _ } -> ( Option.iter (Fmt.epr "%s\n%!") message; match ( should_exit.interactive, should_exit.non_interactive, ctx.subshell, ctx.interactive, commands ) with | `Yes, _, false, true, [] | _, `Yes, false, false, [] -> if should_exit.interactive = `Yes then Fmt.epr "exit\n%!"; Stdlib.exit exit_code | _ -> loop_commands (exit, c :: cs) commands) | Exit.Zero _ as ctx -> loop_commands (ctx, c :: cs) commands) in loop_commands (ctx, []) ast in (ctx, List.rev cs) end