Shells in OCaml
1(*-----------------------------------------------------------------
2 Copyright (c) 2025 The merry programmers. All rights reserved.
3 SPDX-License-Identifier: ISC
4 -----------------------------------------------------------------*)
5open Eio.Std
6open Import
7open Exit.Syntax
8
9(** An evaluator over the AST *)
10module Make (S : Types.State) (E : Types.Exec) = struct
11 (* What follows uses the POSIX definition of what a shell does ($ 2.1).
12
13 It starts from point (4), completing a series of expansions on the AST,
14 then redirection is setup, and finally functions/built-ins/commands are
15 executed. *)
16
17 module J = Job.Make (E)
18 module A = Arith.Make (S)
19
20 class default_map =
21 object (_)
22 inherit Ast.map
23 method string (s : string) = s
24 method int (i : int) = i
25 method char c = c
26 method option f v = Option.map f v
27 method nlist__t f t = Nlist.map f t
28 method nslist__t f t = Nslist.map f t
29 method list f t = List.map f t
30 end
31
32 type ctx = {
33 interactive : bool;
34 subshell : bool;
35 state : S.t;
36 local_state : (string * string) list;
37 executor : E.t;
38 fs : Eio.Fs.dir_ty Eio.Path.t;
39 options : Built_ins.Options.t;
40 stdin : Eio_unix.source_ty Eio.Flow.source;
41 stdout : Eio_unix.sink_ty Eio.Flow.sink;
42 background_jobs : J.t list;
43 last_background_process : string;
44 async_switch : Eio.Switch.t;
45 program : string;
46 argv : string array;
47 functions : (string * Ast.compound_command) list;
48 hash : Hash.t;
49 }
50
51 let clear_local_state ctx = { ctx with local_state = [] }
52
53 class default_ctx_fold =
54 object (_)
55 inherit [ctx] Ast.fold
56 method int _ ctx = ctx
57 method string _ ctx = ctx
58 method char _ ctx = ctx
59 method option f v ctx = Option.fold ~none:ctx ~some:(fun i -> f i ctx) v
60 method nlist__t f v ctx = Nlist.fold_left (fun acc i -> f i acc) ctx v
61
62 method nslist__t f g v ctx =
63 Nslist.fold_left (fun acc a b -> f a acc |> g b) ctx v
64
65 method list f v ctx = List.fold_left (fun acc i -> f i acc) ctx v
66 end
67
68 let map_word_components f ast =
69 let o =
70 object (_)
71 inherit default_map
72 method! word_component cst = f cst
73 end
74 in
75 o#complete_command ast
76
77 let map_words ?(skip_for_clauses = true) f =
78 let o =
79 object (_)
80 inherit default_map as super
81 method! word cst = f cst
82
83 method! for_clause cst =
84 if skip_for_clauses then cst else super#for_clause cst
85 end
86 in
87 o
88
89 let rec tilde_expansion ctx = function
90 | [] -> []
91 | Ast.WordTildePrefix _ :: rest ->
92 Ast.WordName (S.expand ctx.state `Tilde) :: tilde_expansion ctx rest
93 | v :: rest -> v :: tilde_expansion ctx rest
94
95 let arithmetic_expansion ctx expr =
96 let rec fold (ctx, cst) = function
97 | [] -> (ctx, cst)
98 | Ast.WordArithmeticExpression word :: rest ->
99 let expr = Ast.word_components_to_string word in
100 let aexpr =
101 Arith_parser.main Arith_lexer.read (Lexing.from_string expr)
102 in
103 let state, i = A.eval ctx.state aexpr in
104 fold
105 ({ ctx with state }, Ast.WordLiteral (string_of_int i) :: cst)
106 rest
107 | Ast.WordDoubleQuoted dq :: rest ->
108 let ctx, v = fold (ctx, []) dq in
109 fold (ctx, Ast.WordDoubleQuoted (List.rev v) :: cst) rest
110 | Ast.WordSingleQuoted dq :: rest ->
111 let ctx, v = fold (ctx, []) dq in
112 fold (ctx, Ast.WordSingleQuoted (List.rev v) :: cst) rest
113 | v :: rest -> fold (ctx, v :: cst) rest
114 in
115 let state, cst = fold (ctx, []) expr in
116 (state, List.rev cst)
117
118 let stdout_for_pipeline ~sw ctx = function
119 | [] -> (None, `Global ctx.stdout)
120 | _ ->
121 let r, w = Eio_unix.pipe sw in
122 (Some r, `Local (w :> Eio_unix.sink_ty Eio.Flow.sink))
123
124 let fd_of_int ?(close_unix = true) ~sw n =
125 Eio_unix.Fd.of_unix ~close_unix ~sw (Obj.magic n : Unix.file_descr)
126
127 let handle_one_redirection ~sw ctx = function
128 | Ast.IoRedirect_IoFile (n, (op, file)) -> (
129 match op with
130 | Io_op_less ->
131 (* Simple redirection for input *)
132 let r =
133 Eio.Path.open_in ~sw (ctx.fs / Ast.word_components_to_string file)
134 in
135 let fd = Eio_unix.Resource.fd_opt r |> Option.get in
136 [ Types.Redirect (n, fd, `Blocking) ]
137 | Io_op_lessand -> (
138 match file with
139 | [ WordLiteral "-" ] ->
140 if n = 0 then [ Types.Close Eio_unix.Fd.stdin ]
141 else
142 let fd = fd_of_int ~sw n in
143 [ Types.Close fd ]
144 | [ WordLiteral m ] when Option.is_some (int_of_string_opt m) ->
145 let m = int_of_string m in
146 [
147 Types.Redirect
148 (n, fd_of_int ~close_unix:false ~sw m, `Blocking);
149 ]
150 | _ -> [])
151 | (Io_op_great | Io_op_dgreat) as v ->
152 (* Simple file creation *)
153 let append = v = Io_op_dgreat in
154 let w =
155 Eio.Path.open_out ~sw ~append ~create:(`If_missing 0o644)
156 (ctx.fs / Ast.word_components_to_string file)
157 in
158 let fd = Eio_unix.Resource.fd_opt w |> Option.get in
159 [ Types.Redirect (n, fd, `Blocking) ]
160 | Io_op_greatand -> (
161 match file with
162 | [ WordLiteral "-" ] ->
163 if n = 0 then [ Types.Close Eio_unix.Fd.stdout ]
164 else
165 let fd = fd_of_int ~sw n in
166 [ Types.Close fd ]
167 | [ WordLiteral m ] when Option.is_some (int_of_string_opt m) ->
168 let m = int_of_string m in
169 [
170 Types.Redirect
171 (n, fd_of_int ~close_unix:false ~sw m, `Blocking);
172 ]
173 | _ -> [])
174 | Io_op_andgreat ->
175 (* Yesh, not very POSIX *)
176 (* Simple file creation *)
177 let w =
178 Eio.Path.open_out ~sw ~create:(`If_missing 0o644)
179 (ctx.fs / Ast.word_components_to_string file)
180 in
181 let fd = Eio_unix.Resource.fd_opt w |> Option.get in
182 [
183 Types.Redirect (1, fd, `Blocking);
184 Types.Redirect (2, fd, `Blocking);
185 ]
186 | Io_op_clobber -> Fmt.failwith ">| not supported yet."
187 | Io_op_lessgreat -> Fmt.failwith "<> not support yet.")
188 | Ast.IoRedirect_IoHere _ ->
189 Fmt.failwith "HERE documents not yet implemented!"
190
191 let cwd_of_ctx ctx = S.cwd ctx.state |> Fpath.to_string |> ( / ) ctx.fs
192
193 let needs_glob_expansion : Ast.word_component -> bool = function
194 | WordGlobAll | WordGlobAny -> true
195 | _ -> false
196
197 let apply_pair (a, b) f = f a b
198 let ( ||> ) = apply_pair
199
200 let resolve_program ?(update = true) ctx name =
201 let v =
202 (* Fmt.epr "Resolving %s\n%!" name; *)
203 if not (String.contains name '/') then begin
204 (* Fmt.epr "not %a\n%!" Fmt.(option string) (S.lookup ctx.state ~param:"PATH" |> Option.map Ast.word_components_to_string); *)
205 S.lookup ctx.state ~param:"PATH"
206 |> Option.map Ast.word_components_to_string
207 |> Option.value ~default:"/bin:/usr/bin"
208 |> String.split_on_char ':'
209 |> List.find_map (fun dir ->
210 let p = Filename.concat dir name in
211 (* Fmt.epr "Does it exist %s %b\n%!" p (Sys.file_exists p); *)
212 if Sys.file_exists p then Some p else None)
213 end
214 else if Sys.file_exists name then Some name
215 else None
216 in
217 match (update, v) with
218 | true, Some loc ->
219 let hash = Hash.add ~utility:name ~loc ctx.hash in
220 ({ ctx with hash }, Some loc)
221 | false, Some loc -> (ctx, Some loc)
222 | _, None -> (ctx, None)
223
224 let get_env ?(extra = []) ctx =
225 let extra =
226 extra
227 @ List.map (fun (k, v) -> (k, Ast.word_components_to_string v))
228 @@ S.exports ctx.state
229 in
230 let env = Eunix.env () in
231 List.fold_left (fun acc (k, _) -> List.remove_assoc k acc) env extra
232 |> List.append extra
233
234 let remove_quotes s =
235 let s_len = String.length s in
236 if s.[0] = '"' && s.[s_len - 1] = '"' then String.sub s 1 (s_len - 2) else s
237
238 let rec handle_pipeline ~async initial_ctx p : ctx Exit.t =
239 let set_last_background ~async process ctx =
240 if async then
241 { ctx with last_background_process = string_of_int (E.pid process) }
242 else ctx
243 in
244 let on_process ?process ~async ctx =
245 let ctx = clear_local_state ctx in
246 match process with
247 | None -> ctx
248 | Some process -> set_last_background ~async process ctx
249 in
250 let handle_job j p =
251 match p with
252 (* | None, _ -> *)
253 (* let pgid = match pgid with Some p -> p | None -> Unix.getpid () in *)
254 (* Option.some *)
255 (* @@ J.make ~state:`Running ~reap:(Option.get reap) pgid *)
256 (* (Nlist.Singleton p) *)
257 | `Process p -> J.add_process p j
258 | `Built_in p -> J.add_built_in p j
259 | `Error p -> J.add_error p j
260 in
261 let close_stdout ~is_global some_write =
262 if not is_global then begin
263 Eio.Flow.close some_write
264 end
265 in
266 let exec_process ~sw ctx job ?fds ?stdin ~stdout ?pgid executable args =
267 let pgid = match pgid with None -> 0 | Some p -> p in
268 let reap = J.get_reaper job in
269 let mode = if async then Types.Async else Types.Switched sw in
270 let ctx, process =
271 match (executable, resolve_program ctx executable) with
272 | _, (ctx, None) | "", (ctx, _) ->
273 Eunix.with_redirections
274 (match fds with None -> [] | Some ls -> ls)
275 (fun () ->
276 Eio.Flow.copy_string
277 (Fmt.str "msh: command not found: %s\n" executable)
278 stdout);
279 (ctx, Error (127, `Not_found))
280 | _, (ctx, Some full_path) ->
281 ( ctx,
282 E.exec ctx.executor ~delay_reap:(fst reap) ?fds ?stdin ~stdout
283 ~pgid ~mode ~cwd:(cwd_of_ctx ctx)
284 ~env:(get_env ~extra:ctx.local_state ctx)
285 ~executable:full_path (executable :: args) )
286 in
287 match process with
288 | Error (n, _) ->
289 let job = handle_job job (`Error n) in
290 (on_process ~async ctx, job)
291 | Ok process ->
292 let pgid = if Int.equal pgid 0 then E.pid process else pgid in
293 let job =
294 handle_job job (`Process process) |> fun j -> { j with id = pgid }
295 in
296 (on_process ~async ~process ctx, job)
297 in
298 let job_pgid (t : J.t) = t.id in
299 let rec loop pipeline_switch (ctx : ctx) (job : J.t)
300 (stdout_of_previous : Eio_unix.source_ty Eio_unix.source option) :
301 Ast.command list -> ctx * J.t =
302 fun c ->
303 let loop = loop pipeline_switch in
304 match c with
305 | Ast.SimpleCommand (Prefixed (prefix, None, _suffix)) :: rest ->
306 let ctx = collect_assignments ctx prefix in
307 loop ctx job stdout_of_previous rest
308 | Ast.SimpleCommand (Prefixed (prefix, Some executable, suffix)) :: rest
309 ->
310 let ctx = collect_assignments ~update:false ctx prefix in
311 loop ctx job stdout_of_previous
312 (Ast.SimpleCommand (Named (executable, suffix)) :: rest)
313 | Ast.SimpleCommand (Named (executable, suffix)) :: rest -> (
314 let ctx, executable = expand_cst ctx executable in
315 let executable = handle_word_cst_subshell ctx executable in
316 let executable, extra_args =
317 (* This is a side-effect of the alias command with something like
318 alias ls="ls -la" *)
319 match executable with
320 | [ Ast.WordLiteral s ] as v -> (
321 match String.split_on_char ' ' (remove_quotes s) with
322 | exec :: args ->
323 ( [ Ast.WordName exec ],
324 List.map
325 (fun w -> Ast.Suffix_word [ Ast.WordName w ])
326 args )
327 | _ -> (v, []))
328 | v -> (v, [])
329 in
330 let executable = Ast.word_components_to_string executable in
331 let ctx, suffix =
332 match suffix with
333 | None -> (ctx, [])
334 | Some suffix -> expand_redirects (ctx, []) suffix
335 in
336 let ctx, args = args ctx (extra_args @ suffix) in
337 let args_as_strings = List.map Ast.word_components_to_string args in
338 let some_read, some_write =
339 stdout_for_pipeline ~sw:pipeline_switch ctx rest
340 in
341 let is_global, some_write =
342 match some_write with
343 | `Global p -> (true, p)
344 | `Local p -> (false, p)
345 in
346 let rdrs =
347 List.fold_left
348 (fun acc -> function
349 | Ast.Suffix_word _ -> acc
350 | Ast.Suffix_redirect rdr ->
351 handle_one_redirection ~sw:pipeline_switch ctx rdr @ acc)
352 [] suffix
353 |> List.rev
354 in
355 match Built_ins.of_args (executable :: args_as_strings) with
356 | Some (Error _) ->
357 (ctx, handle_job job (`Built_in (Exit.nonzero () 1)))
358 | (None | Some (Ok (Command _))) as v -> (
359 let is_command, command_args, print_command =
360 match v with
361 | Some (Ok (Command { print_command; args })) ->
362 (true, args, print_command)
363 | _ -> (false, [], false)
364 in
365 (* We handle the [export] built_in explicitly as we need access to the
366 raw CST *)
367 match executable with
368 | "export" ->
369 let updated = handle_export ctx args in
370 let job =
371 handle_job job (`Built_in (updated >|= fun _ -> ()))
372 in
373 loop (Exit.value updated) job stdout_of_previous rest
374 | _ -> (
375 let saved_ctx = ctx in
376 let func_app =
377 if is_command then None
378 else
379 let ctx = { ctx with stdout = some_write } in
380 handle_function_application ctx ~name:executable
381 (ctx.program :: args_as_strings)
382 in
383 match func_app with
384 | Some ctx ->
385 close_stdout ~is_global some_write;
386 (* TODO: Proper job stuff and redirects etc. *)
387 let job =
388 handle_job job (`Built_in (ctx >|= fun _ -> ()))
389 in
390 loop saved_ctx job some_read rest
391 | None -> (
392 match Built_ins.of_args command_args with
393 | Some (Error _) ->
394 (ctx, handle_job job (`Built_in (Exit.nonzero () 1)))
395 | Some (Ok bi) ->
396 let ctx =
397 handle_built_in ~rdrs ~stdout:some_write ctx bi
398 in
399 close_stdout ~is_global some_write;
400 let built_in = ctx >|= fun _ -> () in
401 let job = handle_job job (`Built_in built_in) in
402 loop (Exit.value ctx) job some_read rest
403 | _ -> (
404 let exec_and_args =
405 if is_command then begin
406 match command_args with
407 | [] -> assert false
408 | x :: xs -> (
409 Eunix.with_redirections rdrs @@ fun () ->
410 match resolve_program ~update:false ctx x with
411 | _, None -> Exit.nonzero ("", []) 1
412 | _, Some prog ->
413 if print_command then
414 Exit.zero ("echo", [ prog ])
415 else Exit.zero (x, xs))
416 end
417 else Exit.zero (executable, args_as_strings)
418 in
419 match exec_and_args with
420 | Exit.Nonzero _ as v ->
421 let job =
422 handle_job job (`Built_in (v >|= fun _ -> ()))
423 in
424 loop ctx job some_read rest
425 | Exit.Zero (executable, args) -> (
426 match stdout_of_previous with
427 | None ->
428 let ctx, job =
429 exec_process ~sw:pipeline_switch ctx job
430 ~fds:rdrs ~stdout:some_write
431 ~pgid:(job_pgid job) executable args
432 in
433 close_stdout ~is_global some_write;
434 loop ctx job some_read rest
435 | Some stdout ->
436 let ctx, job =
437 exec_process ~sw:pipeline_switch ctx job
438 ~fds:rdrs ~stdin:stdout ~stdout:some_write
439 ~pgid:(job_pgid job) executable
440 args_as_strings
441 in
442 close_stdout ~is_global some_write;
443 loop ctx job some_read rest)))))
444 | Some (Ok bi) ->
445 let ctx = handle_built_in ~rdrs ~stdout:some_write ctx bi in
446 close_stdout ~is_global some_write;
447 let built_in = ctx >|= fun _ -> () in
448 let job = handle_job job (`Built_in built_in) in
449 loop (Exit.value ctx) job some_read rest)
450 | CompoundCommand (c, rdrs) :: rest ->
451 let _rdrs =
452 List.map (handle_one_redirection ~sw:pipeline_switch ctx) rdrs
453 in
454 (* TODO: No way this is right *)
455 let ctx = handle_compound_command ctx c in
456 let job = handle_job job (`Built_in (ctx >|= fun _ -> ())) in
457 loop (Exit.value ctx) job None rest
458 | FunctionDefinition (name, (body, _rdrs)) :: rest ->
459 let ctx = { ctx with functions = (name, body) :: ctx.functions } in
460 loop ctx job None rest
461 | [] -> (clear_local_state ctx, job)
462 in
463 (* HACK: when running the pipeline, we need a process group to
464 put everything in. Eio's model of execution is nice, but we cannot
465 safely delay execution of a process. So instead we create a ghost
466 process that last just until all of the processes are setup. *)
467 Eio.Switch.run @@ fun sw ->
468 let initial_job = J.make 0 [] in
469 let ctx, job = loop sw initial_ctx initial_job None p in
470 match job.processes with
471 | [] -> Exit.zero ctx
472 | _ :: _ ->
473 if not async then begin
474 J.await_exit ~pipefail:false ~interactive:ctx.interactive job
475 >|= fun () -> ctx
476 end
477 else begin
478 Exit.zero { ctx with background_jobs = job :: ctx.background_jobs }
479 end
480
481 and parameter_expansion' ctx ast =
482 let get_prefix ~pattern ~kind param =
483 let _, prefix =
484 String.fold_left
485 (fun (so_far, acc) c ->
486 match acc with
487 | Some s when kind = `Smallest -> (so_far, Some s)
488 | _ -> (
489 let s = so_far ^ String.make 1 c in
490 match Glob.tests ~pattern [ s ] with
491 | [ s ] -> (s, Some s)
492 | _ -> (s, acc)))
493 ("", None) param
494 in
495 prefix
496 in
497 let get_suffix ~pattern ~kind param =
498 let _, prefix =
499 String.fold_left
500 (fun (so_far, acc) c ->
501 match acc with
502 | Some s when kind = `Smallest -> (so_far, Some s)
503 | _ -> (
504 let s = String.make 1 c ^ so_far in
505 match Glob.tests ~pattern [ s ] with
506 | [ s ] -> (s, Some s)
507 | _ -> (s, acc)))
508 ("", None)
509 (String.fold_left (fun acc c -> String.make 1 c ^ acc) "" param)
510 in
511 prefix
512 in
513 let rec expand acc ctx = function
514 | [] -> (ctx, List.rev acc |> List.concat)
515 | Ast.WordVariable v :: rest -> (
516 match v with
517 | Ast.VariableAtom ("!", NoAttribute) ->
518 expand
519 ([ Ast.WordName ctx.last_background_process ] :: acc)
520 ctx rest
521 | Ast.VariableAtom (n, NoAttribute)
522 when Option.is_some (int_of_string_opt n) -> (
523 let n = int_of_string n in
524 match Array.get ctx.argv n with
525 | v -> expand ([ Ast.WordName v ] :: acc) ctx rest
526 | exception Invalid_argument _ ->
527 expand ([ Ast.WordName "" ] :: acc) ctx rest)
528 | Ast.VariableAtom (s, NoAttribute) -> (
529 match S.lookup ctx.state ~param:s with
530 | None -> expand ([ Ast.WordName "" ] :: acc) ctx rest
531 | Some cst -> expand (cst :: acc) ctx rest)
532 | Ast.VariableAtom (s, ParameterLength) -> (
533 match S.lookup ctx.state ~param:s with
534 | None -> expand ([ Ast.WordLiteral "0" ] :: acc) ctx rest
535 | Some cst ->
536 expand
537 ([
538 Ast.WordLiteral
539 (string_of_int
540 (String.length (Ast.word_components_to_string cst)));
541 ]
542 :: acc)
543 ctx rest)
544 | Ast.VariableAtom (s, UseDefaultValues (_, cst)) -> (
545 match S.lookup ctx.state ~param:s with
546 | None -> expand (cst :: acc) ctx rest
547 | Some cst -> expand (cst :: acc) ctx rest)
548 | Ast.VariableAtom
549 ( s,
550 (( RemoveSmallestPrefixPattern cst
551 | RemoveLargestPrefixPattern cst ) as v) ) -> (
552 let ctx, spp = expand_cst ctx cst in
553 let pattern = Ast.word_components_to_string spp in
554 match S.lookup ctx.state ~param:s with
555 | None -> expand (cst :: acc) ctx rest
556 | Some cst -> (
557 let kind =
558 match v with
559 | RemoveSmallestPrefixPattern _ -> `Smallest
560 | RemoveLargestPrefixPattern _ -> `Largest
561 | _ -> assert false
562 in
563 let param = Ast.word_components_to_string cst in
564 let prefix = get_prefix ~pattern ~kind param in
565 match prefix with
566 | None -> expand ([ Ast.WordName param ] :: acc) ctx rest
567 | Some s -> (
568 match String.cut_prefix ~prefix:s param with
569 | Some s -> expand ([ Ast.WordName s ] :: acc) ctx rest
570 | None -> expand ([ Ast.WordName param ] :: acc) ctx rest)
571 ))
572 | Ast.VariableAtom
573 ( s,
574 (( RemoveSmallestSuffixPattern cst
575 | RemoveLargestSuffixPattern cst ) as v) ) -> (
576 let ctx, spp = expand_cst ctx cst in
577 let pattern = Ast.word_components_to_string spp in
578 match S.lookup ctx.state ~param:s with
579 | None -> expand (cst :: acc) ctx rest
580 | Some cst -> (
581 let kind =
582 match v with
583 | RemoveSmallestSuffixPattern _ -> `Smallest
584 | RemoveLargestSuffixPattern _ -> `Largest
585 | _ -> assert false
586 in
587 let param = Ast.word_components_to_string cst in
588 let suffix = get_suffix ~pattern ~kind param in
589 match suffix with
590 | None -> expand ([ Ast.WordName param ] :: acc) ctx rest
591 | Some s -> (
592 match String.cut_suffix ~suffix:s param with
593 | Some s -> expand ([ Ast.WordName s ] :: acc) ctx rest
594 | None -> expand ([ Ast.WordName param ] :: acc) ctx rest)
595 ))
596 | Ast.VariableAtom (s, UseAlternativeValue (_, alt)) -> (
597 match S.lookup ctx.state ~param:s with
598 | Some _ -> expand (alt :: acc) ctx rest
599 | None -> expand ([ Ast.WordEmpty ] :: acc) ctx rest)
600 | Ast.VariableAtom (s, AssignDefaultValues (_, value)) -> (
601 match S.lookup ctx.state ~param:s with
602 | Some cst -> expand (cst :: acc) ctx rest
603 | None ->
604 let state = S.update ctx.state ~param:s value in
605 let new_ctx = { ctx with state } in
606 expand (value :: acc) new_ctx rest)
607 | Ast.VariableAtom (_, IndicateErrorifNullorUnset (_, _)) ->
608 Fmt.failwith "TODO: Indicate Error")
609 | Ast.WordDoubleQuoted cst :: rest ->
610 let new_ctx, cst_acc = expand [] ctx cst in
611 expand ([ Ast.WordDoubleQuoted cst_acc ] :: acc) new_ctx rest
612 | Ast.WordSingleQuoted cst :: rest ->
613 let new_ctx, cst_acc = expand [] ctx cst in
614 expand ([ Ast.WordSingleQuoted cst_acc ] :: acc) new_ctx rest
615 | Ast.WordAssignmentWord (n, w) :: rest ->
616 let new_ctx, cst_acc = expand [] ctx w in
617 expand ([ Ast.WordAssignmentWord (n, cst_acc) ] :: acc) new_ctx rest
618 | v :: rest -> expand ([ v ] :: acc) ctx rest
619 in
620 expand [] ctx ast
621
622 and handle_export ctx (assignments : Ast.word_cst list) =
623 let rec loop acc_ctx = function
624 | [] -> Exit.zero acc_ctx
625 | Ast.WordAssignmentWord (Name param, v) :: rest ->
626 loop
627 {
628 acc_ctx with
629 state = S.update ~export:true acc_ctx.state ~param v;
630 }
631 rest
632 | Ast.WordName param :: rest -> (
633 match S.lookup acc_ctx.state ~param with
634 | Some v ->
635 loop
636 {
637 acc_ctx with
638 state = S.update ~export:true acc_ctx.state ~param v;
639 }
640 rest
641 | None -> loop acc_ctx rest)
642 | c :: _ ->
643 Exit.nonzero_msg acc_ctx "export weird arguments: %s\n"
644 (Ast.word_component_to_string c)
645 in
646 List.fold_left
647 (fun ctx w -> match ctx with Exit.Zero ctx -> loop ctx w | _ -> ctx)
648 (Exit.zero ctx) assignments
649
650 and expand_cst (ctx : ctx) cst : ctx * Ast.word_cst =
651 let cst = tilde_expansion ctx cst in
652 let ctx, cst = parameter_expansion' ctx cst in
653 arithmetic_expansion ctx cst
654
655 and expand_redirects ((ctx, acc) : ctx * Ast.cmd_suffix_item list)
656 (c : Ast.cmd_suffix_item list) =
657 match c with
658 | [] -> (ctx, List.rev acc)
659 | Ast.Suffix_redirect (IoRedirect_IoFile (num, (op, file))) :: rest ->
660 let ctx, cst = expand_cst ctx file in
661 let cst = handle_subshell ctx cst in
662 let v = Ast.Suffix_redirect (IoRedirect_IoFile (num, (op, cst))) in
663 expand_redirects (ctx, v :: acc) rest
664 | (Ast.Suffix_redirect _ as v) :: rest ->
665 expand_redirects (ctx, v :: acc) rest
666 | s :: rest -> expand_redirects (ctx, s :: acc) rest
667
668 and handle_and_or ~sw:_ ~async ctx c =
669 let pipeline = function
670 | Ast.Pipeline p -> (Fun.id, p)
671 | Ast.Pipeline_Bang p -> (Exit.not, p)
672 in
673
674 let rec fold :
675 Ast.and_or * ctx Exit.t -> Ast.pipeline Ast.and_or_list -> ctx Exit.t =
676 fun (sep, exit_so_far) pipe ->
677 match (sep, pipe) with
678 | And, Nlist.Singleton (p, _) -> (
679 match exit_so_far with
680 | Exit.Zero ctx ->
681 let f, p = pipeline p in
682 f @@ handle_pipeline ~async ctx p
683 | v -> v)
684 | Or, Nlist.Singleton (p, _) -> (
685 match exit_so_far with
686 | Exit.Zero _ as ctx -> ctx
687 | _ ->
688 let f, p = pipeline p in
689 f @@ handle_pipeline ~async ctx p)
690 | Noand_or, Nlist.Singleton (p, _) ->
691 let f, p = pipeline p in
692 f @@ handle_pipeline ~async ctx p
693 | Noand_or, Nlist.Cons ((p, next_sep), rest) ->
694 let f, p = pipeline p in
695 let exit_status = f (handle_pipeline ~async ctx p) in
696 fold (next_sep, exit_status) rest
697 | And, Nlist.Cons ((p, next_sep), rest) -> (
698 match exit_so_far with
699 | Exit.Zero ctx ->
700 let f, p = pipeline p in
701 fold (next_sep, f (handle_pipeline ~async ctx p)) rest
702 | Exit.Nonzero _ as v -> v)
703 | Or, Nlist.Cons ((p, next_sep), rest) -> (
704 match exit_so_far with
705 | Exit.Zero _ as exit_so_far -> fold (next_sep, exit_so_far) rest
706 | Exit.Nonzero _ ->
707 let f, p = pipeline p in
708 fold (next_sep, f (handle_pipeline ~async ctx p)) rest)
709 in
710 fold (Noand_or, Exit.zero ctx) c
711
712 and handle_for_clause ctx v : ctx Exit.t =
713 match v with
714 | Ast.For_Name_DoGroup (_, (term, sep)) -> exec ctx (term, Some sep)
715 | Ast.For_Name_In_WordList_DoGroup (Name name, wdlist, (term, sep)) ->
716 let wdlist = Nlist.flatten @@ Nlist.map (word_glob_expand ctx) wdlist in
717 Nlist.fold_left
718 (fun _ word ->
719 let s = S.update ctx.state ~param:name word in
720 let ctx = { ctx with state = s } in
721 exec ctx (term, Some sep))
722 (Exit.zero ctx) wdlist
723
724 and handle_if_clause ctx = function
725 | Ast.If_then ((e1, sep1), (e2, sep2)) -> (
726 let ctx = exec ctx (e1, Some sep1) in
727 match ctx with
728 | Exit.Zero ctx -> exec ctx (e2, Some sep2)
729 | Exit.Nonzero { value = ctx; _ } -> Exit.zero ctx)
730 | Ast.If_then_else ((e1, sep1), (e2, sep2), else_part) -> (
731 let ctx = exec ctx (e1, Some sep1) in
732 match ctx with
733 | Exit.Zero ctx -> exec ctx (e2, Some sep2)
734 | Exit.Nonzero { value = ctx; _ } -> handle_else_part ctx else_part)
735
736 and handle_else_part ctx = function
737 | Ast.Else (c, sep) -> exec ctx (c, Some sep)
738 | Ast.Elif_then ((e1, sep1), (e2, sep2)) -> (
739 let ctx = exec ctx (e1, Some sep1) in
740 match ctx with
741 | Exit.Zero ctx -> exec ctx (e2, Some sep2)
742 | Exit.Nonzero { value = ctx; _ } -> Exit.zero ctx)
743 | Ast.Elif_then_else ((e1, sep1), (e2, sep2), else_part) -> (
744 let ctx = exec ctx (e1, Some sep1) in
745 match ctx with
746 | Exit.Zero ctx -> exec ctx (e2, Some sep2)
747 | Exit.Nonzero { value = ctx; _ } -> handle_else_part ctx else_part)
748
749 and handle_case_clause ctx = function
750 | Ast.Case _ -> Exit.zero ctx
751 | Cases (word, case_list) -> (
752 let ctx, word = expand_cst ctx word in
753 let scrutinee = Ast.word_components_to_string word in
754 let res =
755 Nlist.fold_left
756 (fun acc pat ->
757 match acc with
758 | Some _ as ctx -> ctx
759 | None -> (
760 match pat with
761 | Ast.Case_pattern (p, sub) ->
762 Nlist.fold_left
763 (fun inner_acc pattern ->
764 match inner_acc with
765 | Some _ as v -> v
766 | None ->
767 let ctx, pattern = expand_cst ctx pattern in
768 let pattern =
769 Ast.word_components_to_string pattern
770 in
771 if Glob.test ~pattern scrutinee then begin
772 match sub with
773 | Some sub -> Some (exec_subshell ctx sub)
774 | None -> Some (Exit.zero ctx)
775 end
776 else inner_acc)
777 None p))
778 None case_list
779 in
780 match res with Some ctx -> ctx | None -> Exit.zero ctx)
781
782 and exec_subshell ctx (term, sep) =
783 let saved_ctx = ctx in
784 let e = exec ctx (term, Some sep) in
785 let v = e >|= fun _ -> saved_ctx in
786 v
787
788 and handle_while_clause ctx
789 (While ((term, sep), (term', sep')) : Ast.while_clause) =
790 let rec loop exit_so_far =
791 let running_ctx = Exit.value exit_so_far in
792 match exec running_ctx (term, Some sep) with
793 | Exit.Nonzero _ -> exit_so_far (* TODO: Context? *)
794 | Exit.Zero ctx -> loop (exec ctx (term', Some sep'))
795 in
796 loop (Exit.zero ctx)
797
798 and handle_until_clause ctx
799 (Until ((term, sep), (term', sep')) : Ast.until_clause) =
800 let rec loop exit_so_far =
801 let running_ctx = Exit.value exit_so_far in
802 match exec running_ctx (term, Some sep) with
803 | Exit.Zero _ -> exit_so_far (* TODO: Context? *)
804 | Exit.Nonzero { value = ctx; _ } -> loop (exec ctx (term', Some sep'))
805 in
806 loop (Exit.zero ctx)
807
808 and handle_compound_command ctx v : ctx Exit.t =
809 match v with
810 | Ast.ForClause fc -> handle_for_clause ctx fc
811 | Ast.IfClause if_ -> handle_if_clause ctx if_
812 | Ast.BraceGroup (term, sep) -> exec ctx (term, Some sep)
813 | Ast.Subshell s -> exec_subshell ctx s
814 | Ast.CaseClause cases -> handle_case_clause ctx cases
815 | Ast.WhileClause while_ -> handle_while_clause ctx while_
816 | Ast.UntilClause until -> handle_until_clause ctx until
817
818 and handle_function_application (ctx : ctx) ~name argv : ctx Exit.t option =
819 match List.assoc_opt name ctx.functions with
820 | None -> None
821 | Some commands ->
822 let ctx = { ctx with argv = Array.of_list argv } in
823 Option.some @@ (handle_compound_command ctx commands >|= fun _ -> ctx)
824
825 and needs_subshelling = function
826 | [] -> false
827 | Ast.WordSubshell _ :: _ -> true
828 | Ast.WordDoubleQuoted word :: rest ->
829 needs_subshelling word || needs_subshelling rest
830 | Ast.WordSingleQuoted word :: rest ->
831 needs_subshelling word || needs_subshelling rest
832 | _ -> false
833
834 and handle_subshell (ctx : ctx) wcs =
835 let exec_subshell ~sw ctx s =
836 let buf = Buffer.create 16 in
837 let stdout = Eio.Flow.buffer_sink buf in
838 let r, w = Eio_unix.pipe sw in
839 Eio.Fiber.fork ~sw (fun () -> Eio.Flow.copy r stdout);
840 let subshell_ctx = { ctx with stdout = w; subshell = true } in
841 let sub_ctx, _ = run (Exit.zero subshell_ctx) s in
842 Eio.Flow.close w;
843 ((sub_ctx >|= fun _ -> ctx), Buffer.contents buf)
844 in
845 let rec run_subshells ~sw ran_subshell = function
846 | [] -> []
847 | Ast.WordSubshell s :: rest ->
848 let _ctx, std = exec_subshell ~sw ctx s in
849 ran_subshell := true;
850 Ast.WordName (String.trim std) :: run_subshells ~sw ran_subshell rest
851 | Ast.WordDoubleQuoted word :: rest ->
852 let subshell_q = ref false in
853 let res = run_subshells ~sw subshell_q word in
854 if !subshell_q then res @ run_subshells ~sw subshell_q rest
855 else Ast.WordDoubleQuoted res :: run_subshells ~sw subshell_q rest
856 | Ast.WordSingleQuoted word :: rest ->
857 let subshell_q = ref false in
858 let res = run_subshells ~sw subshell_q word in
859 if !subshell_q then res @ run_subshells ~sw subshell_q rest
860 else Ast.WordSingleQuoted res :: run_subshells ~sw subshell_q rest
861 | v :: rest -> v :: run_subshells ~sw ran_subshell rest
862 in
863 Eio.Switch.run @@ fun sw -> run_subshells ~sw (ref false) wcs
864
865 and handle_word_cst_subshell (ctx : ctx) wcs : Ast.word_cst =
866 if needs_subshelling wcs then begin
867 let wcs = handle_subshell ctx wcs in
868 wcs
869 end
870 else wcs
871
872 and glob_expand ctx wc =
873 let wc = handle_word_cst_subshell ctx wc in
874 if Ast.has_glob wc then
875 Ast.word_components_to_string wc |> fun pattern ->
876 Glob.glob_dir ~pattern (cwd_of_ctx ctx)
877 |> List.map (fun w -> [ Ast.WordName w ])
878 else [ wc ]
879
880 and word_glob_expand (ctx : ctx) wc : Ast.word_cst list =
881 if List.exists needs_glob_expansion wc then glob_expand ctx wc
882 else [ handle_word_cst_subshell ctx wc ]
883
884 and collect_assignments ?(update = true) ctx =
885 List.fold_left
886 (fun ctx -> function
887 | Ast.Prefix_assignment (Name param, v) ->
888 (* Expand the values *)
889 let ctx, v = expand_cst ctx v in
890 let v = handle_subshell ctx v in
891 let state =
892 if update then S.update ctx.state ~param v else ctx.state
893 in
894 {
895 ctx with
896 state;
897 local_state =
898 (param, Ast.word_components_to_string v) :: ctx.local_state;
899 }
900 | _ -> ctx)
901 ctx
902
903 and args ctx swc : ctx * Ast.word_cst list =
904 List.fold_left
905 (fun (ctx, acc) -> function
906 | Ast.Suffix_redirect _ -> (ctx, acc)
907 | Suffix_word wc ->
908 let ctx, cst = expand_cst ctx wc in
909 (ctx, acc @ word_glob_expand ctx cst))
910 (ctx, []) swc
911
912 and handle_built_in ~rdrs ~(stdout : Eio_unix.sink_ty Eio.Flow.sink)
913 (ctx : ctx) = function
914 | Built_ins.Cd { path } ->
915 let cwd = S.cwd ctx.state in
916 let+ state =
917 match path with
918 | Some p ->
919 let fp = Fpath.append cwd (Fpath.v p) in
920 if Eio.Path.is_directory (ctx.fs / Fpath.to_string fp) then
921 Exit.zero @@ S.set_cwd ctx.state fp
922 else
923 Exit.nonzero_msg ~exit_code:1 ctx.state
924 "cd: not a directory: %a" Fpath.pp fp
925 | None -> (
926 match Eunix.find_env "HOME" with
927 | None -> Exit.nonzero_msg ctx.state "HOME not set"
928 | Some p -> Exit.zero (S.set_cwd ctx.state @@ Fpath.v p))
929 in
930 { ctx with state }
931 | Pwd ->
932 let () =
933 Eunix.with_redirections rdrs @@ fun () ->
934 Eio.Flow.copy_string
935 (Fmt.str "%a\n%!" Fpath.pp (S.cwd ctx.state))
936 stdout
937 in
938 Exit.zero ctx
939 | Exit n ->
940 let should_exit =
941 { Exit.default_should_exit with interactive = `Yes }
942 in
943 Exit.nonzero ~should_exit ctx n
944 | Set { update; print_options } ->
945 let v =
946 Exit.zero
947 { ctx with options = Built_ins.Options.update ctx.options update }
948 in
949 if print_options then
950 Eio.Flow.copy_string
951 (Fmt.str "%a" Built_ins.Options.pp ctx.options)
952 stdout;
953 v
954 | Wait i -> (
955 match Unix.waitpid [] i with
956 | _, WEXITED 0 -> Exit.zero ctx
957 | _, (WEXITED n | WSIGNALED n | WSTOPPED n) -> Exit.nonzero ctx n)
958 | Dot file -> (
959 match resolve_program ctx file with
960 | ctx, None -> Exit.nonzero ctx 127
961 | ctx, Some f ->
962 let program = Ast.of_file (ctx.fs / f) in
963 let ctx, _ = run (Exit.zero ctx) program in
964 ctx)
965 | Unset names -> (
966 match names with
967 | `Variables names ->
968 let state =
969 List.fold_left
970 (fun t param -> S.remove ~param t |> snd)
971 ctx.state names
972 in
973 Exit.zero { ctx with state }
974 | `Functions names ->
975 let functions =
976 List.fold_left
977 (fun t param -> List.remove_assoc param t)
978 ctx.functions names
979 in
980 Exit.zero { ctx with functions })
981 | Hash v -> (
982 match v with
983 | Built_ins.Hash_remove -> Exit.zero { ctx with hash = Hash.empty }
984 | Built_ins.Hash_stats ->
985 Eio.Flow.copy_string (Fmt.str "%a" Hash.pp ctx.hash) stdout;
986 Exit.zero ctx
987 | _ -> assert false)
988 | Alias | Unalias -> Exit.zero ctx (* Morbig handles this for us *)
989 | Eval args ->
990 let script = String.concat " " args in
991 let ast = Ast.of_string script in
992 let ctx, _ = run (Exit.zero ctx) ast in
993 ctx
994 | Command _ ->
995 (* Handled separately *)
996 assert false
997
998 and exec initial_ctx ((command, sep) : Ast.complete_command) =
999 let rec loop : Eio.Switch.t -> ctx -> Ast.clist -> ctx Exit.t =
1000 fun sw ctx -> function
1001 | Nlist.Singleton (c, sep) ->
1002 let async =
1003 match sep with Semicolon -> false | Ampersand -> true
1004 in
1005 handle_and_or ~sw ~async ctx c
1006 | Nlist.Cons ((c, sep), cs) -> (
1007 let async =
1008 match sep with Semicolon -> false | Ampersand -> true
1009 in
1010 match handle_and_or ~sw ~async ctx c with
1011 | Exit.Zero ctx -> loop sw ctx cs
1012 | v -> v)
1013 in
1014 match sep with
1015 | Some Semicolon | None ->
1016 Eio.Switch.run @@ fun sw -> loop sw initial_ctx command
1017 | Some Ampersand ->
1018 Fiber.fork ~sw:initial_ctx.async_switch (fun () ->
1019 Fiber.yield ();
1020 let _ : ctx Exit.t =
1021 loop initial_ctx.async_switch initial_ctx command
1022 in
1023 ());
1024 Exit.zero initial_ctx
1025
1026 and execute ctx ast = exec ctx ast
1027
1028 and run ctx ast =
1029 (* Make the shell its own process group *)
1030 Eunix.make_process_group ();
1031 let ctx, cs =
1032 let rec loop_commands (ctx, cs) (c : Ast.complete_commands) =
1033 match c with
1034 | [] -> (ctx, cs)
1035 | command :: commands -> (
1036 let ctx = Exit.value ctx in
1037 (* For our sanity *)
1038 let has_async = Ast.has_async command in
1039 if has_async && not ctx.options.async then begin
1040 Fmt.epr
1041 "You are using asynchronous operators and [set -o async] has \
1042 not been called.\n\
1043 %!";
1044 exit 1
1045 end;
1046 let exit =
1047 try execute ctx command
1048 with
1049 | Eio.Io (Eio.Process.E (Eio.Process.Executable_not_found m), _ctx)
1050 ->
1051 Exit.nonzero_msg ctx ~exit_code:127 "command not found: %s" m
1052 in
1053 match exit with
1054 | Exit.Nonzero { exit_code; message; should_exit; _ } -> (
1055 Option.iter (Fmt.epr "%s\n%!") message;
1056 match
1057 ( should_exit.interactive,
1058 should_exit.non_interactive,
1059 ctx.subshell,
1060 ctx.interactive,
1061 commands )
1062 with
1063 | `Yes, _, false, true, [] | _, `Yes, false, false, [] ->
1064 if should_exit.interactive = `Yes then Fmt.epr "exit\n%!";
1065 Stdlib.exit exit_code
1066 | _ -> loop_commands (exit, c :: cs) commands)
1067 | Exit.Zero _ as ctx -> loop_commands (ctx, c :: cs) commands)
1068 in
1069 loop_commands (ctx, []) ast
1070 in
1071 (ctx, List.rev cs)
1072end