diff --git a/src/lib/EDSL.mli b/src/lib/EDSL.mli index 88ef673..6b247eb 100644 --- a/src/lib/EDSL.mli +++ b/src/lib/EDSL.mli @@ -126,12 +126,53 @@ val make_switch : default:unit Language.t -> unit Language.t (**/**) +(** {3 Redirections } *) type fd_redirection +(** Abstract type of file-descriptor redirections. *) + val to_fd: int t -> int t -> fd_redirection +(** Create a file-descriptor to file-descriptor redirection. *) + val to_file: int t -> string t -> fd_redirection +(** Create a file-descriptor to file redirection. *) + val with_redirections: unit t -> fd_redirection list -> unit t +(** + Run a [unit t] expression after applying a list of file-descriptor + redirections. + + The redirections are applied in the list's order. + + Cf. the example: + {[ + with_redirections (exec ["printf"; "%s"; "hello"]) [ + to_file (int 3) (string "/path/to/one"); + to_file (int 3) (string "/path/to/two"); + to_fd (int 2) (int 3); + to_fd (int 1) (int 2); + ]; + ]} + + ["printf '%s' 'hello'"] will output to the file ["/path/to/two"], + because redirections are set in that order: + + - file-descriptor [3] is set to output to ["/path/to/one"], + - file-descriptor [3] is set to output to ["/path/to/two"] + (overriding the previous redirection), + - file-descriptor [2] is redirected to file-descriptor [3], + - file-descriptor [1] is redirected to file-descriptor [2], + - then, ["printf"] outputs to [1]. + + Invalid cases, like redirecting to a file-descriptor has not been + opened, lead to undefined behavior; see + {{:https://github.com/hammerlab/genspio/issues/41}issue #41}. + If the shell is POSIX, the whole expression [with_redirections expr redirs] + exits and its return value is in [[1, 125]]; if the shell is + ["bash"] or ["zsh"], the failing redirection is just ignored and [expr] is + executed with the remaining redirections if any. +*) val write_output : ?stdout:string t -> diff --git a/src/lib/language.ml b/src/lib/language.ml index a0ab083..526e304 100644 --- a/src/lib/language.ml +++ b/src/lib/language.ml @@ -292,25 +292,41 @@ let rec to_shell: type a. _ -> a t -> string = | Not t -> sprintf "! { %s ; }" (continue t) | Redirect_output (unit_t, redirections) -> - let variables = ref [] in + (* + We're here compiling the redirections into `exec` statements which + set up global redirections; we limit their scope with `( .. )`. + E.g. + ( exec 3>/tmp/output-of-ls ; exec 2>&3 ; exec 1>&2 ; ls ; ) ; + *) let make_redirection { take; redirect_to } = let takearg = to_argument "redirection_take" (`Int take) in let retoarg = to_argument "redirection_to" (match redirect_to with `Fd i -> `Int i | `Path p -> `String p) in - variables := takearg#export :: retoarg#export :: !variables; - sprintf "%s>%s%s" - takearg#argument - (match redirect_to with `Fd _ -> "&" | `Path _ -> " ") - retoarg#argument + let variables = + takearg#export :: retoarg#export :: [] |> List.filter_opt in + let exec = + sprintf "\"exec %%s>%s%%s\" %s %s" + (match redirect_to with `Fd _ -> "&" | `Path _ -> "") + takearg#argument + retoarg#argument + in + sprintf "%s eval \"$(printf %s)\" || { echo 'Exec %s failed' >&2 ; } " + (String.concat variables ~sep:"") + exec + exec in - let compiled_redirections = - List.rev_map redirections ~f:make_redirection in - let command = Construct.string (continue unit_t) in - sprintf "%s eval \"{ $(%s) ; } %s\" " - (String.concat (List.filter_opt !variables) ~sep:"") - (expand_octal (continue command)) - (String.concat ~sep:" " compiled_redirections) + begin match redirections with + | [] -> continue unit_t + | one :: more -> + continue (Seq ( + Raw_cmd (sprintf "( %s" (make_redirection one)) + :: + List.map more ~f:(fun r -> Raw_cmd (make_redirection r)) + @ [unit_t] + @ [ Raw_cmd ")" ] + )) + end | Write_output { expr; stdout; stderr; return_value } -> let ret_arg = Option.map return_value ~f:(fun v -> to_argument "retval" (`String v)) diff --git a/src/test/main.ml b/src/test/main.ml index 772250f..641ad46 100644 --- a/src/test/main.ml +++ b/src/test/main.ml @@ -741,19 +741,12 @@ let tests = seq [ tmp1#set (string ""); tmp2#set (string ""); - call [string "eval"; - output_as_string ( - call [string "printf"; string "exec 3> %s"; tmp1#path] - )]; with_redirections (exec ["printf"; "%s"; recognizable]) [ - to_fd (int 1) (int 2); - to_fd (int 2) (int 3); + to_file (int 3) tmp1#path; to_file (int 3) tmp2#path; (* we hijack tmp1's use of fd 3 *) + to_fd (int 2) (int 3); + to_fd (int 1) (int 2); ]; - call [string "eval"; - output_as_string ( - call [string "printf"; string "exec 3>&-"] - )]; call [string "cat"; tmp1#path]; call [string "cat"; tmp2#path]; assert_or_fail "fd3-empty" (tmp1#get =$= string ""); @@ -763,6 +756,44 @@ let tests = return 3 ] ); + exits 2 ~name:"redirect-fails" Genspio.EDSL.( + let tmp1 = tmp_file "fd3" in + let tmp2 = tmp_file "return" in + let recognizable = "heelllloooooo" in + let this_is_bash = + (exec ["ps"] |> output_as_string) + >> exec ["grep"; "bash"] + |> returns ~value:0 in + seq [ + tmp1#set (string ""); + write_output + ~return_value:tmp2#path ( + with_redirections (exec ["printf"; "%s"; recognizable]) [ + to_fd (int 4) (int 3); (* This fails because &3 is not open! *) + to_file (int 1) tmp1#path; + ] + ); + call [string "printf"; string "%s:\\n"; tmp1#path]; + call [string "cat"; tmp1#path]; + call [string "printf"; string "%s:\\n"; tmp2#path]; + call [string "cat"; tmp2#path]; + assert_or_fail "fd3" ( + (tmp1#get =$= string "") + ||| + (this_is_bash + &&& + (tmp1#get =$= string recognizable)) + ); + assert_or_fail "return-value" ( + (tmp2#get =$= string "2") + ||| + (this_is_bash + &&& + (tmp2#get =$= string "0")) + ); + return 2 + ] + ); ] let posix_sh_tests = [