Shells in OCaml
patrick.sirref.org
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 type signal_handler = { run : (unit -> unit) -> unit; sigint_set : bool }
21
22 type ctx = {
23 interactive : bool;
24 subshell : bool;
25 state : S.t;
26 local_state : (string * string) list;
27 executor : E.t;
28 fs : Eio.Fs.dir_ty Eio.Path.t;
29 options : Built_ins.Options.t;
30 stdin : Eio_unix.source_ty Eio.Flow.source;
31 stdout : Eio_unix.sink_ty Eio.Flow.sink;
32 background_jobs : J.t list;
33 last_background_process : string;
34 async_switch : Eio.Switch.t;
35 program : string;
36 argv : string array;
37 functions : (string * Ast.compound_command) list;
38 hash : Hash.t;
39 rdrs : Types.redirect list;
40 signal_handler : signal_handler;
41 exit_handler : (unit -> unit) option;
42 }
43
44 let _stdin ctx = ctx.stdin
45
46 let make_ctx ?(interactive = false) ?(subshell = false) ?(local_state = [])
47 ?(background_jobs = []) ?(last_background_process = "") ?(functions = [])
48 ?(rdrs = []) ?exit_handler ?(options = Built_ins.Options.default)
49 ?(hash = Hash.empty) ~fs ~stdin ~stdout ~async_switch ~program ~argv
50 ~signal_handler state executor =
51 let signal_handler = { run = signal_handler; sigint_set = false } in
52 {
53 interactive;
54 subshell;
55 state;
56 local_state;
57 executor;
58 fs;
59 options;
60 stdin;
61 stdout;
62 background_jobs;
63 last_background_process;
64 async_switch;
65 program;
66 argv;
67 functions;
68 hash;
69 rdrs;
70 signal_handler;
71 exit_handler;
72 }
73
74 let state ctx = ctx.state
75 let sigint_set ctx = ctx.signal_handler.sigint_set
76 let clear_local_state ctx = { ctx with local_state = [] }
77
78 let rec tilde_expansion ctx = function
79 | [] -> []
80 | Ast.WordTildePrefix _ :: rest ->
81 Ast.WordName (S.expand ctx.state `Tilde) :: tilde_expansion ctx rest
82 | v :: rest -> v :: tilde_expansion ctx rest
83
84 let arithmetic_expansion ctx expr =
85 let rec fold (ctx, cst) = function
86 | [] -> (ctx, cst)
87 | Ast.WordArithmeticExpression word :: rest ->
88 let expr = Ast.word_components_to_string word in
89 let aexpr =
90 Arith_parser.main Arith_lexer.read (Lexing.from_string expr)
91 in
92 let state, i = A.eval ctx.state aexpr in
93 fold
94 ({ ctx with state }, Ast.WordLiteral (string_of_int i) :: cst)
95 rest
96 | Ast.WordDoubleQuoted dq :: rest ->
97 let ctx, v = fold (ctx, []) dq in
98 fold (ctx, Ast.WordDoubleQuoted (List.rev v) :: cst) rest
99 | Ast.WordSingleQuoted dq :: rest ->
100 let ctx, v = fold (ctx, []) dq in
101 fold (ctx, Ast.WordSingleQuoted (List.rev v) :: cst) rest
102 | v :: rest -> fold (ctx, v :: cst) rest
103 in
104 let state, cst = fold (ctx, []) expr in
105 (state, List.rev cst)
106
107 let stdout_for_pipeline ~sw ctx = function
108 | [] -> (None, `Global ctx.stdout)
109 | _ ->
110 let r, w = Eio_unix.pipe sw in
111 (Some r, `Local (w :> Eio_unix.sink_ty Eio.Flow.sink))
112
113 let fd_of_int ?(close_unix = true) ~sw n =
114 Eio_unix.Fd.of_unix ~close_unix ~sw (Obj.magic n : Unix.file_descr)
115
116 let handle_one_redirection ~sw ctx = function
117 | Ast.IoRedirect_IoFile (n, (op, file)) -> (
118 match op with
119 | Io_op_less ->
120 (* Simple redirection for input *)
121 let r =
122 Eio.Path.open_in ~sw (ctx.fs / Ast.word_components_to_string file)
123 in
124 let fd = Eio_unix.Resource.fd_opt r |> Option.get in
125 [ Types.Redirect (n, fd, `Blocking) ]
126 | Io_op_lessand -> (
127 match file with
128 | [ WordLiteral "-" ] ->
129 if n = 0 then [ Types.Close Eio_unix.Fd.stdin ]
130 else
131 let fd = fd_of_int ~sw n in
132 [ Types.Close fd ]
133 | [ WordLiteral m ] when Option.is_some (int_of_string_opt m) ->
134 let m = int_of_string m in
135 [
136 Types.Redirect
137 (n, fd_of_int ~close_unix:false ~sw m, `Blocking);
138 ]
139 | _ -> [])
140 | (Io_op_great | Io_op_dgreat) as v ->
141 (* Simple file creation *)
142 let append = v = Io_op_dgreat in
143 let create =
144 if append then `Never
145 else if ctx.options.noclobber then `Exclusive 0o644
146 else `Or_truncate 0o644
147 in
148 let w =
149 Eio.Path.open_out ~sw ~append ~create
150 (ctx.fs / Ast.word_components_to_string file)
151 in
152 let fd = Eio_unix.Resource.fd_opt w |> Option.get in
153 [ Types.Redirect (n, fd, `Blocking) ]
154 | Io_op_greatand -> (
155 match file with
156 | [ WordLiteral "-" ] ->
157 if n = 0 then [ Types.Close Eio_unix.Fd.stdout ]
158 else
159 let fd = fd_of_int ~sw n in
160 [ Types.Close fd ]
161 | [ WordLiteral m ] when Option.is_some (int_of_string_opt m) ->
162 let m = int_of_string m in
163 [
164 Types.Redirect
165 (n, fd_of_int ~close_unix:false ~sw m, `Blocking);
166 ]
167 | _ -> [])
168 | Io_op_andgreat ->
169 (* Yesh, not very POSIX *)
170 (* Simple file creation *)
171 let w =
172 Eio.Path.open_out ~sw ~create:(`If_missing 0o644)
173 (ctx.fs / Ast.word_components_to_string file)
174 in
175 let fd = Eio_unix.Resource.fd_opt w |> Option.get in
176 [
177 Types.Redirect (1, fd, `Blocking);
178 Types.Redirect (2, fd, `Blocking);
179 ]
180 | Io_op_clobber ->
181 let w =
182 Eio.Path.open_out ~sw ~create:(`Or_truncate 0o644)
183 (ctx.fs / Ast.word_components_to_string file)
184 in
185 let fd = Eio_unix.Resource.fd_opt w |> Option.get in
186 [ Types.Redirect (n, fd, `Blocking) ]
187 | Io_op_lessgreat -> Fmt.failwith "<> not support yet.")
188 | Ast.IoRedirect_IoHere _ ->
189 Fmt.failwith "HERE documents not yet implemented!"
190
191 let handle_redirections ~sw ctx rdrs =
192 try Ok (List.concat_map (handle_one_redirection ~sw ctx) rdrs)
193 with Eio.Io (Eio.Fs.E (Already_exists _), _) ->
194 Fmt.epr "msh: cannot overwrite existing file\n%!";
195 Error ctx
196
197 let cwd_of_ctx ctx = S.cwd ctx.state |> Fpath.to_string |> ( / ) ctx.fs
198
199 let needs_glob_expansion : Ast.word_component -> bool = function
200 | WordGlobAll | WordGlobAny -> true
201 | _ -> false
202
203 let resolve_program ?(update = true) ctx name =
204 let v =
205 if not (String.contains name '/') then begin
206 S.lookup ctx.state ~param:"PATH"
207 |> Option.map Ast.word_components_to_string
208 |> Option.value ~default:"/bin:/usr/bin"
209 |> String.split_on_char ':'
210 |> List.find_map (fun dir ->
211 let p = Filename.concat dir name in
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 update ?export ?readonly ctx ~param v =
235 match S.update ?export ?readonly ctx.state ~param v with
236 | Ok state -> Exit.zero { ctx with state }
237 | Error msg ->
238 Fmt.epr "%s\n%!" msg;
239 Exit.nonzero ctx 1
240
241 let remove_quotes s =
242 let s_len = String.length s in
243 if s.[0] = '"' && s.[s_len - 1] = '"' then String.sub s 1 (s_len - 2) else s
244
245 let exit ctx code =
246 Option.iter (fun f -> f ()) ctx.exit_handler;
247 exit code
248
249 let rec handle_pipeline ~async initial_ctx p : ctx Exit.t =
250 let set_last_background ~async process ctx =
251 if async then
252 { ctx with last_background_process = string_of_int (E.pid process) }
253 else ctx
254 in
255 let on_process ?process ~async ctx =
256 let ctx = clear_local_state ctx in
257 match process with
258 | None -> ctx
259 | Some process -> set_last_background ~async process ctx
260 in
261 let handle_job j = function
262 | `Process p -> J.add_process p j
263 | `Rdr p -> J.add_rdr p j
264 | `Built_in p -> J.add_built_in p j
265 | `Error p -> J.add_error p j
266 | `Exit p -> J.add_exit p j
267 in
268 let close_stdout ~is_global some_write =
269 if not is_global then begin
270 Eio.Flow.close some_write
271 end
272 in
273 let exec_process ~sw ctx job ?fds ?stdin ~stdout ?pgid executable args =
274 let pgid = match pgid with None -> 0 | Some p -> p in
275 let reap = J.get_reaper job in
276 let mode = if async then Types.Async else Types.Switched sw in
277 let fds = ctx.rdrs @ Option.value ~default:[] fds in
278 let ctx, process =
279 match (executable, resolve_program ctx executable) with
280 | _, (ctx, None) | "", (ctx, _) ->
281 Eunix.with_redirections fds (fun () ->
282 Eio.Flow.copy_string
283 (Fmt.str "msh: command not found: %s\n" executable)
284 stdout);
285 (ctx, Error (127, `Not_found))
286 | _, (ctx, Some full_path) ->
287 ( ctx,
288 E.exec ctx.executor ~delay_reap:(fst reap) ~fds ?stdin ~stdout
289 ~pgid ~mode ~cwd:(cwd_of_ctx ctx)
290 ~env:(get_env ~extra:ctx.local_state ctx)
291 ~executable:full_path (executable :: args) )
292 in
293 match process with
294 | Error (n, _) ->
295 let job = handle_job job (`Error n) in
296 (on_process ~async ctx, job)
297 | Ok process ->
298 let pgid = if Int.equal pgid 0 then E.pid process else pgid in
299 let job = handle_job job (`Process process) |> J.set_id pgid in
300 (on_process ~async ~process ctx, job)
301 in
302 let job_pgid (t : J.t) = J.get_id t in
303 let rec loop pipeline_switch (ctx : ctx) (job : J.t)
304 (stdout_of_previous : Eio_unix.source_ty Eio_unix.source option) :
305 Ast.command list -> ctx * J.t =
306 fun c ->
307 let loop = loop pipeline_switch in
308 match c with
309 | Ast.SimpleCommand (Prefixed (prefix, None, _suffix)) :: rest ->
310 let ctx = collect_assignments ctx prefix in
311 let job = handle_job job (`Built_in (Exit.ignore ctx)) in
312 loop (Exit.value ctx) job stdout_of_previous rest
313 | Ast.SimpleCommand (Prefixed (prefix, Some executable, suffix)) :: rest
314 ->
315 let ctx = collect_assignments ~update:false ctx prefix in
316 let job = handle_job job (`Built_in (Exit.ignore ctx)) in
317 loop (Exit.value ctx) job stdout_of_previous
318 (Ast.SimpleCommand (Named (executable, suffix)) :: rest)
319 | Ast.SimpleCommand (Named (executable, suffix)) :: rest -> (
320 let ctx, executable = expand_cst ctx executable in
321 match ctx with
322 | Exit.Nonzero _ as ctx ->
323 let job = handle_job job (`Built_in (Exit.ignore ctx)) in
324 loop (Exit.value ctx) job stdout_of_previous rest
325 | Exit.Zero ctx -> (
326 let executable = handle_word_cst_subshell ctx executable in
327 let executable, extra_args =
328 (* This is a side-effect of the alias command with something like
329 alias ls="ls -la" *)
330 match executable with
331 | [ Ast.WordLiteral s ] as v -> (
332 match String.split_on_char ' ' (remove_quotes s) with
333 | exec :: args ->
334 ( [ Ast.WordName exec ],
335 List.map
336 (fun w -> Ast.Suffix_word [ Ast.WordName w ])
337 args )
338 | _ -> (v, []))
339 | v -> (v, [])
340 in
341 let executable = Ast.word_components_to_string executable in
342 let ctx, suffix =
343 match suffix with
344 | None -> (ctx, [])
345 | Some suffix -> expand_redirects (ctx, []) suffix
346 in
347 let ctx, args = args ctx (extra_args @ suffix) in
348 match ctx with
349 | Exit.Nonzero _ as ctx ->
350 let job = handle_job job (`Built_in (Exit.ignore ctx)) in
351 loop (Exit.value ctx) job stdout_of_previous rest
352 | Exit.Zero ctx -> (
353 let args_as_strings =
354 List.map Ast.word_components_to_string args
355 in
356 let some_read, some_write =
357 stdout_for_pipeline ~sw:pipeline_switch ctx rest
358 in
359 let is_global, some_write =
360 match some_write with
361 | `Global p -> (true, p)
362 | `Local p -> (false, p)
363 in
364 let rdrs =
365 List.fold_left
366 (fun acc -> function
367 | Ast.Suffix_word _ -> acc
368 | Ast.Suffix_redirect rdr -> rdr :: acc)
369 [] suffix
370 |> List.rev
371 in
372 match handle_redirections ~sw:pipeline_switch ctx rdrs with
373 | Error ctx -> (ctx, handle_job job (`Rdr (Exit.nonzero () 1)))
374 | Ok rdrs -> (
375 match
376 Built_ins.of_args (executable :: args_as_strings)
377 with
378 | Some (Error _) ->
379 (ctx, handle_job job (`Built_in (Exit.nonzero () 1)))
380 | (None | Some (Ok (Command _))) as v -> (
381 let is_command, command_args, print_command =
382 match v with
383 | Some (Ok (Command { print_command; args })) ->
384 (true, args, print_command)
385 | _ -> (false, [], false)
386 in
387 (* We handle the [export] built_in explicitly as we need access to the
388 raw CST *)
389 match executable with
390 | "export" ->
391 let updated =
392 handle_export_or_readonly `Export ctx args
393 in
394 let job =
395 handle_job job
396 (`Built_in (updated >|= fun _ -> ()))
397 in
398 loop (Exit.value updated) job stdout_of_previous
399 rest
400 | "readonly" ->
401 let updated =
402 handle_export_or_readonly `Readonly ctx args
403 in
404 let job =
405 handle_job job
406 (`Built_in (updated >|= fun _ -> ()))
407 in
408 loop (Exit.value updated) job stdout_of_previous
409 rest
410 | _ -> (
411 let saved_ctx = ctx in
412 let func_app =
413 if is_command then None
414 else
415 let ctx = { ctx with stdout = some_write } in
416 handle_function_application ctx
417 ~name:executable
418 (ctx.program :: args_as_strings)
419 in
420 match func_app with
421 | Some ctx ->
422 close_stdout ~is_global some_write;
423 (* TODO: Proper job stuff and redirects etc. *)
424 let job =
425 handle_job job (`Built_in (Exit.ignore ctx))
426 in
427 loop saved_ctx job some_read rest
428 | None -> (
429 match Built_ins.of_args command_args with
430 | Some (Error _) ->
431 ( ctx,
432 handle_job job
433 (`Built_in (Exit.nonzero () 1)) )
434 | Some (Ok bi) ->
435 let ctx =
436 handle_built_in ~rdrs ~stdout:some_write
437 ctx bi
438 in
439 let ctx =
440 ctx >|= fun ctx -> clear_local_state ctx
441 in
442 close_stdout ~is_global some_write;
443 let job =
444 match bi with
445 | Built_ins.Exit _ ->
446 let v_ctx = Exit.value ctx in
447 if not v_ctx.subshell then
448 exit v_ctx (Exit.code ctx)
449 else
450 handle_job job
451 (`Exit (Exit.ignore ctx))
452 | _ ->
453 handle_job job
454 (`Built_in (Exit.ignore ctx))
455 in
456 loop (Exit.value ctx) job some_read rest
457 | _ -> (
458 let exec_and_args =
459 if is_command then begin
460 match command_args with
461 | [] -> assert false
462 | x :: xs -> (
463 Eunix.with_redirections rdrs
464 @@ fun () ->
465 match
466 resolve_program ~update:false
467 ctx x
468 with
469 | _, None ->
470 Exit.nonzero ("", []) 1
471 | _, Some prog ->
472 if print_command then
473 Exit.zero ("echo", [ prog ])
474 else Exit.zero (x, xs))
475 end
476 else
477 Exit.zero (executable, args_as_strings)
478 in
479 match exec_and_args with
480 | Exit.Nonzero _ as v ->
481 let job =
482 handle_job job
483 (`Built_in (Exit.ignore v))
484 in
485 loop ctx job some_read rest
486 | Exit.Zero (executable, args) -> (
487 match stdout_of_previous with
488 | None ->
489 let ctx, job =
490 exec_process ~sw:pipeline_switch
491 ctx job ~fds:rdrs
492 ~stdout:some_write
493 ~pgid:(job_pgid job)
494 executable args
495 in
496 close_stdout ~is_global some_write;
497 loop ctx job some_read rest
498 | Some stdout ->
499 let ctx, job =
500 exec_process ~sw:pipeline_switch
501 ctx job ~fds:rdrs
502 ~stdin:stdout
503 ~stdout:some_write
504 ~pgid:(job_pgid job)
505 executable args_as_strings
506 in
507 close_stdout ~is_global some_write;
508 loop ctx job some_read rest)))))
509 | Some (Ok bi) ->
510 let ctx =
511 handle_built_in ~rdrs ~stdout:some_write ctx bi
512 in
513 let ctx = ctx >|= fun ctx -> clear_local_state ctx in
514 close_stdout ~is_global some_write;
515 let job =
516 match bi with
517 | Built_ins.Exit _ ->
518 let v_ctx = Exit.value ctx in
519 if not v_ctx.subshell then begin
520 if (Exit.value ctx).interactive then
521 Fmt.pr "exit\n%!";
522 exit v_ctx (Exit.code ctx)
523 end
524 else handle_job job (`Exit (Exit.ignore ctx))
525 | _ -> handle_job job (`Built_in (Exit.ignore ctx))
526 in
527 loop (Exit.value ctx) job some_read rest))))
528 | CompoundCommand (c, rdrs) :: rest -> (
529 match handle_redirections ~sw:pipeline_switch ctx rdrs with
530 | Error ctx -> (ctx, handle_job job (`Rdr (Exit.nonzero () 1)))
531 | Ok rdrs ->
532 (* TODO: No way this is right *)
533 let ctx = { ctx with rdrs } in
534 let ctx = handle_compound_command ctx c in
535 let job = handle_job job (`Built_in (ctx >|= fun _ -> ())) in
536 let actual_ctx = Exit.value ctx in
537 loop { actual_ctx with rdrs = [] } job None rest)
538 | FunctionDefinition (name, (body, _rdrs)) :: rest ->
539 let ctx = { ctx with functions = (name, body) :: ctx.functions } in
540 loop ctx job None rest
541 | [] -> (clear_local_state ctx, job)
542 in
543 Eio.Switch.run @@ fun sw ->
544 let initial_job = J.make 0 [] in
545 let saved_ctx = initial_ctx in
546 let subshell = saved_ctx.subshell || List.length p > 1 in
547 let ctx = { initial_ctx with subshell } in
548 let ctx, job = loop sw ctx initial_job None p in
549 match J.size job with
550 | 0 -> Exit.zero ctx
551 | _ ->
552 if not async then begin
553 J.await_exit ~pipefail:ctx.options.pipefail
554 ~interactive:ctx.interactive job
555 >|= fun () -> { ctx with subshell = saved_ctx.subshell }
556 end
557 else begin
558 Exit.zero
559 {
560 ctx with
561 background_jobs = job :: ctx.background_jobs;
562 subshell = saved_ctx.subshell;
563 }
564 end
565
566 and parameter_expansion' ctx ast =
567 let get_prefix ~pattern ~kind param =
568 let _, prefix =
569 String.fold_left
570 (fun (so_far, acc) c ->
571 match acc with
572 | Some s when kind = `Smallest -> (so_far, Some s)
573 | _ -> (
574 let s = so_far ^ String.make 1 c in
575 match Glob.tests ~pattern [ s ] with
576 | [ s ] -> (s, Some s)
577 | _ -> (s, acc)))
578 ("", None) param
579 in
580 prefix
581 in
582 let get_suffix ~pattern ~kind param =
583 let _, prefix =
584 String.fold_left
585 (fun (so_far, acc) c ->
586 match acc with
587 | Some s when kind = `Smallest -> (so_far, Some s)
588 | _ -> (
589 let s = String.make 1 c ^ so_far in
590 match Glob.tests ~pattern [ s ] with
591 | [ s ] -> (s, Some s)
592 | _ -> (s, acc)))
593 ("", None)
594 (String.fold_left (fun acc c -> String.make 1 c ^ acc) "" param)
595 in
596 prefix
597 in
598 let rec expand acc ctx = function
599 | [] -> (Exit.zero ctx, List.rev acc |> List.concat)
600 | Ast.WordVariable v :: rest -> (
601 match v with
602 | Ast.VariableAtom ("!", NoAttribute) ->
603 expand
604 ([ Ast.WordName ctx.last_background_process ] :: acc)
605 ctx rest
606 | Ast.VariableAtom (n, NoAttribute)
607 when Option.is_some (int_of_string_opt n) -> (
608 let n = int_of_string n in
609 match Array.get ctx.argv n with
610 | v -> expand ([ Ast.WordName v ] :: acc) ctx rest
611 | exception Invalid_argument _ ->
612 expand ([ Ast.WordName "" ] :: acc) ctx rest)
613 | Ast.VariableAtom (s, NoAttribute) -> (
614 match S.lookup ctx.state ~param:s with
615 | None ->
616 if ctx.options.no_unset then begin
617 ( Exit.nonzero_msg ctx ~exit_code:1 "%s: unbound variable" s,
618 List.rev acc |> List.concat )
619 end
620 else expand ([ Ast.WordName "" ] :: acc) ctx rest
621 | Some cst -> expand (cst :: acc) ctx rest)
622 | Ast.VariableAtom (s, ParameterLength) -> (
623 match S.lookup ctx.state ~param:s with
624 | None -> expand ([ Ast.WordLiteral "0" ] :: acc) ctx rest
625 | Some cst ->
626 expand
627 ([
628 Ast.WordLiteral
629 (string_of_int
630 (String.length (Ast.word_components_to_string cst)));
631 ]
632 :: acc)
633 ctx rest)
634 | Ast.VariableAtom (s, UseDefaultValues (_, cst)) -> (
635 match S.lookup ctx.state ~param:s with
636 | None -> expand (cst :: acc) ctx rest
637 | Some cst -> expand (cst :: acc) ctx rest)
638 | Ast.VariableAtom
639 ( s,
640 (( RemoveSmallestPrefixPattern cst
641 | RemoveLargestPrefixPattern cst ) as v) ) -> (
642 let ctx, spp = expand_cst ctx cst in
643 match ctx with
644 | Exit.Nonzero _ as ctx -> (ctx, List.rev acc |> List.concat)
645 | Exit.Zero ctx -> (
646 let pattern = Ast.word_components_to_string spp in
647 match S.lookup ctx.state ~param:s with
648 | None -> expand (cst :: acc) ctx rest
649 | Some cst -> (
650 let kind =
651 match v with
652 | RemoveSmallestPrefixPattern _ -> `Smallest
653 | RemoveLargestPrefixPattern _ -> `Largest
654 | _ -> assert false
655 in
656 let param = Ast.word_components_to_string cst in
657 let prefix = get_prefix ~pattern ~kind param in
658 match prefix with
659 | None -> expand ([ Ast.WordName param ] :: acc) ctx rest
660 | Some s -> (
661 match String.cut_prefix ~prefix:s param with
662 | Some s ->
663 expand ([ Ast.WordName s ] :: acc) ctx rest
664 | None ->
665 expand ([ Ast.WordName param ] :: acc) ctx rest)))
666 )
667 | Ast.VariableAtom
668 ( s,
669 (( RemoveSmallestSuffixPattern cst
670 | RemoveLargestSuffixPattern cst ) as v) ) -> (
671 let ctx, spp = expand_cst ctx cst in
672 let pattern = Ast.word_components_to_string spp in
673 match ctx with
674 | Exit.Nonzero _ as ctx -> (ctx, List.rev acc |> List.concat)
675 | Exit.Zero ctx -> (
676 match S.lookup ctx.state ~param:s with
677 | None -> expand (cst :: acc) ctx rest
678 | Some cst -> (
679 let kind =
680 match v with
681 | RemoveSmallestSuffixPattern _ -> `Smallest
682 | RemoveLargestSuffixPattern _ -> `Largest
683 | _ -> assert false
684 in
685 let param = Ast.word_components_to_string cst in
686 let suffix = get_suffix ~pattern ~kind param in
687 match suffix with
688 | None -> expand ([ Ast.WordName param ] :: acc) ctx rest
689 | Some s -> (
690 match String.cut_suffix ~suffix:s param with
691 | Some s ->
692 expand ([ Ast.WordName s ] :: acc) ctx rest
693 | None ->
694 expand ([ Ast.WordName param ] :: acc) ctx rest)))
695 )
696 | Ast.VariableAtom (s, UseAlternativeValue (_, alt)) -> (
697 match S.lookup ctx.state ~param:s with
698 | Some _ -> expand (alt :: acc) ctx rest
699 | None -> expand ([ Ast.WordEmpty ] :: acc) ctx rest)
700 | Ast.VariableAtom (s, AssignDefaultValues (_, value)) -> (
701 match S.lookup ctx.state ~param:s with
702 | Some cst -> expand (cst :: acc) ctx rest
703 | None -> (
704 match S.update ctx.state ~param:s value with
705 | Ok state ->
706 let new_ctx = { ctx with state } in
707 expand (value :: acc) new_ctx rest
708 | Error m ->
709 ( Exit.nonzero_msg ~exit_code:1 ctx "%s" m,
710 List.rev acc |> List.concat )))
711 | Ast.VariableAtom (_, IndicateErrorifNullorUnset (_, _)) ->
712 Fmt.failwith "TODO: Indicate Error")
713 | Ast.WordDoubleQuoted cst :: rest -> (
714 let new_ctx, cst_acc = expand [] ctx cst in
715 match new_ctx with
716 | Exit.Nonzero _ -> (new_ctx, cst_acc)
717 | Exit.Zero new_ctx ->
718 expand ([ Ast.WordDoubleQuoted cst_acc ] :: acc) new_ctx rest)
719 | Ast.WordSingleQuoted cst :: rest -> (
720 let new_ctx, cst_acc = expand [] ctx cst in
721 match new_ctx with
722 | Exit.Nonzero _ -> (new_ctx, cst_acc)
723 | Exit.Zero new_ctx ->
724 expand ([ Ast.WordSingleQuoted cst_acc ] :: acc) new_ctx rest)
725 | Ast.WordAssignmentWord (n, w) :: rest -> (
726 let new_ctx, cst_acc = expand [] ctx w in
727 match new_ctx with
728 | Exit.Nonzero _ -> (new_ctx, cst_acc)
729 | Exit.Zero new_ctx ->
730 expand
731 ([ Ast.WordAssignmentWord (n, cst_acc) ] :: acc)
732 new_ctx rest)
733 | v :: rest -> expand ([ v ] :: acc) ctx rest
734 in
735 expand [] ctx ast
736
737 and handle_export_or_readonly kind ctx (assignments : Ast.word_cst list) =
738 let flags, assignments =
739 List.fold_left
740 (fun (fs, args) -> function
741 | [ Ast.WordName v ] | [ Ast.WordLiteral v ] -> (
742 match Astring.String.cut ~sep:"-" v with
743 | Some ("", f) -> (f :: fs, args)
744 | _ -> (fs, [ Ast.WordName v ] :: args))
745 | v -> (fs, v :: args))
746 ([], []) assignments
747 in
748 let update =
749 match kind with
750 | `Export -> update ~export:true ~readonly:false
751 | `Readonly -> update ~export:false ~readonly:true
752 in
753 let rec loop acc_ctx = function
754 | [] -> Exit.zero acc_ctx
755 | Ast.WordAssignmentWord (Name param, v) :: rest ->
756 update acc_ctx ~param v >>= fun new_ctx -> loop new_ctx rest
757 | Ast.WordName param :: rest -> (
758 match S.lookup acc_ctx.state ~param with
759 | Some v ->
760 update acc_ctx ~param v >>= fun new_ctx -> loop new_ctx rest
761 | None -> loop acc_ctx rest)
762 | c :: _ ->
763 Exit.nonzero_msg acc_ctx "export weird arguments: %s\n"
764 (Ast.word_component_to_string c)
765 in
766 match flags with
767 | [] ->
768 List.fold_left
769 (fun ctx w -> match ctx with Exit.Zero ctx -> loop ctx w | _ -> ctx)
770 (Exit.zero ctx) assignments
771 | fs ->
772 if List.mem "p" fs then begin
773 match kind with
774 | `Readonly -> S.pp_readonly Fmt.stdout ctx.state
775 | `Export -> S.pp_export Fmt.stdout ctx.state
776 end;
777 Exit.zero ctx
778
779 and expand_cst (ctx : ctx) cst : ctx Exit.t * Ast.word_cst =
780 let cst = tilde_expansion ctx cst in
781 let ctx, cst = parameter_expansion' ctx cst in
782 match ctx with
783 | Exit.Nonzero _ as ctx -> (ctx, cst)
784 | Exit.Zero ctx ->
785 (* TODO: Propagate errors *)
786 let ctx, ast = arithmetic_expansion ctx cst in
787 (Exit.zero ctx, ast)
788
789 and expand_redirects ((ctx, acc) : ctx * Ast.cmd_suffix_item list)
790 (c : Ast.cmd_suffix_item list) =
791 match c with
792 | [] -> (ctx, List.rev acc)
793 | Ast.Suffix_redirect (IoRedirect_IoFile (num, (op, file))) :: rest -> (
794 let ctx, cst = expand_cst ctx file in
795 match ctx with
796 | Exit.Nonzero _ -> assert false
797 | Exit.Zero ctx ->
798 let cst = handle_subshell ctx cst in
799 let v = Ast.Suffix_redirect (IoRedirect_IoFile (num, (op, cst))) in
800 expand_redirects (ctx, v :: acc) rest)
801 | (Ast.Suffix_redirect _ as v) :: rest ->
802 expand_redirects (ctx, v :: acc) rest
803 | s :: rest -> expand_redirects (ctx, s :: acc) rest
804
805 and handle_and_or ~sw:_ ~async ctx c =
806 let pipeline = function
807 | Ast.Pipeline p -> (Fun.id, p)
808 | Ast.Pipeline_Bang p -> (Exit.not, p)
809 in
810
811 let rec fold :
812 Ast.and_or * ctx Exit.t -> Ast.pipeline Ast.and_or_list -> ctx Exit.t =
813 fun (sep, exit_so_far) pipe ->
814 match (sep, pipe) with
815 | And, Nlist.Singleton (p, _) -> (
816 match exit_so_far with
817 | Exit.Zero ctx ->
818 let f, p = pipeline p in
819 f @@ handle_pipeline ~async ctx p
820 | v -> v)
821 | Or, Nlist.Singleton (p, _) -> (
822 match exit_so_far with
823 | Exit.Zero _ as ctx -> ctx
824 | _ ->
825 let f, p = pipeline p in
826 f @@ handle_pipeline ~async ctx p)
827 | Noand_or, Nlist.Singleton (p, _) ->
828 let f, p = pipeline p in
829 f @@ handle_pipeline ~async ctx p
830 | Noand_or, Nlist.Cons ((p, next_sep), rest) ->
831 let f, p = pipeline p in
832 let exit_status = f (handle_pipeline ~async ctx p) in
833 fold (next_sep, exit_status) rest
834 | And, Nlist.Cons ((p, next_sep), rest) -> (
835 match exit_so_far with
836 | Exit.Zero ctx ->
837 let f, p = pipeline p in
838 fold (next_sep, f (handle_pipeline ~async ctx p)) rest
839 | Exit.Nonzero _ as v -> v)
840 | Or, Nlist.Cons ((p, next_sep), rest) -> (
841 match exit_so_far with
842 | Exit.Zero _ as exit_so_far -> fold (next_sep, exit_so_far) rest
843 | Exit.Nonzero _ ->
844 let f, p = pipeline p in
845 fold (next_sep, f (handle_pipeline ~async ctx p)) rest)
846 in
847 fold (Noand_or, Exit.zero ctx) c
848
849 and handle_for_clause ctx v : ctx Exit.t =
850 match v with
851 | Ast.For_Name_DoGroup (_, (term, sep)) -> exec ctx (term, Some sep)
852 | Ast.For_Name_In_WordList_DoGroup (Name name, wdlist, (term, sep)) ->
853 let wdlist = Nlist.flatten @@ Nlist.map (word_glob_expand ctx) wdlist in
854 Nlist.fold_left
855 (fun _ word ->
856 update ctx ~param:name word >>= fun ctx -> exec ctx (term, Some sep))
857 (Exit.zero ctx) wdlist
858
859 and handle_if_clause ctx = function
860 | Ast.If_then ((e1, sep1), (e2, sep2)) -> (
861 let ctx = exec ctx (e1, Some sep1) in
862 match ctx with
863 | Exit.Zero ctx -> exec ctx (e2, Some sep2)
864 | Exit.Nonzero { value = ctx; _ } -> Exit.zero ctx)
865 | Ast.If_then_else ((e1, sep1), (e2, sep2), else_part) -> (
866 let ctx = exec ctx (e1, Some sep1) in
867 match ctx with
868 | Exit.Zero ctx -> exec ctx (e2, Some sep2)
869 | Exit.Nonzero { value = ctx; _ } -> handle_else_part ctx else_part)
870
871 and handle_else_part ctx = function
872 | Ast.Else (c, sep) -> exec ctx (c, Some sep)
873 | Ast.Elif_then ((e1, sep1), (e2, sep2)) -> (
874 let ctx = exec ctx (e1, Some sep1) in
875 match ctx with
876 | Exit.Zero ctx -> exec ctx (e2, Some sep2)
877 | Exit.Nonzero { value = ctx; _ } -> Exit.zero ctx)
878 | Ast.Elif_then_else ((e1, sep1), (e2, sep2), else_part) -> (
879 let ctx = exec ctx (e1, Some sep1) in
880 match ctx with
881 | Exit.Zero ctx -> exec ctx (e2, Some sep2)
882 | Exit.Nonzero { value = ctx; _ } -> handle_else_part ctx else_part)
883
884 and handle_case_clause ctx = function
885 | Ast.Case _ -> Exit.zero ctx
886 | Cases (word, case_list) -> (
887 let ctx, word = expand_cst ctx word in
888 match ctx with
889 | Exit.Nonzero _ as ctx -> ctx
890 | Exit.Zero ctx -> (
891 let scrutinee = Ast.word_components_to_string word in
892 let res =
893 Nlist.fold_left
894 (fun acc pat ->
895 match acc with
896 | Some _ as ctx -> ctx
897 | None -> (
898 match pat with
899 | Ast.Case_pattern (p, sub) ->
900 Nlist.fold_left
901 (fun inner_acc pattern ->
902 match inner_acc with
903 | Some _ as v -> v
904 | None -> (
905 let ctx, pattern = expand_cst ctx pattern in
906 match ctx with
907 | Exit.Nonzero _ as ctx -> Some ctx
908 | Exit.Zero ctx ->
909 let pattern =
910 Ast.word_components_to_string pattern
911 in
912 if Glob.test ~pattern scrutinee then begin
913 match sub with
914 | Some sub ->
915 Some (exec_subshell ctx sub)
916 | None -> Some (Exit.zero ctx)
917 end
918 else inner_acc))
919 None p))
920 None case_list
921 in
922 match res with Some ctx -> ctx | None -> Exit.zero ctx))
923
924 and exec_subshell ctx (term, sep) =
925 let saved_ctx = ctx in
926 let e = exec ctx (term, Some sep) in
927 let v = e >|= fun _ -> saved_ctx in
928 v
929
930 and handle_while_clause ctx
931 (While ((term, sep), (term', sep')) : Ast.while_clause) =
932 let rec loop exit_so_far =
933 let running_ctx = Exit.value exit_so_far in
934 match exec running_ctx (term, Some sep) with
935 | Exit.Nonzero _ -> exit_so_far (* TODO: Context? *)
936 | Exit.Zero ctx -> loop (exec ctx (term', Some sep'))
937 in
938 loop (Exit.zero ctx)
939
940 and handle_until_clause ctx
941 (Until ((term, sep), (term', sep')) : Ast.until_clause) =
942 let rec loop exit_so_far =
943 let running_ctx = Exit.value exit_so_far in
944 match exec running_ctx (term, Some sep) with
945 | Exit.Zero _ -> exit_so_far (* TODO: Context? *)
946 | Exit.Nonzero { value = ctx; _ } -> loop (exec ctx (term', Some sep'))
947 in
948 loop (Exit.zero ctx)
949
950 and handle_compound_command ctx v : ctx Exit.t =
951 match v with
952 | Ast.ForClause fc -> handle_for_clause ctx fc
953 | Ast.IfClause if_ -> handle_if_clause ctx if_
954 | Ast.BraceGroup (term, sep) -> exec ctx (term, Some sep)
955 | Ast.Subshell s -> exec_subshell ctx s
956 | Ast.CaseClause cases -> handle_case_clause ctx cases
957 | Ast.WhileClause while_ -> handle_while_clause ctx while_
958 | Ast.UntilClause until -> handle_until_clause ctx until
959
960 and handle_function_application (ctx : ctx) ~name argv : ctx Exit.t option =
961 match List.assoc_opt name ctx.functions with
962 | None -> None
963 | Some commands ->
964 let ctx = { ctx with argv = Array.of_list argv } in
965 Option.some @@ (handle_compound_command ctx commands >|= fun _ -> ctx)
966
967 and needs_subshelling = function
968 | [] -> false
969 | Ast.WordSubshell _ :: _ -> true
970 | Ast.WordDoubleQuoted word :: rest ->
971 needs_subshelling word || needs_subshelling rest
972 | Ast.WordSingleQuoted word :: rest ->
973 needs_subshelling word || needs_subshelling rest
974 | _ -> false
975
976 and handle_subshell (ctx : ctx) wcs =
977 let exec_subshell ~sw ctx s =
978 let buf = Buffer.create 16 in
979 let stdout = Eio.Flow.buffer_sink buf in
980 let r, w = Eio_unix.pipe sw in
981 Eio.Fiber.fork ~sw (fun () -> Eio.Flow.copy r stdout);
982 let subshell_ctx = { ctx with stdout = w; subshell = true } in
983 let sub_ctx, _ = run (Exit.zero subshell_ctx) s in
984 Eio.Flow.close w;
985 ((sub_ctx >|= fun _ -> ctx), Buffer.contents buf)
986 in
987 let rec run_subshells ~sw ran_subshell = function
988 | [] -> []
989 | Ast.WordSubshell s :: rest ->
990 let _ctx, std = exec_subshell ~sw ctx s in
991 ran_subshell := true;
992 Ast.WordName (String.trim std) :: run_subshells ~sw ran_subshell rest
993 | Ast.WordDoubleQuoted word :: rest ->
994 let subshell_q = ref false in
995 let res = run_subshells ~sw subshell_q word in
996 if !subshell_q then res @ run_subshells ~sw subshell_q rest
997 else Ast.WordDoubleQuoted res :: run_subshells ~sw subshell_q rest
998 | Ast.WordSingleQuoted word :: rest ->
999 let subshell_q = ref false in
1000 let res = run_subshells ~sw subshell_q word in
1001 if !subshell_q then res @ run_subshells ~sw subshell_q rest
1002 else Ast.WordSingleQuoted res :: run_subshells ~sw subshell_q rest
1003 | v :: rest -> v :: run_subshells ~sw ran_subshell rest
1004 in
1005 Eio.Switch.run @@ fun sw -> run_subshells ~sw (ref false) wcs
1006
1007 and handle_word_cst_subshell (ctx : ctx) wcs : Ast.word_cst =
1008 if needs_subshelling wcs then begin
1009 let wcs = handle_subshell ctx wcs in
1010 wcs
1011 end
1012 else wcs
1013
1014 and glob_expand ctx wc =
1015 let wc = handle_word_cst_subshell ctx wc in
1016 if Ast.has_glob wc && not ctx.options.no_path_expansion then
1017 Ast.word_components_to_string wc |> fun pattern ->
1018 Glob.glob_dir ~pattern (cwd_of_ctx ctx)
1019 |> List.map (fun w -> [ Ast.WordName w ])
1020 else [ wc ]
1021
1022 and word_glob_expand (ctx : ctx) wc : Ast.word_cst list =
1023 if List.exists needs_glob_expansion wc then glob_expand ctx wc
1024 else [ handle_word_cst_subshell ctx wc ]
1025
1026 and collect_assignments ?(update = true) ctx vs : ctx Exit.t =
1027 List.fold_left
1028 (fun ctx prefix ->
1029 match ctx with
1030 | Exit.Nonzero _ -> ctx
1031 | Exit.Zero ctx -> (
1032 match prefix with
1033 | Ast.Prefix_assignment (Name param, v) -> (
1034 (* Expand the values *)
1035 let ctx, v = expand_cst ctx v in
1036 match ctx with
1037 | Exit.Nonzero _ as ctx -> ctx
1038 | Exit.Zero ctx -> (
1039 let v = handle_subshell ctx v in
1040 let state =
1041 if update then S.update ctx.state ~param v
1042 else Ok ctx.state
1043 in
1044 match state with
1045 | Error message -> Exit.nonzero ~message ctx 1
1046 | Ok state ->
1047 Exit.zero
1048 {
1049 ctx with
1050 state;
1051 local_state =
1052 (param, Ast.word_components_to_string v)
1053 :: ctx.local_state;
1054 }))
1055 | _ -> Exit.zero ctx))
1056 (Exit.zero ctx) vs
1057
1058 and args ctx swc : ctx Exit.t * Ast.word_cst list =
1059 List.fold_left
1060 (fun (ctx, acc) -> function
1061 | Ast.Suffix_redirect _ -> (ctx, acc)
1062 | Suffix_word wc -> (
1063 match ctx with
1064 | Exit.Nonzero _ as ctx -> (ctx, acc)
1065 | Exit.Zero ctx -> (
1066 let ctx, cst = expand_cst ctx wc in
1067 match ctx with
1068 | Exit.Nonzero _ as ctx -> (ctx, acc)
1069 | Exit.Zero c as ctx -> (ctx, acc @ word_glob_expand c cst))))
1070 (Exit.zero ctx, [])
1071 swc
1072
1073 and handle_built_in ~rdrs ~(stdout : Eio_unix.sink_ty Eio.Flow.sink)
1074 (ctx : ctx) v =
1075 let rdrs = ctx.rdrs @ rdrs in
1076 Eunix.with_redirections rdrs @@ fun () ->
1077 match v with
1078 | Built_ins.Cd { path } ->
1079 let cwd = S.cwd ctx.state in
1080 let+ state =
1081 match path with
1082 | Some p ->
1083 let fp = Fpath.append cwd (Fpath.v p) in
1084 if Eio.Path.is_directory (ctx.fs / Fpath.to_string fp) then
1085 Exit.zero @@ S.set_cwd ctx.state fp
1086 else
1087 Exit.nonzero_msg ~exit_code:1 ctx.state
1088 "cd: not a directory: %a" Fpath.pp fp
1089 | None -> (
1090 match Eunix.find_env "HOME" with
1091 | None -> Exit.nonzero_msg ctx.state "HOME not set"
1092 | Some p -> Exit.zero (S.set_cwd ctx.state @@ Fpath.v p))
1093 in
1094 { ctx with state }
1095 | Pwd ->
1096 let () =
1097 Eio.Flow.copy_string
1098 (Fmt.str "%a\n%!" Fpath.pp (S.cwd ctx.state))
1099 stdout
1100 in
1101 Exit.zero ctx
1102 | Exit n ->
1103 let should_exit =
1104 { Exit.default_should_exit with interactive = `Yes }
1105 in
1106 Exit.nonzero ~should_exit ctx n
1107 | Set { update; print_options } ->
1108 let v =
1109 Exit.zero
1110 { ctx with options = Built_ins.Options.update ctx.options update }
1111 in
1112 if print_options then
1113 Eio.Flow.copy_string
1114 (Fmt.str "%a" Built_ins.Options.pp ctx.options)
1115 stdout;
1116 v
1117 | Wait i -> (
1118 match Unix.waitpid [] i with
1119 | _, WEXITED 0 -> Exit.zero ctx
1120 | _, (WEXITED n | WSIGNALED n | WSTOPPED n) -> Exit.nonzero ctx n)
1121 | Dot file -> (
1122 match resolve_program ctx file with
1123 | ctx, None -> Exit.nonzero ctx 127
1124 | ctx, Some f ->
1125 let program = Ast.of_file (ctx.fs / f) in
1126 let ctx, _ = run (Exit.zero ctx) program in
1127 ctx)
1128 | Unset names -> (
1129 match names with
1130 | `Variables names ->
1131 let state =
1132 List.fold_left
1133 (fun t param -> S.remove ~param t |> snd)
1134 ctx.state names
1135 in
1136 Exit.zero { ctx with state }
1137 | `Functions names ->
1138 let functions =
1139 List.fold_left
1140 (fun t param -> List.remove_assoc param t)
1141 ctx.functions names
1142 in
1143 Exit.zero { ctx with functions })
1144 | Hash v -> (
1145 match v with
1146 | Built_ins.Hash_remove -> Exit.zero { ctx with hash = Hash.empty }
1147 | Built_ins.Hash_stats ->
1148 Eio.Flow.copy_string (Fmt.str "%a" Hash.pp ctx.hash) stdout;
1149 Exit.zero ctx
1150 | _ -> assert false)
1151 | Alias | Unalias -> Exit.zero ctx (* Morbig handles this for us *)
1152 | Eval args ->
1153 let script = String.concat " " args in
1154 let ast = Ast.of_string script in
1155 let ctx, _ = run (Exit.zero ctx) ast in
1156 ctx
1157 | Echo args ->
1158 let str = String.concat " " args ^ "\n" in
1159 Eio.Flow.copy_string str stdout;
1160 Exit.zero ctx
1161 | Trap (action, signals) ->
1162 let saved_ctx = ctx in
1163 let action =
1164 match action with
1165 | Action m ->
1166 let ast = Ast.of_string m in
1167 let f _ =
1168 saved_ctx.signal_handler.run @@ fun () ->
1169 let _, _ = run (Exit.zero saved_ctx) ast in
1170 ()
1171 in
1172 Sys.Signal_handle f
1173 | Default -> Sys.Signal_default
1174 | Ignore -> Sys.Signal_ignore
1175 | Int _ -> assert false
1176 in
1177 Exit.zero
1178 @@ List.fold_left
1179 (fun ctx signal ->
1180 match signal with
1181 | `Exit ->
1182 let action =
1183 match action with
1184 | Sys.Signal_default | Sys.Signal_ignore -> None
1185 | Sys.Signal_handle f -> Some (fun () -> f 0)
1186 in
1187 { ctx with exit_handler = action }
1188 | `Signal signal ->
1189 let action =
1190 (* Handle sigint separately for interactive mode *)
1191 match (action, signal) with
1192 | Sys.Signal_default, Eunix.Signals.Interrupt ->
1193 if ctx.interactive then Sys.Signal_ignore else action
1194 | _ -> action
1195 in
1196 let setting_sigint =
1197 ctx.signal_handler.sigint_set = false
1198 &&
1199 match action with
1200 | Sys.Signal_handle _ -> true
1201 | _ -> false
1202 in
1203 Sys.set_signal (Eunix.Signals.to_int signal) action;
1204 {
1205 ctx with
1206 signal_handler =
1207 { ctx.signal_handler with sigint_set = setting_sigint };
1208 })
1209 ctx signals
1210 | Command _ ->
1211 (* Handled separately *)
1212 assert false
1213
1214 and exec initial_ctx ((command, sep) : Ast.complete_command) =
1215 let rec loop : Eio.Switch.t -> ctx -> Ast.clist -> ctx Exit.t =
1216 fun sw ctx -> function
1217 | Nlist.Singleton (c, sep) ->
1218 let async =
1219 match sep with Semicolon -> false | Ampersand -> true
1220 in
1221 handle_and_or ~sw ~async ctx c
1222 | Nlist.Cons ((c, sep), cs) -> (
1223 let async =
1224 match sep with Semicolon -> false | Ampersand -> true
1225 in
1226 match handle_and_or ~sw ~async ctx c with
1227 | Exit.Zero ctx -> loop sw ctx cs
1228 | v -> v)
1229 in
1230 match sep with
1231 | Some Semicolon | None ->
1232 Eio.Switch.run @@ fun sw -> loop sw initial_ctx command
1233 | Some Ampersand ->
1234 Fiber.fork ~sw:initial_ctx.async_switch (fun () ->
1235 Fiber.yield ();
1236 let _ : ctx Exit.t =
1237 loop initial_ctx.async_switch initial_ctx command
1238 in
1239 ());
1240 Exit.zero initial_ctx
1241
1242 and execute ctx ast = exec ctx ast
1243
1244 and run ctx ast =
1245 (* Make the shell its own process group *)
1246 Eunix.make_process_group ();
1247 let ctx, cs =
1248 let rec loop_commands (ctx, cs) (c : Ast.complete_commands) =
1249 match c with
1250 | [] -> (ctx, cs)
1251 | command :: commands -> (
1252 let ctx = Exit.value ctx in
1253 (* For our sanity *)
1254 let has_async = Ast.has_async command in
1255 if has_async && not ctx.options.async then begin
1256 Fmt.epr
1257 "You are using asynchronous operators and [set -o async] has \
1258 not been called.\n\
1259 %!";
1260 exit ctx 1
1261 end;
1262 let exit =
1263 try execute ctx command
1264 with
1265 | Eio.Io (Eio.Process.E (Eio.Process.Executable_not_found m), _ctx)
1266 ->
1267 Exit.nonzero_msg ctx ~exit_code:127 "command not found: %s" m
1268 in
1269 match exit with
1270 | Exit.Nonzero { exit_code; message; should_exit; _ } -> (
1271 Option.iter (Fmt.epr "%s\n%!") message;
1272 match
1273 ( should_exit.interactive,
1274 should_exit.non_interactive,
1275 ctx.subshell,
1276 ctx.interactive,
1277 commands )
1278 with
1279 | `Yes, _, false, true, [] | _, `Yes, false, false, [] ->
1280 if should_exit.interactive = `Yes then Fmt.epr "exit\n%!";
1281 Stdlib.exit exit_code
1282 | _ -> loop_commands (exit, c :: cs) commands)
1283 | Exit.Zero _ as ctx -> loop_commands (ctx, c :: cs) commands)
1284 in
1285 loop_commands (ctx, []) ast
1286 in
1287 (ctx, List.rev cs)
1288end