Something went wrong. Try again.
Shells in OCaml forked from patrick.sirref.org/merry
Something went wrong. Try again.
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290(*----------------------------------------------------------------- Copyright (c) 2025 The merry programmers. All rights reserved. SPDX-License-Identifier: ISC -----------------------------------------------------------------*)open Eio.Stdopen Importopen 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