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