Shells in OCaml
Export
This adds a (probably slightly broken) `export` built-in. For now it
only handles the usual case of `export A1=B1 A2=B2`.
+128
-57
+17
-3
src/lib/ast.ml
+17
-3
src/lib/ast.ml
···
738
738
let rec word_component_to_string : word_component -> string = function
739
739
| WordName s -> s
740
740
| WordLiteral s -> s
741
-
| WordDoubleQuoted s -> String.concat "" (List.map word_component_to_string s)
742
-
| WordSingleQuoted s -> String.concat "" (List.map word_component_to_string s)
741
+
| WordDoubleQuoted s -> word_components_to_string s
742
+
| WordSingleQuoted s -> word_components_to_string s
743
743
| WordGlobAll -> "*"
744
744
| WordGlobAny -> "?"
745
+
| WordAssignmentWord (Name p, v) -> p ^ "=" ^ word_components_to_string v
745
746
| WordSubshell _ ->
746
747
Fmt.failwith
747
748
"This is an error in Merry, subshells should already have been \
···
750
751
Fmt.failwith "Conversion of %a" Yojson.Safe.pp
751
752
(word_component_to_yojson v)
752
753
753
-
let word_components_to_string ws =
754
+
and word_components_to_string ws =
754
755
String.concat "" (List.map word_component_to_string ws)
755
756
756
757
class check_ast =
···
787
788
end
788
789
in
789
790
o#complete_command ast false
791
+
792
+
let has_glob ast =
793
+
let o =
794
+
object
795
+
inherit check_ast as super
796
+
797
+
method! word_component v ctx =
798
+
match v with
799
+
| WordGlobAll | WordGlobAny -> true
800
+
| _ -> super#word_component v ctx
801
+
end
802
+
in
803
+
o#word_cst ast false
+3
src/lib/ast.mli
+3
src/lib/ast.mli
···
26
26
(** Checks, recursively, the command to see if there is any use of the async
27
27
operator [&] *)
28
28
29
+
val has_glob : word_cst -> bool
30
+
(** Checks whether or not any glob patterns exist in a given word_cst *)
31
+
29
32
module Dump : sig
30
33
val pp : t Fmt.t
31
34
(** Dump the program *)
+88
-47
src/lib/eval.ml
+88
-47
src/lib/eval.ml
···
217
217
let apply_pair (a, b) f = f a b
218
218
let ( ||> ) = apply_pair
219
219
220
-
let get_env ?(extra = []) () =
220
+
let get_env ?(extra = []) ctx =
221
+
let extra =
222
+
extra
223
+
@ List.map (fun (k, v) -> (k, Ast.word_components_to_string v))
224
+
@@ S.exports ctx.state
225
+
in
221
226
let env = Eunix.env () in
222
227
List.fold_left (fun acc (k, _) -> List.remove_assoc k acc) env extra
223
228
|> List.append extra
···
252
257
let process =
253
258
E.exec ctx.executor ?fds ?stdin ~stdout ~pgid ~mode
254
259
~cwd:(cwd_of_ctx ctx)
255
-
~env:(get_env ~extra:ctx.local_state ())
260
+
~env:(get_env ~extra:ctx.local_state ctx)
256
261
args
257
262
in
258
263
match process with
···
279
284
(Ast.SimpleCommand (Named (executable, suffix)) :: rest)
280
285
| Ast.SimpleCommand (Named (executable, suffix)) :: rest -> (
281
286
let ctx, executable = expand_cst ctx executable in
282
-
let executable = handle_word_components_to_string ctx executable in
287
+
let executable = handle_word_cst_subshell ctx executable in
288
+
let executable = Ast.word_components_to_string executable in
283
289
let ctx, suffix =
284
290
match suffix with
285
291
| None -> (ctx, [])
286
292
| Some suffix -> expand_redirects (ctx, []) suffix
287
293
in
288
294
let args = args ctx suffix in
295
+
let args_as_strings = List.map Ast.word_components_to_string args in
289
296
let some_read, some_write =
290
297
stdout_for_pipeline ~sw:pipeline_switch ctx rest
291
298
in
···
294
301
| `Global p -> (true, p)
295
302
| `Local p -> (false, p)
296
303
in
297
-
match Built_ins.of_args (executable :: args) with
304
+
match Built_ins.of_args (executable :: args_as_strings) with
298
305
| Some (Ok bi) ->
299
306
let ctx = handle_built_in ctx bi in
300
307
let built_in = ctx >|= fun _ -> () in
···
303
310
| Some (Error _) ->
304
311
(ctx, handle_job ~pgid job (`Built_in (Exit.nonzero () 1)))
305
312
| None -> (
306
-
let saved_ctx = ctx in
307
-
match
308
-
let ctx = { ctx with stdout = some_write } in
309
-
handle_function_application ctx ~name:executable
310
-
(ctx.program :: args)
311
-
with
312
-
| Some ctx ->
313
-
close_stdout ~is_global some_write;
314
-
(* TODO: Proper job stuff and redirects etc. *)
313
+
(* We handle the [export] built_in explicitly as we need access to the
314
+
raw CST *)
315
+
match executable with
316
+
| "export" ->
317
+
let updated = handle_export ctx args in
315
318
let job =
316
-
handle_job ~pgid job (`Built_in (ctx >|= fun _ -> ()))
317
-
in
318
-
loop saved_ctx job (pgid, some_read) rest
319
-
| None -> (
320
-
let redirect =
321
-
List.fold_left
322
-
(fun acc -> function
323
-
| Ast.Suffix_word _ -> acc
324
-
| Ast.Suffix_redirect rdr ->
325
-
handle_one_redirection ~sw:pipeline_switch ctx rdr
326
-
:: acc)
327
-
[] suffix
328
-
|> List.rev |> List.filter_map Fun.id
319
+
handle_job ~pgid job (`Built_in (updated >|= fun _ -> ()))
329
320
in
330
-
match stdout_of_previous with
331
-
| None ->
332
-
let ctx, job =
333
-
exec_process ctx job ~fds:redirect ~stdout:some_write
334
-
~pgid (executable :: args)
321
+
loop (Exit.value updated) job (pgid, stdout_of_previous) rest
322
+
| _ -> (
323
+
let saved_ctx = ctx in
324
+
match
325
+
let ctx = { ctx with stdout = some_write } in
326
+
handle_function_application ctx ~name:executable
327
+
(ctx.program :: args_as_strings)
328
+
with
329
+
| Some ctx ->
330
+
close_stdout ~is_global some_write;
331
+
(* TODO: Proper job stuff and redirects etc. *)
332
+
let job =
333
+
handle_job ~pgid job (`Built_in (ctx >|= fun _ -> ()))
335
334
in
336
-
close_stdout ~is_global some_write;
337
-
loop ctx job (pgid, some_read) rest
338
-
| Some stdout ->
339
-
let ctx, job =
340
-
exec_process ctx job ~fds:redirect ~stdin:stdout
341
-
~stdout:some_write ~pgid (executable :: args)
335
+
loop saved_ctx job (pgid, some_read) rest
336
+
| None -> (
337
+
let redirect =
338
+
List.fold_left
339
+
(fun acc -> function
340
+
| Ast.Suffix_word _ -> acc
341
+
| Ast.Suffix_redirect rdr ->
342
+
handle_one_redirection ~sw:pipeline_switch ctx
343
+
rdr
344
+
:: acc)
345
+
[] suffix
346
+
|> List.rev |> List.filter_map Fun.id
342
347
in
343
-
close_stdout ~is_global some_write;
344
-
loop ctx job (pgid, some_read) rest)))
348
+
match stdout_of_previous with
349
+
| None ->
350
+
let ctx, job =
351
+
exec_process ctx job ~fds:redirect
352
+
~stdout:some_write ~pgid
353
+
(executable :: args_as_strings)
354
+
in
355
+
close_stdout ~is_global some_write;
356
+
loop ctx job (pgid, some_read) rest
357
+
| Some stdout ->
358
+
let ctx, job =
359
+
exec_process ctx job ~fds:redirect ~stdin:stdout
360
+
~stdout:some_write ~pgid
361
+
(executable :: args_as_strings)
362
+
in
363
+
close_stdout ~is_global some_write;
364
+
loop ctx job (pgid, some_read) rest))))
345
365
| CompoundCommand (c, rdrs) :: rest ->
346
366
let _rdrs =
347
367
List.map (handle_one_redirection ~sw:pipeline_switch ctx) rdrs
···
379
399
Exit.zero { ctx with background_jobs = job :: ctx.background_jobs }
380
400
end
381
401
402
+
and handle_export ctx (assignments : Ast.word_cst list) =
403
+
let rec loop acc_ctx = function
404
+
| [] -> Exit.zero acc_ctx
405
+
| Ast.WordAssignmentWord (Name param, v) :: rest ->
406
+
loop
407
+
{
408
+
acc_ctx with
409
+
state = S.update ~export:true acc_ctx.state ~param v;
410
+
}
411
+
rest
412
+
| _ :: _ -> Exit.nonzero_msg acc_ctx "export weird arguments"
413
+
in
414
+
List.fold_left
415
+
(fun ctx w -> match ctx with Exit.Zero ctx -> loop ctx w | _ -> ctx)
416
+
(Exit.zero ctx) assignments
417
+
382
418
and expand_cst (ctx : ctx) cst : ctx * Ast.word_cst =
383
419
let cst = tilde_expansion ctx cst in
384
420
let _, o = parameter_expansion' ctx in
···
447
483
let wdlist = Nlist.flatten @@ Nlist.map (word_glob_expand ctx) wdlist in
448
484
Nlist.fold_left
449
485
(fun _ word ->
450
-
let s = S.update ctx.state ~param:name [ Ast.WordLiteral word ] in
486
+
let s = S.update ctx.state ~param:name word in
451
487
let ctx = { ctx with state = s } in
452
488
exec ctx (term, Some sep))
453
489
(Exit.zero ctx) wdlist
···
534
570
in
535
571
Eio.Switch.run @@ fun sw -> run_subshells ~sw (ref false) wcs
536
572
537
-
and handle_word_components_to_string (ctx : ctx) wcs : string =
573
+
and handle_word_cst_subshell (ctx : ctx) wcs : Ast.word_cst =
538
574
if needs_subshelling wcs then begin
539
575
let wcs = handle_subshell ctx wcs in
540
-
Ast.word_components_to_string wcs
576
+
wcs
541
577
end
542
-
else Ast.word_components_to_string wcs
578
+
else wcs
543
579
544
580
and glob_expand ctx wc =
545
-
handle_word_components_to_string ctx wc |> Globlon.glob |> Array.to_list
581
+
let wc = handle_word_cst_subshell ctx wc in
582
+
if Ast.has_glob wc then
583
+
Ast.word_components_to_string wc
584
+
|> Globlon.glob |> Array.to_list
585
+
|> List.map (fun w -> [ Ast.WordName w ])
586
+
else [ wc ]
546
587
547
-
and word_glob_expand (ctx : ctx) wc =
588
+
and word_glob_expand (ctx : ctx) wc : Ast.word_cst list =
548
589
if List.exists needs_glob_expansion wc then glob_expand ctx wc
549
-
else [ handle_word_components_to_string ctx wc ]
590
+
else [ handle_word_cst_subshell ctx wc ]
550
591
551
592
and collect_assignments ?(update = true) ctx =
552
593
List.fold_left
···
566
607
| _ -> ctx)
567
608
ctx
568
609
569
-
and args ctx swc =
610
+
and args ctx swc : Ast.word_cst list =
570
611
List.concat_map
571
612
(function
572
613
| Ast.Suffix_redirect _ -> []
+9
-5
src/lib/posix/state.ml
+9
-5
src/lib/posix/state.ml
···
6
6
root : int;
7
7
outermost : bool;
8
8
home : string;
9
-
variables : Merry.Ast.word_cst Variables.t;
9
+
variables : (bool * Merry.Ast.word_cst) Variables.t;
10
10
}
11
11
12
12
let make ?(functions = []) ?(root = 0) ?(outermost = true) ?(home = "/root")
···
16
16
let cwd t = t.cwd
17
17
let set_cwd t cwd = { t with cwd }
18
18
let expand t = function `Tilde -> t.home
19
-
let lookup t ~param = Variables.find_opt param t.variables
19
+
let lookup t ~param = Variables.find_opt param t.variables |> Option.map snd
20
20
21
-
let update t ~param v =
22
-
let variables' = Variables.add param v t.variables in
21
+
let update ?(export = false) t ~param v =
22
+
let variables' = Variables.add param (export, v) t.variables in
23
23
{ t with variables = variables' }
24
24
25
+
let exports t =
26
+
Variables.to_list t.variables
27
+
|> List.filter_map (function p, (true, v) -> Some (p, v) | _ -> None)
28
+
25
29
let dump ppf s =
26
30
Fmt.pf ppf "Variables:[%a]"
27
31
Fmt.(list ~sep:Fmt.comma (pair string Yojson.Safe.pp))
28
32
(Variables.to_list s.variables
29
-
|> List.map (fun (s, v) -> (s, Merry.Ast.word_cst_to_yojson v)))
33
+
|> List.map (fun (s, (_, v)) -> (s, Merry.Ast.word_cst_to_yojson v)))
+6
-2
src/lib/types.ml
+6
-2
src/lib/types.ml
···
23
23
val lookup : t -> param:string -> Ast.word_cst option
24
24
(** Parameter lookup. [None] means [unset]. *)
25
25
26
-
val update : t -> param:string -> Ast.word_cst -> t
27
-
(** Update the state with a new parameter mapping *)
26
+
val update : ?export:bool -> t -> param:string -> Ast.word_cst -> t
27
+
(** Update the state with a new parameter mapping and whether or not it should
28
+
exported to the environment (default false). *)
29
+
30
+
val exports : t -> (string * Ast.word_cst) list
31
+
(** All of the variables that must be exported to the environment *)
28
32
29
33
val dump : t Fmt.t
30
34
end