Shells in OCaml
Various fixes
- Fixes to rdrs across compound commands
- Continue and Return support
- Globbing now uses Globlon
+144
-208
+41
-13
src/lib/built_ins.ml
+41
-13
src/lib/built_ins.ml
···
43
43
let update t options =
44
44
List.fold_left
45
45
(fun d -> function
46
-
| `Pipefail -> with_options ~pipefail:true d
47
-
| `Noclobber -> with_options ~noclobber:true d
48
-
| `Noglob -> with_options ~no_path_expansion:true d
49
-
| `Errexit -> with_options ~errexit:true d
50
-
| `Nounset -> with_options ~no_unset:true d
51
-
| `Async -> with_options ~async:true d)
46
+
| `Pipefail, pipefail -> with_options ~pipefail d
47
+
| `Noclobber, noclobber -> with_options ~noclobber d
48
+
| `Noglob, no_path_expansion -> with_options ~no_path_expansion d
49
+
| `Errexit, errexit -> with_options ~errexit d
50
+
| `Nounset, no_unset -> with_options ~no_unset d
51
+
| `Async, async -> with_options ~async d)
52
52
t options
53
53
54
54
let pp ppf opt =
···
71
71
Fmt.pf ppf "@[<v>%a@]" Fmt.(list pp_option) opts
72
72
end
73
73
74
-
type set = { update : Options.option list; print_options : bool }
74
+
type set = { update : (Options.option * bool) list; print_options : bool }
75
75
type hash = Hash_remove | Hash_stats | Hash_add of string list
76
76
type trap = Int of int | Action of string | Ignore | Default
77
77
···
213
213
let doc = "No unset, like -o nounset." in
214
214
Arg.(value & flag & info [ "u" ] ~docv:"NOUNSET" ~doc)
215
215
216
+
let rest =
217
+
let doc = "Arguments" in
218
+
Arg.(value & pos_all string [] & info [] ~docv:"ARGUMENTS" ~doc)
219
+
220
+
let classify_args args =
221
+
let plus_flags, args =
222
+
List.fold_left
223
+
(fun (p, a) v ->
224
+
if String.starts_with ~prefix:"+" v then (v :: p, a) else (p, v :: a))
225
+
([], []) args
226
+
in
227
+
(List.rev plus_flags, List.rev args)
228
+
216
229
let t =
217
-
let make_set update noglob noclobber nounset errexit =
218
-
let extra = if noglob then [ `Noglob ] else [] in
219
-
let extra = if noclobber then `Noclobber :: extra else extra in
220
-
let extra = if nounset then `Nounset :: extra else extra in
221
-
let extra = if errexit then `Errexit :: extra else extra in
230
+
let make_set update noglob noclobber nounset errexit rest =
231
+
let update = List.map (fun u -> (u, true)) update in
232
+
let extra = if noglob then [ (`Noglob, true) ] else [] in
233
+
let extra = if noclobber then (`Noclobber, true) :: extra else extra in
234
+
let extra = if nounset then (`Nounset, true) :: extra else extra in
235
+
let extra = if errexit then (`Errexit, true) :: extra else extra in
222
236
let update = extra @ update in
237
+
let unset, _args = classify_args rest in
238
+
let unset =
239
+
List.filter_map
240
+
(function
241
+
| "+f" -> Some (`Noglob, false)
242
+
| "+u" -> Some (`Nounset, false)
243
+
| "+e" -> Some (`Errexit, false)
244
+
| e ->
245
+
Debug.Log.err (fun f -> f "Missed set arg: %s" e);
246
+
None)
247
+
unset
248
+
in
249
+
let update = update @ unset in
223
250
Set { update; print_options = false }
224
251
in
225
252
let term =
226
-
Term.(const make_set $ option $ noglob $ noclobber $ nounset $ errexit)
253
+
Term.(
254
+
const make_set $ option $ noglob $ noclobber $ nounset $ errexit $ rest)
227
255
in
228
256
let info =
229
257
let doc = "Set or unset options and positional parameters." in
+2
-2
src/lib/built_ins.mli
+2
-2
src/lib/built_ins.mli
···
26
26
t ->
27
27
t
28
28
29
-
val update : t -> option list -> t
29
+
val update : t -> (option * bool) list -> t
30
30
val pp : t Fmt.t
31
31
end
32
32
33
-
type set = { update : Options.option list; print_options : bool }
33
+
type set = { update : (Options.option * bool) list; print_options : bool }
34
34
type hash = Hash_remove | Hash_stats | Hash_add of string list
35
35
type trap = Int of int | Action of string | Ignore | Default
36
36
+3
-2
src/lib/dune
+3
-2
src/lib/dune
+53
-20
src/lib/eval.ml
+53
-20
src/lib/eval.ml
···
52
52
umask : int;
53
53
}
54
54
55
+
exception Continue of ctx
56
+
(* Used for the [continue] non-POSIX keyword *)
57
+
58
+
exception Return of ctx Exit.t
59
+
(* Used for the [return] non-POSIX keyword *)
60
+
55
61
let _stdin ctx = ctx.stdin
56
62
57
63
let make_ctx ?(interactive = false) ?(subshell = false) ?(local_state = [])
···
346
352
Fmt.invalid_arg
347
353
"Exec with args not yet supported...";
348
354
({ ctx with rdrs }, job)
355
+
| "continue" (* non-POSIX *) -> raise (Continue ctx)
349
356
| _ -> (
350
357
let saved_ctx = ctx in
351
358
let func_app =
···
466
473
match handle_redirections ~sw:pipeline_switch ctx rdrs with
467
474
| Error ctx -> (ctx, handle_job job (`Rdr (Exit.nonzero () 1)))
468
475
| Ok rdrs ->
476
+
let saved_rdrs = ctx.rdrs in
469
477
(* TODO: No way this is right *)
470
-
let ctx = { ctx with rdrs } in
478
+
let ctx = { ctx with rdrs = rdrs @ saved_rdrs } in
471
479
let ctx = handle_compound_command ctx c in
472
480
let job = handle_job job (`Built_in (ctx >|= fun _ -> ())) in
473
481
let actual_ctx = Exit.value ctx in
474
-
loop { actual_ctx with rdrs = [] } job None rest)
482
+
loop { actual_ctx with rdrs = saved_rdrs } job None rest)
475
483
| FunctionDefinition (name, (body, _rdrs)) :: rest ->
476
484
let ctx = { ctx with functions = (name, body) :: ctx.functions } in
477
485
loop ctx job None rest
···
593
601
| Some s when kind = `Smallest -> (so_far, Some s)
594
602
| _ -> (
595
603
let s = so_far ^ String.make 1 c in
596
-
match Glob.tests ~pattern [ s ] with
597
-
| [ s ] -> (s, Some s)
598
-
| _ -> (s, acc)))
604
+
match Glob.test ~pattern s with
605
+
| true -> (s, Some s)
606
+
| false -> (s, acc)))
599
607
("", None) param
600
608
in
601
609
prefix
···
608
616
| Some s when kind = `Smallest -> (so_far, Some s)
609
617
| _ -> (
610
618
let s = String.make 1 c ^ so_far in
611
-
match Glob.tests ~pattern [ s ] with
612
-
| [ s ] -> (s, Some s)
613
-
| _ -> (s, acc)))
619
+
match Glob.test ~pattern s with
620
+
| true -> (s, Some s)
621
+
| false -> (s, acc)))
614
622
("", None)
615
623
(String.fold_left (fun acc c -> String.make 1 c ^ acc) "" param)
616
624
in
···
1013
1021
List.fold_left
1014
1022
(fun _ word ->
1015
1023
update ctx ~param:name word.Ast.txt >>= fun ctx ->
1016
-
exec ctx (term, Some sep))
1024
+
try exec ctx (term, Some sep)
1025
+
with Continue ctx -> Exit.zero ctx)
1017
1026
(Exit.zero ctx) (List.concat words))
1018
1027
(Exit.zero ctx) wdlist
1019
1028
···
1102
1111
let running_ctx = Exit.value exit_so_far in
1103
1112
match exec running_ctx (term, Some sep) with
1104
1113
| Exit.Nonzero _ -> exit_so_far (* TODO: Context? *)
1105
-
| Exit.Zero ctx -> loop (exec ctx (term', Some sep'))
1114
+
| Exit.Zero ctx ->
1115
+
loop
1116
+
(try exec ctx (term', Some sep')
1117
+
with Continue ctx -> Exit.zero ctx)
1106
1118
in
1107
1119
loop (Exit.zero ctx)
1108
1120
···
1112
1124
let running_ctx = Exit.value exit_so_far in
1113
1125
match exec running_ctx (term, Some sep) with
1114
1126
| Exit.Zero _ -> exit_so_far (* TODO: Context? *)
1115
-
| Exit.Nonzero { value = ctx; _ } -> loop (exec ctx (term', Some sep'))
1127
+
| Exit.Nonzero { value = ctx; _ } ->
1128
+
loop
1129
+
(try exec ctx (term', Some sep')
1130
+
with Continue ctx -> Exit.zero ctx)
1116
1131
in
1117
1132
loop (Exit.zero ctx)
1118
1133
···
1136
1151
argv);
1137
1152
let ctx = { ctx with argv = Array.of_list argv } in
1138
1153
let v =
1139
-
Option.some @@ (handle_compound_command ctx commands >|= fun _ -> ctx)
1154
+
try
1155
+
Option.some
1156
+
@@ (handle_compound_command ctx commands >|= fun _ -> ctx)
1157
+
with Return ctx -> Some ctx
1140
1158
in
1141
1159
Debug.Log.debug (fun f -> f "function leave: %s" name);
1142
1160
v
···
1164
1182
1165
1183
and glob_expand ctx pattern : ctx * Ast.fragment list =
1166
1184
( ctx,
1167
-
match Glob.glob_dir ~pattern (cwd_of_ctx ctx) with
1168
-
| [] -> [ Ast.Fragment.make pattern ]
1169
-
| exception _ -> [ Ast.Fragment.make pattern ]
1170
-
| xs -> List.map Ast.Fragment.make xs )
1185
+
match Glob.glob_dir pattern with
1186
+
| [] ->
1187
+
Debug.Log.debug (fun f -> f "Glob %s returned nothing" pattern);
1188
+
[ Ast.Fragment.make pattern ]
1189
+
| exception e ->
1190
+
Debug.Log.debug (fun f ->
1191
+
f "Glob expand exception: %s" (Printexc.to_string e));
1192
+
[ Ast.Fragment.make pattern ]
1193
+
| xs ->
1194
+
Debug.Log.debug (fun f ->
1195
+
f "Globbed %s to [%a]" pattern Fmt.(list (quote string)) xs);
1196
+
List.map Ast.Fragment.make xs )
1171
1197
1172
1198
and collect_assignments ?(update = true) ctx vs : ctx Exit.t =
1173
1199
List.fold_left
···
1183
1209
| Exit.Nonzero _ as ctx -> ctx
1184
1210
| Exit.Zero ctx -> (
1185
1211
let state =
1186
-
if update then
1212
+
(* TODO: Overhaul... need to collect assignments after word expansion...*)
1213
+
if update || String.equal "IFS" param then
1187
1214
S.update ctx.state ~param
1188
1215
(Ast.Fragment.join_list ~sep:"" @@ List.concat v)
1189
1216
else Ok ctx.state
···
1259
1286
{ Exit.default_should_exit with interactive = `Yes }
1260
1287
in
1261
1288
Exit.nonzero ~should_exit ctx n
1262
-
| Return n -> Exit.nonzero ctx n
1289
+
| Return 0 -> raise (Return (Exit.zero ctx))
1290
+
| Return n -> raise (Return (Exit.nonzero ctx n))
1263
1291
| Set { update; print_options } ->
1264
1292
let v =
1265
1293
Exit.zero
···
1388
1416
with
1389
1417
| "\n" -> Some acc
1390
1418
| c -> loop (acc ^ c)
1391
-
| exception End_of_file -> None
1419
+
| exception End_of_file ->
1420
+
Debug.Log.debug (fun f -> f "Read EOF");
1421
+
if String.equal acc "" then None else Some acc
1392
1422
in
1393
1423
loop ""
1394
1424
in
···
1402
1432
:: acc)
1403
1433
in
1404
1434
let fields =
1405
-
Option.map (fun s -> field_splitting ctx [ Ast.Fragment.make s ]) line
1435
+
Option.map
1436
+
(fun s ->
1437
+
field_splitting ctx [ Ast.Fragment.make ~splittable:true s ])
1438
+
line
1406
1439
in
1407
1440
match fields with
1408
1441
| None -> Exit.nonzero ctx 1
-6
src/lib/glob/dune
-6
src/lib/glob/dune
-47
src/lib/glob/glob.ml
-47
src/lib/glob/glob.ml
···
1
-
(* From dune-glob library
2
-
3
-
The MIT License
4
-
5
-
Copyright (c) 2016 Jane Street Group, LLC <opensource@janestreet.com>
6
-
7
-
Permission is hereby granted, free of charge, to any person obtaining a copy
8
-
of this software and associated documentation files (the "Software"), to deal
9
-
in the Software without restriction, including without limitation the rights
10
-
to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
11
-
copies of the Software, and to permit persons to whom the Software is
12
-
furnished to do so, subject to the following conditions:
13
-
14
-
The above copyright notice and this permission notice shall be included in all
15
-
copies or substantial portions of the Software.
16
-
17
-
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
18
-
IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
19
-
FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
20
-
AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
21
-
LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
22
-
OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
23
-
SOFTWARE. *)
24
-
25
-
type t = Re of { re : Re.re; repr : string } | Literal of string
26
-
27
-
let test t s =
28
-
match t with
29
-
| Literal t -> String.equal t s
30
-
| Re { re; repr = _ } -> Re.execp re s
31
-
32
-
let empty = Re { re = Re.compile Re.empty; repr = "\000" }
33
-
let universal = Re { re = Re.compile (Re.rep Re.any); repr = "**" }
34
-
35
-
let of_string_result repr =
36
-
Lexer.parse_string repr
37
-
|> Result.map (function
38
-
| Lexer.Literal s -> Literal s
39
-
| Re re -> Re { re = Re.compile re; repr })
40
-
41
-
let of_string repr =
42
-
match of_string_result repr with
43
-
| Error (_, msg) -> invalid_arg (Printf.sprintf "invalid glob: :%s" msg)
44
-
| Ok t -> t
45
-
46
-
let to_string t = match t with Re { repr; re = _ } -> repr | Literal s -> s
47
-
let hash t = String.hash (to_string t)
-21
src/lib/glob/glob.mli
-21
src/lib/glob/glob.mli
···
1
-
(** Simple glob support library. *)
2
-
3
-
type t
4
-
5
-
val empty : t
6
-
(** A glob that matches nothing *)
7
-
8
-
val universal : t
9
-
(** A glob that matches anything (including the strings starting with a ".") *)
10
-
11
-
val test : t -> string -> bool
12
-
(** Tests if string matches the glob. *)
13
-
14
-
val to_string : t -> string
15
-
(** Returns textual representation of a glob. *)
16
-
17
-
val of_string : string -> t
18
-
(** Converts string to glob. Throws [Invalid_argument] exception if string is
19
-
not a valid glob. *)
20
-
21
-
val hash : t -> int
-91
src/lib/glob/lexer.mll
-91
src/lib/glob/lexer.mll
···
1
-
{
2
-
open Re
3
-
4
-
let string_of_list chars =
5
-
let s = Bytes.make (List.length chars) '0' in
6
-
List.iteri (fun i c -> Bytes.set s i c) chars;
7
-
Bytes.to_string s
8
-
9
-
type t =
10
-
| Literal of string
11
-
| Re of Re.t
12
-
13
-
let no_slash = diff any (char '/')
14
-
let no_slash_no_dot = diff any (set "./")
15
-
16
-
type stack =
17
-
| Bottom
18
-
| Lbrace of stack
19
-
| Char of char * stack
20
-
| Re of Re.t * stack
21
-
| Comma of stack
22
-
23
-
let make_group st =
24
-
let rec loop current_re full_res st =
25
-
match st with
26
-
| Bottom -> failwith "'}' without opening '{'"
27
-
| Re (re, st) -> loop (re :: current_re) full_res st
28
-
| Char (c, st) -> loop (char c :: current_re) full_res st
29
-
| Comma st -> loop [] (seq current_re :: full_res) st
30
-
| Lbrace st -> Re (alt (seq current_re :: full_res), st)
31
-
in
32
-
loop [] [] st
33
-
34
-
let finalize st =
35
-
let rec loop acc st =
36
-
match st with
37
-
| Bottom -> seq (start :: acc)
38
-
| Re (re, st) -> loop (re :: acc) st
39
-
| Char (c, st) -> loop (char c :: acc) st
40
-
| Comma st -> loop (char ',' :: acc) st
41
-
| Lbrace _ -> failwith "unclosed '{'"
42
-
in
43
-
let rec try_str (acc : char list) st =
44
-
match st with
45
-
| Bottom -> Literal (string_of_list acc)
46
-
| Comma st -> try_str (',' :: acc) st
47
-
| Char (c, st) -> try_str (c :: acc) st
48
-
| st ->
49
-
let re =
50
-
let re = [stop] in
51
-
match acc with
52
-
| [] -> re
53
-
| _ :: _ -> str (string_of_list acc) :: re
54
-
in
55
-
Re (loop re st)
56
-
in
57
-
try_str [] st
58
-
}
59
-
60
-
rule initial = parse
61
-
(* | "**" { glob (Re (rep any, Bottom)) lexbuf } *)
62
-
| "*" { glob (Re (rep any, Bottom)) lexbuf }
63
-
| "" { glob Bottom lexbuf }
64
-
65
-
and glob st = parse
66
-
| eof
67
-
| '\\' eof { finalize st }
68
-
| '\\' (_ as c) { glob (Char (c , st)) lexbuf }
69
-
| "**" { glob (Re (seq [no_slash_no_dot; rep no_slash] , st)) lexbuf }
70
-
| '*' { glob (Re (rep no_slash , st)) lexbuf }
71
-
| '?' { glob (Re (no_slash , st)) lexbuf }
72
-
| '{' { glob (Lbrace st ) lexbuf }
73
-
| ',' { glob (Comma st ) lexbuf }
74
-
| '}' { glob (make_group st) lexbuf }
75
-
| '[' { char_set st lexbuf }
76
-
| ']' { failwith "']' without opening '['" }
77
-
| _ as c { glob (Char (c , st)) lexbuf }
78
-
79
-
and char_set st = parse
80
-
| '!' ([^ ']']* as s) "]" { glob (Re (diff any (set s) , st)) lexbuf }
81
-
| ([^ ']']* as s) "]" { glob (Re (set s , st)) lexbuf }
82
-
| "" { failwith "unclosed character set" }
83
-
84
-
{
85
-
let parse_string s =
86
-
let lb = Lexing.from_string s in
87
-
match initial lb with
88
-
| re -> Result.Ok re
89
-
| exception Failure msg ->
90
-
Error (Lexing.lexeme_start lb, msg)
91
-
}
+5
-4
src/lib/import.ml
+5
-4
src/lib/import.ml
···
75
75
end
76
76
77
77
module Glob = struct
78
-
let tests ~pattern s = List.filter Glob.(test (of_string pattern)) s
78
+
let glob_dir pattern = Globlon.glob pattern |> Array.to_list
79
79
80
80
let test ~pattern s =
81
-
match tests ~pattern [ s ] with [ _ ] -> true | _ :: _ | [] -> false
82
-
83
-
let glob_dir ~pattern dir = tests ~pattern (Eio.Path.read_dir dir)
81
+
let pat =
82
+
Re.Glob.glob ~anchored:true ~pathname:false pattern |> Re.compile
83
+
in
84
+
Re.execp pat s
84
85
end
+38
test/non-posix.t
+38
test/non-posix.t
···
1
+
Some non-POSIX pieces that we've brought into merry to make
2
+
it more useful.
3
+
4
+
1. Continue
5
+
6
+
$ cat > test.sh << EOF
7
+
> for i in "hello" "the" "world"; do
8
+
> if [ \${#i} -lt 4 ]; then
9
+
> continue
10
+
> fi
11
+
> echo "Got \$i"
12
+
> done
13
+
> EOF
14
+
15
+
$ sh test.sh
16
+
Got hello
17
+
Got world
18
+
$ msh test.sh
19
+
Got hello
20
+
Got world
21
+
22
+
A very specific example coming from /usr/sbin/update-shells
23
+
24
+
$ cat > test.sh << EOF
25
+
> echo "# /etc/shells: valud login shells" > file.txt
26
+
> echo "/bin/sh" >> file.txt
27
+
>
28
+
> while IFS='#' read -r line _; do
29
+
> echo "Line \$line"
30
+
> done < file.txt
31
+
> EOF
32
+
33
+
$ sh test.sh
34
+
Line
35
+
Line /bin/sh
36
+
$ msh test.sh
37
+
Line
38
+
Line /bin/sh
+2
-2
test/wordexp.ml
+2
-2
test/wordexp.ml
···
91
91
let actual = expand ctx cargs in
92
92
Alcotest.check fragments "same fragments" expected actual
93
93
94
-
let _test_glob env () =
94
+
let test_glob env () =
95
95
let cargs = W.[ glob_all; lit ".ml" ] in
96
96
with_default_ctx ~args:[ "*.ml" ] env @@ fun ctx ->
97
97
let expected = Ast.Fragment.[ make "test_merry.ml"; make "wordexp.ml" ] in
···
113
113
("single expansion", `Quick, test_single_expansion env);
114
114
("argv expansion", `Quick, test_argv_expansion env);
115
115
("argv expansion dquote", `Quick, test_argv_in_quotes_expansion env);
116
-
(* ("glob all", `Quick, test_glob env); *)
116
+
("glob all", `Quick, test_glob env);
117
117
("tilde", `Quick, test_tilde env);
118
118
]
119
119