patrick.sirref.org
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
9let pp_args = Fmt.(list ~sep:(Fmt.any " ") string)
10
11let pp_fs_create ppf (v : Eio.Fs.create) =
12 match v with
13 | `If_missing o -> Fmt.pf ppf "if-missing %o" o
14 | `Exclusive o -> Fmt.pf ppf "exclusive %o" o
15 | `Or_truncate o -> Fmt.pf ppf "or-truncate %o" o
16 | `Never -> Fmt.pf ppf "never"
17
18let make_child_rdrs_for_parent =
19 List.map (function
20 | Types.Child_redirect (a, b, c) -> Types.Parent_redirect (a, b, c)
21 | v -> v)
22
23(** An evaluator over the AST *)
24module Make (S : Types.State) (E : Types.Exec) = struct
25 (* What follows uses the POSIX definition of what a shell does ($ 2.1).
26
27 It starts from point (4), completing a series of expansions on the AST,
28 then redirection is setup, and finally functions/built-ins/commands are
29 executed. *)
30
31 module J = Job.Make (E)
32 module A = Arith.Make (S)
33
34 type signal_handler = { run : (unit -> unit) -> unit; sigint_set : bool }
35
36 type ctx = {
37 interactive : bool;
38 subshell : bool;
39 state : S.t;
40 local_state : (string * string) list;
41 executor : E.t;
42 fs : Eio.Fs.dir_ty Eio.Path.t;
43 options : Built_ins.Options.t;
44 stdin : Eio_unix.source_ty Eio.Flow.source;
45 stdout : Eio_unix.sink_ty Eio.Flow.sink;
46 background_jobs : J.t list;
47 last_background_process : string;
48 last_pipeline_status : int option;
49 async_switch : Eio.Switch.t;
50 program : string;
51 argv : string array;
52 functions : (string * Ast.compound_command) list;
53 hash : Hash.t;
54 rdrs : Types.redirect list;
55 signal_handler : signal_handler;
56 exit_handler : (unit -> unit) option;
57 in_double_quotes : bool;
58 umask : int;
59 fd_pool : Fd_pool.t;
60 }
61
62 exception Continue of int * ctx
63 (* Used for the [continue] non-POSIX keyword *)
64
65 exception Break of int * ctx
66 (* Used for the [break] non-POSIX keyword *)
67
68 exception Return of ctx Exit.t
69 (* Used for the [return] non-POSIX keyword *)
70
71 let make_ctx ?(interactive = false) ?(subshell = false) ?(local_state = [])
72 ?(background_jobs = []) ?(last_background_process = "")
73 ?last_pipeline_status ?(functions = []) ?(rdrs = []) ?exit_handler
74 ?(options = Built_ins.Options.default) ?(hash = Hash.empty)
75 ?(in_double_quotes = false) ?(umask = 0o22) ~fs ~stdin ~stdout
76 ~async_switch ~program ~argv ~signal_handler state executor =
77 let signal_handler = { run = signal_handler; sigint_set = false } in
78 {
79 interactive;
80 subshell;
81 state;
82 local_state;
83 executor;
84 fs;
85 options;
86 stdin;
87 stdout;
88 background_jobs;
89 last_background_process;
90 last_pipeline_status;
91 async_switch;
92 program;
93 argv;
94 functions;
95 hash;
96 rdrs;
97 signal_handler;
98 exit_handler;
99 in_double_quotes;
100 umask;
101 fd_pool = Fd_pool.make 256;
102 }
103
104 let state ctx = ctx.state
105 let sigint_set ctx = ctx.signal_handler.sigint_set
106 let fs ctx = ctx.fs
107 let clear_local_state ctx = { ctx with local_state = [] }
108
109 let tilde_expansion ctx = function
110 | Ast.WordTildePrefix _ -> Ast.WordTildePrefix (S.expand ctx.state `Tilde)
111 | v -> v
112
113 let word_cst_to_string ?field_splitting v =
114 Ast.word_components_to_strings ?field_splitting v |> String.concat ""
115
116 let arithmetic_expansion ctx word =
117 let expr = word_cst_to_string word in
118 let aexpr = Arith_parser.main Arith_lexer.read (Lexing.from_string expr) in
119 let state, i = A.eval ctx.state aexpr in
120 ({ ctx with state }, Ast.Fragment.make (string_of_int i))
121
122 let stdout_for_pipeline ~sw ctx = function
123 | [] -> (None, `Global ctx.stdout)
124 | _ ->
125 let r, w = Fd_pool.pipe ctx.fd_pool sw in
126 (Some r, `Local (w :> Eio_unix.sink_ty Eio.Flow.sink))
127
128 let fd_of_int ?(close_unix = true) ~sw (n : int) =
129 Eio_unix.Fd.of_unix ~close_unix ~sw (Obj.magic n : Unix.file_descr)
130
131 let file_creation_mode ctx = 0o666 - ctx.umask
132 let cwd_of_ctx ctx = S.cwd ctx.state |> Fpath.to_string |> ( / ) ctx.fs
133
134 let resolve_program ?(update = true) ctx name =
135 let v =
136 if not (String.contains name '/') then begin
137 S.lookup ctx.state ~param:"PATH"
138 |> Option.value ~default:"/bin:/usr/bin"
139 |> String.split_on_char ':'
140 |> List.find_map (fun dir ->
141 let p = Filename.concat dir name in
142 if Sys.file_exists p then Some p else None)
143 end
144 else if Sys.file_exists name then Some name
145 else None
146 in
147 match (update, v) with
148 | true, Some loc ->
149 let hash = Hash.add ~utility:name ~loc ctx.hash in
150 ({ ctx with hash }, Some loc)
151 | false, Some loc -> (ctx, Some loc)
152 | _, None -> (ctx, None)
153
154 let get_env ?(extra = []) ctx =
155 let extra =
156 extra @ List.map (fun (k, v) -> (k, v)) @@ S.exports ctx.state
157 in
158 let env = Eunix.env () in
159 List.fold_left (fun acc (k, _) -> List.remove_assoc k acc) env extra
160 |> List.append extra
161
162 let update ?export ?readonly ctx ~param v =
163 match S.update ?export ?readonly ctx.state ~param v with
164 | Ok state -> Exit.zero { ctx with state }
165 | Error msg ->
166 Fmt.epr "%s\n%!" msg;
167 Exit.nonzero ctx 1
168
169 let remove_quotes s =
170 let s_len = String.length s in
171 let s = if s.[0] = '"' then String.sub s 1 (s_len - 1) else s in
172 let s_len = String.length s in
173 if s.[s_len - 1] = '"' then String.sub s 0 (s_len - 1) else s
174
175 let exit ctx code =
176 Option.iter (fun f -> f ()) ctx.exit_handler;
177 exit code
178
179 let rec handle_pipeline ~async initial_ctx p : ctx Exit.t =
180 let set_last_background ~async process ctx =
181 if async then
182 { ctx with last_background_process = string_of_int (E.pid process) }
183 else ctx
184 in
185 let on_process ?process ~async ctx =
186 let ctx = clear_local_state ctx in
187 match process with
188 | None -> ctx
189 | Some process -> set_last_background ~async process ctx
190 in
191 let handle_job j = function
192 | `Process p -> J.add_process p j
193 | `Rdr p -> J.add_rdr p j
194 | `Built_in p -> J.add_built_in p j
195 | `Error p -> J.add_error p j
196 | `Exit p -> J.add_exit p j
197 in
198 let close_stdout ~is_global some_write =
199 if not is_global then begin
200 Eio.Flow.close some_write
201 end
202 in
203 let exec_process ~sw ctx job ?fds ?stdin ~stdout ?pgid executable args =
204 let pgid = match pgid with None -> 0 | Some p -> p in
205 let reap = J.get_reaper job in
206 let mode = if async then Types.Async else Types.Switched sw in
207 let fds = ctx.rdrs @ Option.value ~default:[] fds in
208 let ctx, process =
209 match (executable, resolve_program ctx executable) with
210 | _, (ctx, None) | "", (ctx, _) ->
211 Eio.Flow.copy_string
212 (Fmt.str "msh: command not found: %s\n" executable)
213 stdout;
214 (ctx, Error (127, `Not_found))
215 | _, (ctx, Some full_path) ->
216 Debug.Log.debug (fun f ->
217 f "executing %a\n%a"
218 Fmt.(list ~sep:(Fmt.any " ") (quote string))
219 (full_path :: args)
220 Fmt.(list Types.pp_redirect)
221 fds);
222 ( ctx,
223 E.exec ctx.executor ~delay_reap:(fst reap) ~fds ?stdin ~stdout
224 ~pgid ~mode ~cwd:(cwd_of_ctx ctx)
225 ~env:(get_env ~extra:ctx.local_state ctx)
226 ~executable:full_path (executable :: args) )
227 in
228 match process with
229 | Error (n, _) ->
230 let job = handle_job job (`Error n) in
231 (on_process ~async ctx, job)
232 | Ok process ->
233 let pgid = if Int.equal pgid 0 then E.pid process else pgid in
234 let job = handle_job job (`Process process) |> J.set_id pgid in
235 (on_process ~async ~process ctx, job)
236 in
237 let job_pgid (t : J.t) = J.get_id t in
238 let rec loop pipeline_switch (ctx : ctx) (job : J.t)
239 (stdout_of_previous : Eio_unix.source_ty Eio_unix.source option) :
240 Ast.command list -> ctx * J.t =
241 fun c ->
242 let loop = loop pipeline_switch in
243 match c with
244 | Ast.SimpleCommand (Prefixed (prefix, None, _suffix)) :: rest ->
245 Debug.Log.debug (fun f ->
246 f "assignment-only: %a" yojson_pp
247 (Ast.cmd_prefix_to_yojson prefix));
248 let ctx = collect_assignments ctx prefix in
249 let job = handle_job job (`Built_in (Exit.ignore ctx)) in
250 loop (Exit.value ctx) job stdout_of_previous rest
251 | Ast.SimpleCommand (Prefixed (prefix, Some executable, suffix)) :: rest
252 ->
253 let ctx = collect_assignments ~update:false ctx prefix in
254 let job = handle_job job (`Built_in (Exit.ignore ctx)) in
255 loop (Exit.value ctx) job stdout_of_previous
256 (Ast.SimpleCommand (Named (executable, suffix)) :: rest)
257 | Ast.SimpleCommand (Named (executable, suffix)) :: rest -> (
258 let ctx, executable = word_expansion ctx executable in
259 match ctx with
260 | Exit.Nonzero _ as ctx ->
261 let job = handle_job job (`Built_in (Exit.ignore ctx)) in
262 loop (Exit.value ctx) job stdout_of_previous rest
263 | Exit.Zero ctx -> (
264 let executable, extra_args =
265 (* This is a side-effect of the alias command with something like
266 alias ls="ls -la" *)
267 match
268 Ast.Fragment.join_list ~sep:"" (List.concat executable)
269 |> String.split_on_char ' ' |> List.map Ast.Fragment.make
270 with
271 | [] -> ("", [])
272 | exec :: args ->
273 ( remove_quotes exec.txt,
274 List.map
275 (fun v ->
276 Ast.Suffix_word
277 [ Ast.WordLiteral (remove_quotes v.Ast.txt) ])
278 args )
279 in
280 let ctx, suffix =
281 match suffix with
282 | None -> (ctx, [])
283 | Some suffix -> expand_redirects (ctx, []) suffix
284 in
285 let ctx, args = args ctx (extra_args @ suffix) in
286 match ctx with
287 | Exit.Nonzero _ as ctx ->
288 let job = handle_job job (`Built_in (Exit.ignore ctx)) in
289 loop (Exit.value ctx) job stdout_of_previous rest
290 | Exit.Zero ctx -> (
291 let some_read, some_write =
292 stdout_for_pipeline ~sw:pipeline_switch ctx rest
293 in
294 let is_global, some_write =
295 match some_write with
296 | `Global p -> (true, p)
297 | `Local p -> (false, p)
298 in
299 let rdrs =
300 List.fold_left
301 (fun acc -> function
302 | Ast.Suffix_word _ -> acc
303 | Ast.Suffix_redirect rdr -> rdr :: acc)
304 [] suffix
305 |> List.rev
306 in
307 match
308 handle_redirections
309 ~sw:
310 (if String.equal executable "exec" then ctx.async_switch
311 else pipeline_switch)
312 ctx rdrs
313 with
314 | Error ctx -> (ctx, handle_job job (`Rdr (Exit.nonzero () 1)))
315 | Ok rdrs -> (
316 match Built_ins.of_args (executable :: args) with
317 | Some (Error _) ->
318 (ctx, handle_job job (`Built_in (Exit.nonzero () 1)))
319 | (None | Some (Ok (Command _))) as v -> (
320 let is_command, command_args, print_command =
321 match v with
322 | Some (Ok (Command { print_command; args })) ->
323 (true, args, print_command)
324 | _ -> (false, [], false)
325 in
326 (* We handle the [export] built_in explicitly as we
327 need access to the raw CST *)
328 match executable with
329 | "export" ->
330 let updated =
331 handle_assignments `Export ctx args
332 in
333 let job =
334 handle_job job
335 (`Built_in (updated >|= fun _ -> ()))
336 in
337 Debug.Log.debug (fun f ->
338 f "export %a" pp_args args);
339 loop (Exit.value updated) job stdout_of_previous
340 rest
341 | "readonly" ->
342 let updated =
343 handle_assignments `Readonly ctx args
344 in
345 let job =
346 handle_job job
347 (`Built_in (updated >|= fun _ -> ()))
348 in
349 Debug.Log.debug (fun f ->
350 f "readonly %a" pp_args args);
351 loop (Exit.value updated) job stdout_of_previous
352 rest
353 | "local" ->
354 let updated =
355 handle_assignments `Local ctx args
356 in
357 let job =
358 handle_job job
359 (`Built_in (updated >|= fun _ -> ()))
360 in
361 loop (Exit.value updated) job stdout_of_previous
362 rest
363 | "exec" ->
364 (* let _ = Sys.command "ls -la /proc/self/fd" in *)
365 Debug.Log.debug (fun f ->
366 f "exec [%a] [%a]" pp_args args
367 Fmt.(list Types.pp_redirect)
368 rdrs);
369 let rdrs = make_child_rdrs_for_parent rdrs in
370 Eunix.with_redirections ~restore:false rdrs
371 @@ fun () ->
372 if args <> [] then
373 Fmt.invalid_arg
374 "Exec with args not yet supported...";
375 (ctx, job)
376 | ":" -> (ctx, job)
377 | _ -> (
378 let saved_ctx = ctx in
379 let func_app =
380 if is_command then None
381 else
382 let ctx = { ctx with stdout = some_write } in
383 handle_function_application ctx
384 ~name:executable (ctx.program :: args)
385 in
386 match func_app with
387 | Some ctx ->
388 close_stdout ~is_global some_write;
389 (* TODO: Proper job stuff and redirects etc. *)
390 let job =
391 handle_job job (`Built_in (Exit.ignore ctx))
392 in
393 loop
394 {
395 saved_ctx with
396 state = (Exit.value ctx).state;
397 }
398 job some_read rest
399 | None -> (
400 match Built_ins.of_args command_args with
401 | Some (Error _) ->
402 ( ctx,
403 handle_job job
404 (`Built_in (Exit.nonzero () 1)) )
405 | Some (Ok bi) ->
406 let rdrs =
407 make_child_rdrs_for_parent rdrs
408 in
409 let ctx =
410 handle_built_in ~rdrs ~stdout:some_write
411 ctx bi
412 in
413 let ctx =
414 ctx >|= fun ctx -> clear_local_state ctx
415 in
416 close_stdout ~is_global some_write;
417 let job =
418 match bi with
419 | Built_ins.Exit _ ->
420 let v_ctx = Exit.value ctx in
421 if not v_ctx.subshell then
422 exit v_ctx (Exit.code ctx)
423 else
424 handle_job job
425 (`Exit (Exit.ignore ctx))
426 | _ ->
427 handle_job job
428 (`Built_in (Exit.ignore ctx))
429 in
430 loop (Exit.value ctx) job some_read rest
431 | _ -> (
432 let exec_and_args =
433 if is_command then begin
434 match command_args with
435 | [] -> assert false
436 | x :: xs -> (
437 match
438 resolve_program ~update:false
439 ctx x
440 with
441 | _, None ->
442 Exit.nonzero ("", []) 1
443 | _, Some prog ->
444 if print_command then
445 Exit.zero ("echo", [ prog ])
446 else Exit.zero (x, xs))
447 end
448 else Exit.zero (executable, args)
449 in
450 match exec_and_args with
451 | Exit.Nonzero _ as v ->
452 let job =
453 handle_job job
454 (`Built_in (Exit.ignore v))
455 in
456 loop ctx job some_read rest
457 | Exit.Zero (executable, args) -> (
458 match stdout_of_previous with
459 | None ->
460 let ctx, job =
461 exec_process ~sw:pipeline_switch
462 ctx job ~fds:rdrs
463 ~stdout:some_write
464 ~pgid:(job_pgid job)
465 executable args
466 in
467 close_stdout ~is_global some_write;
468 loop ctx job some_read rest
469 | Some stdout ->
470 let ctx, job =
471 exec_process ~sw:pipeline_switch
472 ctx job ~fds:rdrs
473 ~stdin:stdout
474 ~stdout:some_write
475 ~pgid:(job_pgid job)
476 executable args
477 in
478 close_stdout ~is_global some_write;
479 loop ctx job some_read rest)))))
480 | Some (Ok bi) ->
481 let rdrs = make_child_rdrs_for_parent rdrs in
482 let ctx =
483 handle_built_in ~rdrs ~stdout:some_write ctx bi
484 in
485 let ctx = ctx >|= fun ctx -> clear_local_state ctx in
486 close_stdout ~is_global some_write;
487 let job =
488 match bi with
489 | Built_ins.Exit _ ->
490 let v_ctx = Exit.value ctx in
491 if not v_ctx.subshell then begin
492 if (Exit.value ctx).interactive then
493 Fmt.pr "exit\n%!";
494 exit v_ctx (Exit.code ctx)
495 end
496 else handle_job job (`Exit (Exit.ignore ctx))
497 | _ -> handle_job job (`Built_in (Exit.ignore ctx))
498 in
499 loop (Exit.value ctx) job some_read rest))))
500 | CompoundCommand (c, rdrs) :: rest -> (
501 match handle_redirections ~sw:pipeline_switch ctx rdrs with
502 | Error ctx -> (ctx, handle_job job (`Rdr (Exit.nonzero () 1)))
503 | Ok rdrs ->
504 let saved_rdrs = ctx.rdrs in
505 let rdrs = make_child_rdrs_for_parent rdrs in
506 (* TODO: No way this is right *)
507 let ctx = { ctx with rdrs = rdrs @ saved_rdrs } in
508 let ctx = handle_compound_command ctx c in
509 let job = handle_job job (`Built_in (ctx >|= fun _ -> ())) in
510 let actual_ctx = Exit.value ctx in
511 loop { actual_ctx with rdrs = saved_rdrs } job None rest)
512 | FunctionDefinition (name, (body, _rdrs)) :: rest ->
513 let ctx = { ctx with functions = (name, body) :: ctx.functions } in
514 loop ctx job None rest
515 | [] -> (clear_local_state ctx, job)
516 in
517 Eio.Switch.run @@ fun sw ->
518 let initial_job = J.make 0 [] in
519 let saved_ctx = initial_ctx in
520 let subshell = saved_ctx.subshell || List.length p > 1 in
521 let ctx = { initial_ctx with subshell } in
522 let ctx, job = loop sw ctx initial_job None p in
523 match J.size job with
524 | 0 -> Exit.zero ctx
525 | _ ->
526 if not async then begin
527 let e =
528 J.await_exit ~pipefail:ctx.options.pipefail
529 ~interactive:ctx.interactive job
530 in
531 let ctx = { ctx with last_pipeline_status = Some (Exit.code e) } in
532 e >|= fun () -> { ctx with subshell = saved_ctx.subshell }
533 end
534 else begin
535 Exit.zero
536 {
537 ctx with
538 background_jobs = job :: ctx.background_jobs;
539 subshell = saved_ctx.subshell;
540 }
541 end
542
543 and handle_one_redirection ?(for_parent = false) ~sw ctx v =
544 let redirect (s, d, b) =
545 if for_parent then Types.Parent_redirect (s, d, b)
546 else Types.Child_redirect (s, d, b)
547 in
548 match v with
549 | Ast.IoRedirect_IoFile (n, (op, file)) -> (
550 let _ctx, file = word_expansion ctx file in
551 let file = Ast.Fragment.join_list ~sep:"" (List.concat file) in
552 match op with
553 | Io_op_less ->
554 (* Simple redirection for input *)
555 let r = Eio.Path.open_in ~sw (ctx.fs / file) in
556 let fd = Eio_unix.Resource.fd_opt r |> Option.get in
557 [ redirect (n, fd, `Blocking) ]
558 | Io_op_lessand -> (
559 match file with
560 | "-" ->
561 if n = 0 then [ Types.Close Eio_unix.Fd.stdin ]
562 else
563 let fd = fd_of_int ~sw n in
564 [ Types.Close fd ]
565 | m when Option.is_some (int_of_string_opt m) ->
566 let m = int_of_string m in
567 [ redirect (n, fd_of_int ~close_unix:false ~sw m, `Blocking) ]
568 | _ -> [])
569 | (Io_op_great | Io_op_dgreat) as v ->
570 (* Simple file creation *)
571 let append = v = Io_op_dgreat in
572 let create =
573 if append then `If_missing (file_creation_mode ctx)
574 else if ctx.options.noclobber then
575 `Exclusive (file_creation_mode ctx)
576 else `Or_truncate (file_creation_mode ctx)
577 in
578 Debug.Log.debug (fun f ->
579 f "Creating file (append:%b, %a): %s" append pp_fs_create create
580 file);
581 let w = Eio.Path.open_out ~sw ~append ~create (ctx.fs / file) in
582 let fd = Eio_unix.Resource.fd_opt w |> Option.get in
583 [ redirect (n, fd, `Blocking) ]
584 | Io_op_greatand -> (
585 match file with
586 | "-" ->
587 if n = 0 then [ Types.Close Eio_unix.Fd.stdout ]
588 else
589 let fd = fd_of_int ~sw n in
590 [ Types.Close fd ]
591 | m when Option.is_some (int_of_string_opt m) ->
592 let m = int_of_string m in
593 [ redirect (n, fd_of_int ~close_unix:false ~sw m, `Blocking) ]
594 | _ -> [])
595 | Io_op_andgreat ->
596 (* Yesh, not very POSIX *)
597 (* Simple file creation *)
598 let w =
599 Eio.Path.open_out ~sw
600 ~create:(`If_missing (file_creation_mode ctx))
601 (ctx.fs / file)
602 in
603 let fd = Eio_unix.Resource.fd_opt w |> Option.get in
604 [ redirect (1, fd, `Blocking); redirect (2, fd, `Blocking) ]
605 | Io_op_clobber ->
606 let w =
607 Eio.Path.open_out ~sw
608 ~create:(`Or_truncate (file_creation_mode ctx))
609 (ctx.fs / file)
610 in
611 let fd = Eio_unix.Resource.fd_opt w |> Option.get in
612 [ redirect (n, fd, `Blocking) ]
613 | Io_op_lessgreat -> Fmt.failwith "<> not support yet.")
614 | Ast.IoRedirect_IoHere (i, Ast.IoHere (_, v)) ->
615 let _ctx, cst = word_expansion ctx v in
616 let s = List.concat cst |> Ast.Fragment.join_list ~sep:"" in
617 let r, w = Fd_pool.pipe ctx.fd_pool sw in
618 Eio.Flow.copy_string s w;
619 Eio.Flow.close w;
620 let fd = Eio_unix.Resource.fd_opt r |> Option.get in
621 [ redirect (i, fd, `Blocking) ]
622 | Ast.IoRedirect_IoHere (i, Ast.IoHere_Dash (_, v)) ->
623 let _ctx, cst = word_expansion ctx v in
624 let strip_tab (Ast.{ txt; _ } as v) =
625 let txt =
626 String.split_on_char '\n' txt
627 |> List.map String.trim |> String.concat "\n"
628 in
629 { v with txt }
630 in
631 let s =
632 List.concat cst |> List.map strip_tab
633 |> Ast.Fragment.join_list ~sep:""
634 in
635 let r, w = Fd_pool.pipe ctx.fd_pool sw in
636 Eio.Flow.copy_string s w;
637 Eio.Flow.close w;
638 let fd = Eio_unix.Resource.fd_opt r |> Option.get in
639 [ redirect (i, fd, `Blocking) ]
640
641 and handle_redirections ?(for_parent = false) ~sw ctx rdrs =
642 try Ok (List.concat_map (handle_one_redirection ~for_parent ~sw ctx) rdrs)
643 with Eio.Io (Eio.Fs.E (Already_exists _), _) ->
644 Fmt.epr "msh: cannot overwrite existing file\n%!";
645 Error ctx
646
647 and parameter_expansion ctx ast : ctx Exit.t * Ast.fragment list list =
648 let get_prefix ~pattern ~kind param =
649 let _, prefix =
650 String.fold_left
651 (fun (so_far, acc) c ->
652 match acc with
653 | Some s when kind = `Smallest -> (so_far, Some s)
654 | _ -> (
655 let s = so_far ^ String.make 1 c in
656 match Glob.test ~pattern s with
657 | true -> (s, Some s)
658 | false -> (s, acc)))
659 ("", None) param
660 in
661 prefix
662 in
663 let get_suffix ~pattern ~kind param =
664 let _, prefix =
665 String.fold_left
666 (fun (so_far, acc) c ->
667 match acc with
668 | Some s when kind = `Smallest -> (so_far, Some s)
669 | _ -> (
670 let s = String.make 1 c ^ so_far in
671 match Glob.test ~pattern s with
672 | true -> (s, Some s)
673 | false -> (s, acc)))
674 ("", None)
675 (String.fold_left (fun acc c -> String.make 1 c ^ acc) "" param)
676 in
677 prefix
678 in
679 let tl_or_empty v = try List.tl v with _ -> [] in
680 let lookup_variable ctx ~param =
681 match int_of_string_opt param with
682 | Some n -> (
683 match Array.get ctx.argv n with
684 | v -> Some v
685 | exception Invalid_argument _ -> None)
686 | None -> S.lookup ctx.state ~param
687 in
688 let expand ctx v : ctx Exit.t * Ast.fragment list list =
689 let module Fragment = struct
690 include Ast.Fragment
691
692 let make ?(join = if ctx.in_double_quotes then `With_previous else `No)
693 ?globbable ?splittable ?tilde_expansion v =
694 Ast.Fragment.make ~join ?splittable ?tilde_expansion ?globbable v
695 end in
696 match v with
697 | Ast.WordVariable v -> (
698 match v with
699 | Ast.VariableAtom ("!", NoAttribute) ->
700 (Exit.zero ctx, [ [ Fragment.make ctx.last_background_process ] ])
701 | Ast.VariableAtom ("?", NoAttribute) ->
702 let status =
703 match ctx.last_pipeline_status with
704 | None -> []
705 | Some i -> [ Fragment.make (string_of_int i) ]
706 in
707 (Exit.zero ctx, [ status ])
708 | Ast.VariableAtom ("-", NoAttribute) ->
709 let i = if ctx.interactive then "i" else "" in
710 ( Exit.zero ctx,
711 [
712 [
713 Fragment.make (Built_ins.Options.to_letters ctx.options ^ i);
714 ];
715 ] )
716 | Ast.VariableAtom ("@", NoAttribute) ->
717 let args = tl_or_empty @@ Array.to_list ctx.argv in
718 Debug.Log.debug (fun f ->
719 f "expanding %@: %a\n%!" Fmt.(list string) args);
720 let args =
721 if not ctx.in_double_quotes then
722 List.map
723 (fun v -> [ Fragment.make ~join:`No ~splittable:true v ])
724 args
725 else
726 let l = List.length args in
727 List.mapi
728 (fun idx arg ->
729 if idx = 0 then [ Fragment.make ~join:`With_previous arg ]
730 else if idx = l - 1 then
731 [ Fragment.make ~join:`With_next arg ]
732 else [ Fragment.make ~join:`No arg ])
733 args
734 in
735 (Exit.zero ctx, args)
736 | Ast.VariableAtom ("*", NoAttribute) ->
737 let args = tl_or_empty @@ Array.to_list ctx.argv in
738 Debug.Log.debug (fun f ->
739 f "expanding *: %a\n%!" Fmt.(list string) args);
740 let args =
741 if not ctx.in_double_quotes then
742 [ List.map Ast.Fragment.make args ]
743 else
744 [
745 [
746 Ast.Fragment.make ~join:`With_previous
747 (String.concat
748 (Option.value ~default:" "
749 (S.lookup ctx.state ~param:"IFS"))
750 args);
751 ];
752 ]
753 in
754 (Exit.zero ctx, args)
755 | Ast.VariableAtom ("#", NoAttribute) ->
756 ( Exit.zero ctx,
757 [
758 [
759 Fragment.make
760 (string_of_int
761 (List.length @@ tl_or_empty (Array.to_list ctx.argv)));
762 ];
763 ] )
764 | Ast.VariableAtom (n, NoAttribute)
765 when Option.is_some (int_of_string_opt n) -> (
766 let n = int_of_string n in
767 match Array.get ctx.argv n with
768 | v -> (Exit.zero ctx, [ [ Fragment.make v ] ])
769 | exception Invalid_argument _ ->
770 (Exit.zero ctx, [ [ Fragment.make "" ] ]))
771 | Ast.VariableAtom (s, NoAttribute) -> (
772 match lookup_variable ctx ~param:s with
773 | None ->
774 if ctx.options.no_unset then begin
775 ( Exit.nonzero_msg ctx ~exit_code:1 "%s: unbound variable" s,
776 [ [ Fragment.make "" ] ] )
777 end
778 else (Exit.zero ctx, [ [ Fragment.make "" ] ])
779 | Some cst ->
780 ( Exit.zero ctx,
781 [
782 [
783 Fragment.make ~splittable:(not ctx.in_double_quotes) cst;
784 ];
785 ] ))
786 | Ast.VariableAtom (s, ParameterLength) -> (
787 match lookup_variable ctx ~param:s with
788 | None -> (Exit.zero ctx, [ [ Fragment.make "0" ] ])
789 | Some cst ->
790 ( Exit.zero ctx,
791 [ [ Fragment.make (string_of_int (String.length cst)) ] ] ))
792 | Ast.VariableAtom (s, UseDefaultValues (_, cst)) -> (
793 match lookup_variable ctx ~param:s with
794 | None ->
795 (Exit.zero ctx, [ [ Fragment.make (word_cst_to_string cst) ] ])
796 | Some cst -> (Exit.zero ctx, [ [ Fragment.make cst ] ]))
797 | Ast.VariableAtom
798 ( s,
799 (( RemoveSmallestPrefixPattern cst
800 | RemoveLargestPrefixPattern cst ) as v) ) -> (
801 let ctx, spp = word_expansion ctx cst in
802 match ctx with
803 | Exit.Nonzero _ as ctx -> (ctx, [ [ Fragment.make "" ] ])
804 | Exit.Zero ctx -> (
805 let pattern = Fragment.join_list ~sep:"" (List.concat spp) in
806 match lookup_variable ctx ~param:s with
807 | None ->
808 ( Exit.zero ctx,
809 [ [ Fragment.make (word_cst_to_string cst) ] ] )
810 | Some cst -> (
811 let kind =
812 match v with
813 | RemoveSmallestPrefixPattern _ -> `Smallest
814 | RemoveLargestPrefixPattern _ -> `Largest
815 | _ -> assert false
816 in
817 let param = cst in
818 let prefix = get_prefix ~pattern ~kind param in
819 match prefix with
820 | None -> (Exit.zero ctx, [ [ Fragment.make param ] ])
821 | Some s -> (
822 match String.cut_prefix ~prefix:s param with
823 | Some s -> (Exit.zero ctx, [ [ Fragment.make s ] ])
824 | None -> (Exit.zero ctx, [ [ Fragment.make param ] ])
825 ))))
826 | Ast.VariableAtom
827 ( s,
828 (( RemoveSmallestSuffixPattern cst
829 | RemoveLargestSuffixPattern cst ) as v) ) -> (
830 let ctx, spp = word_expansion ctx cst in
831 let pattern = Fragment.join_list ~sep:"" (List.concat spp) in
832 match ctx with
833 | Exit.Nonzero _ as ctx -> (ctx, [ [ Fragment.empty ] ])
834 | Exit.Zero ctx -> (
835 match lookup_variable ctx ~param:s with
836 | None ->
837 ( Exit.zero ctx,
838 [ [ Fragment.make (word_cst_to_string cst) ] ] )
839 | Some cst -> (
840 let kind =
841 match v with
842 | RemoveSmallestSuffixPattern _ -> `Smallest
843 | RemoveLargestSuffixPattern _ -> `Largest
844 | _ -> assert false
845 in
846 let param = cst in
847 let suffix = get_suffix ~pattern ~kind param in
848 match suffix with
849 | None -> (Exit.zero ctx, [ [ Fragment.make param ] ])
850 | Some s -> (
851 match String.cut_suffix ~suffix:s param with
852 | Some s -> (Exit.zero ctx, [ [ Fragment.make s ] ])
853 | None -> (Exit.zero ctx, [ [ Fragment.make param ] ])
854 ))))
855 | Ast.VariableAtom (s, UseAlternativeValue (_, alt)) -> (
856 let ctx, alt = word_expansion ctx alt in
857 match lookup_variable (Exit.value ctx) ~param:s with
858 | Some "" | None -> (ctx, [ [] ])
859 | Some _ -> (ctx, alt))
860 | Ast.VariableAtom (s, AssignDefaultValues (_, value)) -> (
861 let new_ctx, value = word_expansion ctx value in
862 match lookup_variable (Exit.value new_ctx) ~param:s with
863 | Some "" | None -> (
864 match
865 S.update ctx.state ~param:s
866 (List.concat value |> Ast.Fragment.join_list ~sep:"")
867 with
868 | Ok state ->
869 let new_ctx = { (Exit.value new_ctx) with state } in
870 (Exit.zero new_ctx, value)
871 | Error m -> (Exit.nonzero_msg ~exit_code:1 ctx "%s" m, [ [] ])
872 )
873 | Some cst -> (new_ctx, [ [ Fragment.make cst ] ]))
874 | Ast.VariableAtom (_, IndicateErrorifNullorUnset (_, _)) ->
875 Fmt.failwith "TODO: Indicate Error")
876 | Ast.WordDoubleQuoted [] -> (Exit.zero ctx, [ [ Ast.Fragment.empty ] ])
877 | Ast.WordDoubleQuoted cst -> (
878 let saved_dqoute = ctx.in_double_quotes in
879 let ctx = { ctx with in_double_quotes = true } in
880 let new_ctx, cst_acc = word_expansion ctx cst in
881 let new_ctx =
882 Exit.map
883 ~f:(fun ctx -> { ctx with in_double_quotes = saved_dqoute })
884 new_ctx
885 in
886 match new_ctx with
887 | Exit.Nonzero _ -> (new_ctx, cst_acc)
888 | Exit.Zero new_ctx -> (Exit.zero new_ctx, cst_acc))
889 | Ast.WordSingleQuoted [] -> (Exit.zero ctx, [ [ Ast.Fragment.empty ] ])
890 | Ast.WordSingleQuoted cst -> (
891 let saved_dqoute = ctx.in_double_quotes in
892 let new_ctx, cst_acc = word_expansion ctx cst in
893 let new_ctx =
894 Exit.map
895 ~f:(fun ctx -> { ctx with in_double_quotes = saved_dqoute })
896 new_ctx
897 in
898 match new_ctx with
899 | Exit.Nonzero _ -> (new_ctx, cst_acc)
900 | Exit.Zero new_ctx -> (Exit.zero new_ctx, cst_acc))
901 | Ast.WordAssignmentWord (Name n, w) -> (
902 let new_ctx, cst_acc = word_expansion ctx w in
903 match new_ctx with
904 | Exit.Nonzero _ -> (new_ctx, cst_acc)
905 | Exit.Zero _ ->
906 ( new_ctx,
907 [
908 [
909 Fragment.make
910 (n ^ "="
911 ^ Fragment.join_list ~sep:"" (List.concat cst_acc));
912 ];
913 ] ))
914 | Ast.WordSubshell sub ->
915 (* Command substitution *)
916 let s = command_substitution ctx sub in
917 (Exit.zero ctx, [ [ Fragment.make s ] ])
918 | Ast.WordArithmeticExpression cst ->
919 arithmetic_expansion ctx cst |> fun (ctx, v) ->
920 (Exit.zero ctx, [ [ v ] ])
921 | Ast.WordName s -> (Exit.zero ctx, [ [ Fragment.make s ] ])
922 | Ast.WordLiteral s ->
923 let v = Fragment.make s in
924 (Exit.zero ctx, [ [ v ] ])
925 | Ast.WordGlobAll ->
926 (Exit.zero ctx, [ [ Fragment.make ~globbable:true "*" ] ])
927 | Ast.WordGlobAny ->
928 (Exit.zero ctx, [ [ Fragment.make ~globbable:true "?" ] ])
929 | Ast.WordTildePrefix s ->
930 (Exit.zero ctx, [ [ Fragment.make ~tilde_expansion:true s ] ])
931 | v ->
932 Fmt.failwith "TODO: expansion of %a" yojson_pp
933 (Ast.word_component_to_yojson v)
934 in
935 expand ctx ast
936
937 and split_fields ifs s =
938 let v, ls =
939 String.fold_left
940 (fun (so_far, ls) c ->
941 if String.contains ifs c then ("", so_far :: ls)
942 else (so_far ^ String.make 1 c, ls))
943 ("", []) s
944 in
945 List.rev (v :: ls)
946
947 and field_splitting ctx = function
948 | [] -> []
949 | Ast.{ splittable = true; txt; globbable; _ } :: rest -> (
950 match S.lookup ctx.state ~param:"IFS" with
951 | Some "" -> [ Ast.Fragment.make ~globbable txt ]
952 | (None | Some _) as ifs ->
953 let ifs = Option.value ~default:" \t\n" ifs in
954 (split_fields ifs txt |> List.map (Ast.Fragment.make ~globbable))
955 @ field_splitting ctx rest)
956 | txt :: rest -> txt :: field_splitting ctx rest
957
958 and word_expansion' ctx cst : ctx Exit.t * Ast.fragments list =
959 let cst = tilde_expansion ctx cst in
960 parameter_expansion ctx cst
961
962 and word_expansion ctx cst : ctx Exit.t * Ast.fragments list =
963 let rec aux ctx = function
964 | [] -> (ctx, []) (* one empty word *)
965 | c :: rest ->
966 let new_ctx, l = word_expansion' (Exit.value ctx) c in
967 let next_ctx, r = aux new_ctx rest in
968 let combined = l @ r in
969 (next_ctx, combined)
970 in
971 let ctx, cst = aux (Exit.zero ctx) cst in
972 match ctx with
973 | Exit.Nonzero _ -> (ctx, cst)
974 | Exit.Zero ctx ->
975 let fields = cst in
976 let fields = List.map (field_splitting ctx) fields in
977 let (ctx, cst) : ctx * Ast.fragments list =
978 begin
979 let glob = Ast.Fragment.join_list ~sep:"" (List.concat fields) in
980 let vs : Ast.fragments list =
981 let has_glob =
982 List.exists
983 (fun (f : Ast.fragment) -> f.globbable)
984 (List.concat fields)
985 in
986 let _new_ctx, s =
987 if (not ctx.options.no_path_expansion) && has_glob then
988 glob_expand ctx glob
989 else if ctx.options.no_path_expansion && has_glob then
990 (ctx, [ Ast.Fragment.make glob ])
991 else (ctx, List.concat fields)
992 in
993 [ s ]
994 in
995 (ctx, vs)
996 end
997 in
998 (Exit.zero ctx, List.map Ast.Fragment.handle_joins cst)
999
1000 and handle_assignments kind ctx (assignments : string list) =
1001 let flags, assignments =
1002 List.fold_left
1003 (fun (fs, args) v ->
1004 match Astring.String.cut ~sep:"-" v with
1005 | Some ("", f) -> (f :: fs, args)
1006 | _ -> (fs, v :: args))
1007 ([], []) assignments
1008 in
1009 let update =
1010 match kind with
1011 | `Export -> update ~export:true ~readonly:false
1012 | `Readonly -> update ~export:false ~readonly:true
1013 | `Local -> update ~export:false ~readonly:false
1014 in
1015 let read_arg acc_ctx param =
1016 (* TODO: quoting? *)
1017 match Astring.String.cut ~sep:"=" param with
1018 | Some (param, v) -> update acc_ctx ~param v
1019 | None -> (
1020 match S.lookup acc_ctx.state ~param with
1021 | Some v -> update acc_ctx ~param v
1022 | None -> Exit.zero acc_ctx)
1023 in
1024 match flags with
1025 | [] ->
1026 List.fold_left
1027 (fun ctx w ->
1028 match ctx with Exit.Zero ctx -> read_arg ctx w | _ -> ctx)
1029 (Exit.zero ctx) assignments
1030 | fs ->
1031 if List.mem "p" fs then begin
1032 match kind with
1033 | `Readonly -> S.pp_readonly Fmt.stdout ctx.state
1034 | `Export -> S.pp_export Fmt.stdout ctx.state
1035 | `Local -> ()
1036 end;
1037 Exit.zero ctx
1038
1039 and expand_redirects ((ctx, acc) : ctx * Ast.cmd_suffix_item list)
1040 (c : Ast.cmd_suffix_item list) =
1041 match c with
1042 | [] -> (ctx, List.rev acc)
1043 | Ast.Suffix_redirect (IoRedirect_IoFile (num, (op, file))) :: rest -> (
1044 let ctx, cst = word_expansion ctx file in
1045 match ctx with
1046 | Exit.Nonzero _ -> Fmt.failwith "Redirect expansion"
1047 | Exit.Zero ctx ->
1048 let cst =
1049 List.map
1050 (fun Ast.{ txt; _ } -> Ast.WordLiteral txt)
1051 (List.concat cst)
1052 in
1053 let v = Ast.Suffix_redirect (IoRedirect_IoFile (num, (op, cst))) in
1054 expand_redirects (ctx, v :: acc) rest)
1055 | (Ast.Suffix_redirect _ as v) :: rest ->
1056 expand_redirects (ctx, v :: acc) rest
1057 | s :: rest -> expand_redirects (ctx, s :: acc) rest
1058
1059 and handle_and_or ~sw:_ ~async ctx c =
1060 let pipeline = function
1061 | Ast.Pipeline p -> (Fun.id, p)
1062 | Ast.Pipeline_Bang p -> (Exit.not, p)
1063 in
1064
1065 let rec fold :
1066 Ast.and_or * ctx Exit.t -> Ast.pipeline Ast.and_or_list -> ctx Exit.t =
1067 fun (sep, exit_so_far) pipe ->
1068 match (sep, pipe) with
1069 | And, Nlist.Singleton (p, _) -> (
1070 match exit_so_far with
1071 | Exit.Zero ctx ->
1072 let f, p = pipeline p in
1073 f @@ handle_pipeline ~async ctx p
1074 | v -> v)
1075 | Or, Nlist.Singleton (p, _) -> (
1076 match exit_so_far with
1077 | Exit.Zero _ as ctx -> ctx
1078 | _ ->
1079 let f, p = pipeline p in
1080 f @@ handle_pipeline ~async ctx p)
1081 | Noand_or, Nlist.Singleton (p, _) ->
1082 let f, p = pipeline p in
1083 f @@ handle_pipeline ~async ctx p
1084 | Noand_or, Nlist.Cons ((p, next_sep), rest) ->
1085 let f, p = pipeline p in
1086 let exit_status = f (handle_pipeline ~async ctx p) in
1087 fold (next_sep, exit_status) rest
1088 | And, Nlist.Cons ((p, next_sep), rest) -> (
1089 match exit_so_far with
1090 | Exit.Zero ctx ->
1091 let f, p = pipeline p in
1092 fold (next_sep, f (handle_pipeline ~async ctx p)) rest
1093 | Exit.Nonzero _ as v -> v)
1094 | Or, Nlist.Cons ((p, next_sep), rest) -> (
1095 match exit_so_far with
1096 | Exit.Zero _ as exit_so_far -> fold (next_sep, exit_so_far) rest
1097 | Exit.Nonzero _ ->
1098 let f, p = pipeline p in
1099 fold (next_sep, f (handle_pipeline ~async ctx p)) rest)
1100 in
1101 fold (Noand_or, Exit.zero ctx) c
1102
1103 and handle_for_clause ctx v : ctx Exit.t =
1104 match v with
1105 | Ast.For_Name_DoGroup (_, (term, sep)) -> exec ctx (term, Some sep)
1106 | Ast.For_Name_In_WordList_DoGroup (Name name, wdlist, (term, sep)) -> (
1107 let wdlist = Nlist.map (word_expansion ctx) wdlist in
1108 try
1109 Nlist.fold_left
1110 (fun _ (_, words) ->
1111 List.fold_left
1112 (fun _ word ->
1113 update ctx ~param:name word.Ast.txt >>= fun ctx ->
1114 try exec ctx (term, Some sep) with
1115 | Continue (1, ctx) -> Exit.zero ctx
1116 | Continue (n, ctx) -> raise (Continue (n - 1, ctx)))
1117 (Exit.zero ctx) (List.concat words))
1118 (Exit.zero ctx) wdlist
1119 with
1120 | Break (1, ctx) -> Exit.zero ctx
1121 | Break (n, ctx) -> raise (Break (n - 1, ctx)))
1122
1123 and handle_if_clause ctx = function
1124 | Ast.If_then ((e1, sep1), (e2, sep2)) -> (
1125 let ctx = exec ctx (e1, Some sep1) in
1126 match ctx with
1127 | Exit.Zero ctx -> exec ctx (e2, Some sep2)
1128 | Exit.Nonzero { value = ctx; _ } -> Exit.zero ctx)
1129 | Ast.If_then_else ((e1, sep1), (e2, sep2), else_part) -> (
1130 let ctx = exec ctx (e1, Some sep1) in
1131 match ctx with
1132 | Exit.Zero ctx -> exec ctx (e2, Some sep2)
1133 | Exit.Nonzero { value = ctx; _ } -> handle_else_part ctx else_part)
1134
1135 and handle_else_part ctx = function
1136 | Ast.Else (c, sep) -> exec ctx (c, Some sep)
1137 | Ast.Elif_then ((e1, sep1), (e2, sep2)) -> (
1138 let ctx = exec ctx (e1, Some sep1) in
1139 match ctx with
1140 | Exit.Zero ctx -> exec ctx (e2, Some sep2)
1141 | Exit.Nonzero { value = ctx; _ } -> Exit.zero ctx)
1142 | Ast.Elif_then_else ((e1, sep1), (e2, sep2), else_part) -> (
1143 let ctx = exec ctx (e1, Some sep1) in
1144 match ctx with
1145 | Exit.Zero ctx -> exec ctx (e2, Some sep2)
1146 | Exit.Nonzero { value = ctx; _ } -> handle_else_part ctx else_part)
1147
1148 and handle_case_clause ctx = function
1149 | Ast.Case _ -> Exit.zero ctx
1150 | Cases (word, case_list) -> (
1151 let ctx, word = word_expansion ctx word in
1152 match ctx with
1153 | Exit.Nonzero _ as ctx -> ctx
1154 | Exit.Zero ctx -> (
1155 let scrutinee =
1156 Ast.Fragment.join_list ~sep:"" @@ List.concat word
1157 in
1158 let res =
1159 Nlist.fold_left
1160 (fun acc pat ->
1161 match acc with
1162 | Some _ as ctx -> ctx
1163 | None -> (
1164 match pat with
1165 | Ast.Case_pattern (p, sub) ->
1166 Nlist.fold_left
1167 (fun inner_acc pattern ->
1168 match inner_acc with
1169 | Some _ as v -> v
1170 | None ->
1171 let _, pattern =
1172 word_expansion
1173 {
1174 ctx with
1175 options =
1176 Built_ins.Options.with_options
1177 ~no_path_expansion:true ctx.options;
1178 }
1179 pattern
1180 in
1181 let pattern =
1182 Ast.Fragment.join_list ~sep:""
1183 (List.concat pattern)
1184 in
1185 if Glob.test ~pattern scrutinee then begin
1186 match sub with
1187 | Some (c, sep) ->
1188 Some (exec ctx (c, Some sep))
1189 | None -> Some (Exit.zero ctx)
1190 end
1191 else inner_acc)
1192 None p))
1193 None case_list
1194 in
1195 match res with Some ctx -> ctx | None -> Exit.zero ctx))
1196
1197 and exec_subshell ctx (term, sep) =
1198 let saved_ctx = ctx in
1199 let e = exec ctx (term, Some sep) in
1200 let v = e >|= fun _ -> saved_ctx in
1201 v
1202
1203 and handle_while_clause ctx
1204 (While ((term, sep), (term', sep')) : Ast.while_clause) =
1205 let rec loop exit_so_far =
1206 let running_ctx = Exit.value exit_so_far in
1207 match exec running_ctx (term, Some sep) with
1208 | Exit.Nonzero _ -> exit_so_far (* TODO: Context? *)
1209 | Exit.Zero ctx ->
1210 loop
1211 (try exec ctx (term', Some sep') with
1212 | Continue (1, ctx) -> Exit.zero ctx
1213 | Continue (n, ctx) -> raise (Continue (n - 1, ctx)))
1214 in
1215 try loop (Exit.zero ctx) with
1216 | Break (1, ctx) -> Exit.zero ctx
1217 | Break (n, ctx) -> raise (Break (n - 1, ctx))
1218
1219 and handle_until_clause ctx
1220 (Until ((term, sep), (term', sep')) : Ast.until_clause) =
1221 let rec loop exit_so_far =
1222 let running_ctx = Exit.value exit_so_far in
1223 match exec running_ctx (term, Some sep) with
1224 | Exit.Zero _ -> exit_so_far (* TODO: Context? *)
1225 | Exit.Nonzero { value = ctx; _ } ->
1226 loop
1227 (try exec ctx (term', Some sep') with
1228 | Continue (1, ctx) -> Exit.zero ctx
1229 | Continue (n, ctx) -> raise (Continue (n - 1, ctx)))
1230 in
1231 try loop (Exit.zero ctx) with
1232 | Break (1, ctx) -> Exit.zero ctx
1233 | Break (n, ctx) -> raise (Break (n - 1, ctx))
1234
1235 and handle_compound_command ctx v : ctx Exit.t =
1236 match v with
1237 | Ast.ForClause fc -> handle_for_clause ctx fc
1238 | Ast.IfClause if_ -> handle_if_clause ctx if_
1239 | Ast.BraceGroup (term, sep) -> exec ctx (term, Some sep)
1240 | Ast.Subshell s -> exec_subshell ctx s
1241 | Ast.CaseClause cases -> handle_case_clause ctx cases
1242 | Ast.WhileClause while_ -> handle_while_clause ctx while_
1243 | Ast.UntilClause until -> handle_until_clause ctx until
1244
1245 and handle_function_application (ctx : ctx) ~name argv : ctx Exit.t option =
1246 match List.assoc_opt name ctx.functions with
1247 | None -> None
1248 | Some commands ->
1249 Debug.Log.debug (fun f ->
1250 f "function enter: %s [%a]" name
1251 Fmt.(list ~sep:Fmt.(any " ") string)
1252 argv);
1253 let ctx = { ctx with argv = Array.of_list argv } in
1254 let v =
1255 try Option.some @@ handle_compound_command ctx commands
1256 with Return ctx -> Some ctx
1257 in
1258 Debug.Log.debug (fun f -> f "function leave: %s" name);
1259 v
1260
1261 and command_substitution (ctx : ctx) (cc : Ast.complete_commands) =
1262 let exec_subshell ctx s =
1263 let buf = Buffer.create 16 in
1264 let stdout = Eio.Flow.buffer_sink buf in
1265 let sub_ctx =
1266 Eio.Switch.run @@ fun sw ->
1267 let r, w = Fd_pool.pipe ctx.fd_pool sw in
1268 Eio.Fiber.fork ~sw (fun () -> Eio.Flow.copy r stdout);
1269 let subshell_ctx = { ctx with stdout = w; subshell = true } in
1270 let sub_ctx, _ = run (Exit.zero subshell_ctx) s in
1271 Eio.Flow.close w;
1272 sub_ctx
1273 in
1274 ((sub_ctx >|= fun _ -> ctx), Buffer.contents buf)
1275 in
1276 let run_subshells s =
1277 let _ctx, std = exec_subshell ctx s in
1278 String.trim std
1279 in
1280 run_subshells cc
1281
1282 and glob_expand ctx pattern : ctx * Ast.fragment list =
1283 ( ctx,
1284 match Glob.glob_dir pattern with
1285 | [] ->
1286 Debug.Log.debug (fun f -> f "Glob %s returned nothing" pattern);
1287 [ Ast.Fragment.make pattern ]
1288 | exception e ->
1289 Debug.Log.debug (fun f ->
1290 f "Glob expand exception: %s" (Printexc.to_string e));
1291 [ Ast.Fragment.make pattern ]
1292 | xs ->
1293 Debug.Log.debug (fun f ->
1294 f "Globbed %s to [%a]" pattern Fmt.(list (quote string)) xs);
1295 List.map Ast.Fragment.make xs )
1296
1297 and collect_assignments ?(update = true) ctx vs : ctx Exit.t =
1298 List.fold_left
1299 (fun ctx prefix ->
1300 match ctx with
1301 | Exit.Nonzero _ -> ctx
1302 | Exit.Zero ctx -> (
1303 match prefix with
1304 | Ast.Prefix_assignment (Name param, v) -> (
1305 (* Expand the values *)
1306 let ctx, v = word_expansion ctx v in
1307 match ctx with
1308 | Exit.Nonzero _ as ctx -> ctx
1309 | Exit.Zero ctx -> (
1310 let state =
1311 (* TODO: Overhaul... need to collect assignments after word expansion...*)
1312 if update || String.equal "IFS" param then
1313 S.update ctx.state ~param
1314 (Ast.Fragment.join_list ~sep:"" @@ List.concat v)
1315 else Ok ctx.state
1316 in
1317 match state with
1318 | Error message -> Exit.nonzero ~message ctx 1
1319 | Ok state ->
1320 Exit.zero
1321 {
1322 ctx with
1323 state;
1324 local_state =
1325 ( param,
1326 Ast.Fragment.join_list ~sep:"" @@ List.concat v
1327 )
1328 :: ctx.local_state;
1329 }))
1330 | _ -> Exit.zero ctx))
1331 (Exit.zero ctx) vs
1332
1333 and args ctx swc : ctx Exit.t * string list =
1334 let ctx, fs =
1335 List.fold_left
1336 (fun (ctx, acc) -> function
1337 | Ast.Suffix_redirect _ -> (ctx, acc)
1338 | Suffix_word wc -> (
1339 match ctx with
1340 | Exit.Nonzero _ as ctx -> (ctx, acc)
1341 | Exit.Zero ctx -> (
1342 let ctx, cst = word_expansion ctx wc in
1343 match ctx with
1344 | Exit.Nonzero _ as ctx -> (ctx, acc)
1345 | Exit.Zero _ as ctx -> (ctx, acc @ cst))))
1346 (Exit.zero ctx, [])
1347 swc
1348 in
1349 (ctx, List.map Ast.Fragment.to_string @@ List.concat fs)
1350
1351 and handle_built_in ~rdrs ~(stdout : Eio_unix.sink_ty Eio.Flow.sink)
1352 (ctx : ctx) v =
1353 let rdrs = ctx.rdrs @ rdrs in
1354 Eunix.with_redirections ~restore:true rdrs @@ fun () ->
1355 Debug.Log.debug (fun f -> f "built-in: %s" (Built_ins.to_string v));
1356 match v with
1357 | Built_ins.Cd { path } ->
1358 let cwd = S.cwd ctx.state in
1359 let+ state =
1360 match path with
1361 | Some p ->
1362 let fp = Fpath.append cwd (Fpath.v p) in
1363 if Eio.Path.is_directory (ctx.fs / Fpath.to_string fp) then begin
1364 Unix.chdir (Fpath.to_string fp);
1365 Exit.zero @@ S.set_cwd ctx.state fp
1366 end
1367 else
1368 Exit.nonzero_msg ~exit_code:1 ctx.state
1369 "cd: not a directory: %a" Fpath.pp fp
1370 | None -> (
1371 match Eunix.find_env "HOME" with
1372 | None -> Exit.nonzero_msg ctx.state "HOME not set"
1373 | Some p -> Exit.zero (S.set_cwd ctx.state @@ Fpath.v p))
1374 in
1375 { ctx with state }
1376 | Pwd ->
1377 let () =
1378 Eio.Flow.copy_string
1379 (Fmt.str "%a\n%!" Fpath.pp (S.cwd ctx.state))
1380 stdout
1381 in
1382 Exit.zero ctx
1383 | Exit n ->
1384 let should_exit =
1385 { Exit.default_should_exit with interactive = `Yes }
1386 in
1387 Exit.nonzero ~should_exit ctx n
1388 | Return 0 -> raise (Return (Exit.zero ctx))
1389 | Return n -> raise (Return (Exit.nonzero ctx n))
1390 | Break n -> raise (Break (n, ctx))
1391 | Continue n -> raise (Continue (n, ctx))
1392 | Set { update; print_options } ->
1393 let v =
1394 Exit.zero
1395 { ctx with options = Built_ins.Options.update ctx.options update }
1396 in
1397 if print_options then
1398 Eio.Flow.copy_string
1399 (Fmt.str "%a" Built_ins.Options.pp ctx.options)
1400 stdout;
1401 v
1402 | Wait i -> (
1403 match Unix.waitpid [] i with
1404 | _, WEXITED 0 -> Exit.zero ctx
1405 | _, (WEXITED n | WSIGNALED n | WSTOPPED n) -> Exit.nonzero ctx n)
1406 | Dot file -> (
1407 match resolve_program ctx file with
1408 | ctx, None -> Exit.nonzero ctx 127
1409 | ctx, Some fname ->
1410 Debug.Log.debug (fun f -> f "sourcing...");
1411 let program = Ast.of_file (ctx.fs / fname) in
1412 let ctx, _ =
1413 run' ~make_process_group:false (Exit.zero ctx) program
1414 in
1415 Debug.Log.debug (fun f -> f "finished sourcing %s" fname);
1416 ctx)
1417 | Unset names -> (
1418 match names with
1419 | `Variables names ->
1420 let state =
1421 List.fold_left
1422 (fun t param -> S.remove ~param t |> snd)
1423 ctx.state names
1424 in
1425 Exit.zero { ctx with state }
1426 | `Functions names ->
1427 let functions =
1428 List.fold_left
1429 (fun t param -> List.remove_assoc param t)
1430 ctx.functions names
1431 in
1432 Exit.zero { ctx with functions })
1433 | Hash v -> (
1434 match v with
1435 | Built_ins.Hash_remove -> Exit.zero { ctx with hash = Hash.empty }
1436 | Built_ins.Hash_stats ->
1437 Eio.Flow.copy_string (Fmt.str "%a" Hash.pp ctx.hash) stdout;
1438 Exit.zero ctx
1439 | _ -> assert false)
1440 | Alias | Unalias -> Exit.zero ctx (* Morbig handles this for us *)
1441 | Eval args ->
1442 let script = String.concat "" args in
1443 let ast = Ast.of_string script in
1444 let ctx, _ = run (Exit.zero ctx) ast in
1445 ctx
1446 | Echo args ->
1447 let str = String.concat " " (List.map String.trim args) ^ "\n" in
1448 Eio.Flow.copy_string str stdout;
1449 Exit.zero ctx
1450 | Trap (action, signals) ->
1451 let saved_ctx = ctx in
1452 let action =
1453 match action with
1454 | Action m ->
1455 let ast = Ast.of_string m in
1456 let f _ =
1457 saved_ctx.signal_handler.run @@ fun () ->
1458 let _, _ = run (Exit.zero saved_ctx) ast in
1459 ()
1460 in
1461 Sys.Signal_handle f
1462 | Default -> Sys.Signal_default
1463 | Ignore -> Sys.Signal_ignore
1464 | Int _ -> assert false
1465 in
1466 Exit.zero
1467 @@ List.fold_left
1468 (fun ctx signal ->
1469 match signal with
1470 | `Exit ->
1471 let action =
1472 match action with
1473 | Sys.Signal_default | Sys.Signal_ignore -> None
1474 | Sys.Signal_handle f -> Some (fun () -> f 0)
1475 in
1476 { ctx with exit_handler = action }
1477 | `Signal signal ->
1478 let action =
1479 (* Handle sigint separately for interactive mode *)
1480 match (action, signal) with
1481 | Sys.Signal_default, Eunix.Signals.Interrupt ->
1482 if ctx.interactive then Sys.Signal_ignore else action
1483 | _ -> action
1484 in
1485 let setting_sigint =
1486 ctx.signal_handler.sigint_set = false
1487 &&
1488 match action with
1489 | Sys.Signal_handle _ -> true
1490 | _ -> false
1491 in
1492 Sys.set_signal (Eunix.Signals.to_int signal) action;
1493 {
1494 ctx with
1495 signal_handler =
1496 { ctx.signal_handler with sigint_set = setting_sigint };
1497 })
1498 ctx signals
1499 | Umask None ->
1500 let str = Fmt.str "0%o\n" ctx.umask in
1501 Eio.Flow.copy_string str stdout;
1502 Exit.zero ctx
1503 | Umask (Some i) -> Exit.zero { ctx with umask = i }
1504 | Shift n ->
1505 let n = Option.value ~default:1 n in
1506 let new_len = Array.length ctx.argv - n in
1507 assert (new_len >= 0);
1508 let argv = Array.init new_len (fun i -> Array.get ctx.argv (i + n)) in
1509 Exit.zero { ctx with argv }
1510 | Read (_backslash, vars) -> (
1511 let line =
1512 let buf = Cstruct.create 1 in
1513 let rec loop acc =
1514 match
1515 Eio.Flow.read_exact ctx.stdin buf;
1516 Cstruct.to_string buf
1517 with
1518 | "\n" -> Some acc
1519 | c -> loop (acc ^ c)
1520 | exception End_of_file ->
1521 Debug.Log.debug (fun f -> f "Read EOF");
1522 if String.equal acc "" then None else Some acc
1523 in
1524 loop ""
1525 in
1526 let rec loop acc = function
1527 | v :: vars, Ast.{ txt; _ } :: fs -> loop ((v, txt) :: acc) (vars, fs)
1528 | _, [] -> List.rev acc
1529 | [], lines ->
1530 let last_var, last_line = List.hd acc in
1531 List.rev
1532 ((last_var, last_line ^ Ast.Fragment.join_list ~sep:"" lines)
1533 :: acc)
1534 in
1535 let fields =
1536 Option.map
1537 (fun s ->
1538 field_splitting ctx [ Ast.Fragment.make ~splittable:true s ])
1539 line
1540 in
1541 match fields with
1542 | None -> Exit.nonzero ctx 1
1543 | Some fs ->
1544 let vars = loop [] (vars, fs) in
1545 let state =
1546 List.fold_left
1547 (fun st (k, v) -> S.update st ~param:k v |> Result.get_ok)
1548 ctx.state vars
1549 in
1550 Exit.zero { ctx with state })
1551 | Command _ ->
1552 (* Handled separately *)
1553 assert false
1554
1555 and exec initial_ctx ((command, sep) : Ast.complete_command) =
1556 let rec loop : Eio.Switch.t -> ctx -> Ast.clist -> ctx Exit.t =
1557 fun sw ctx -> function
1558 | Nlist.Singleton (c, sep) ->
1559 let async =
1560 match sep with Semicolon -> false | Ampersand -> true
1561 in
1562 handle_and_or ~sw ~async ctx c
1563 | Nlist.Cons ((c, sep), cs) -> (
1564 let async =
1565 match sep with Semicolon -> false | Ampersand -> true
1566 in
1567 match handle_and_or ~sw ~async ctx c with
1568 | Exit.Zero ctx -> loop sw ctx cs
1569 | v -> v)
1570 in
1571 match sep with
1572 | Some Semicolon | None ->
1573 Eio.Switch.run @@ fun sw -> loop sw initial_ctx command
1574 | Some Ampersand ->
1575 Fiber.fork ~sw:initial_ctx.async_switch (fun () ->
1576 Fiber.yield ();
1577 let _ : ctx Exit.t =
1578 loop initial_ctx.async_switch initial_ctx command
1579 in
1580 ());
1581 Exit.zero initial_ctx
1582
1583 and execute ctx ast = exec ctx ast
1584 and run ctx ast = run' ~make_process_group:true ctx ast
1585
1586 and run' ?(make_process_group = true) ctx ast =
1587 (* Make the shell its own process group *)
1588 if make_process_group then Eunix.make_process_group ();
1589 let ctx, cs =
1590 let rec loop_commands (ctx, cs) (c : Ast.complete_commands) =
1591 match c with
1592 | [] -> (ctx, cs)
1593 | command :: commands -> (
1594 let ctx = Exit.value ctx in
1595 (* For our sanity *)
1596 let has_async = Ast.has_async command in
1597 if has_async && not ctx.options.async then begin
1598 Fmt.epr
1599 "You are using asynchronous operators and [set -o async] has \
1600 not been called.\n\
1601 %!";
1602 exit ctx 1
1603 end;
1604 let exit =
1605 try execute ctx command
1606 with
1607 | Eio.Io (Eio.Process.E (Eio.Process.Executable_not_found m), _ctx)
1608 ->
1609 Exit.nonzero_msg ctx ~exit_code:127 "command not found: %s" m
1610 in
1611 match exit with
1612 | Exit.Nonzero { exit_code; message; should_exit; _ } -> (
1613 Option.iter (Fmt.epr "%s\n%!") message;
1614 match
1615 ( should_exit.interactive,
1616 should_exit.non_interactive,
1617 ctx.subshell,
1618 ctx.interactive,
1619 commands )
1620 with
1621 | `Yes, _, false, true, [] | _, `Yes, false, false, [] ->
1622 if should_exit.interactive = `Yes then Fmt.epr "exit\n%!";
1623 Stdlib.exit exit_code
1624 | _ -> loop_commands (exit, c :: cs) commands)
1625 | Exit.Zero _ as ctx -> loop_commands (ctx, c :: cs) commands)
1626 in
1627 loop_commands (ctx, []) ast
1628 in
1629 (ctx, List.rev cs)
1630end