Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

[ocamlbuild] Simplify a little the execute_many protocol and then cleanup Command. 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@8671 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Nicolas Pouillard 2007-11-28 16:11:46 +00:00
parent 187653767a
commit 9e216739ee
10 changed files with 63 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
ocamlbuild/command.ml
View File

@ -17,6 +17,7 @@ open My_std
open Log
type tags = Tags.t
type pathname = string
let jobs = ref 1
@ -28,8 +29,8 @@ and spec =
| N (* nop or nil *)
| S of spec list
| A of string
| P of string (* Pathname.t *)
| Px of string (* Pathname.t *)
| P of pathname
| Px of pathname
| Sh of string
| T of Tags.t
| V of string
@ -40,8 +41,8 @@ and vspec =
[ `N
| `S of vspec list
| `A of string
| `P of string (* Pathname.t *)
| `Px of string (* Pathname.t *)
| `P of pathname
| `Px of pathname
| `Sh of string
| `Quote of vspec ]
@ -158,11 +159,13 @@ let string_target_and_tags_of_command_spec spec =
let target = if !rtarget = "" then s else !rtarget in
s, target, !rtags
let string_print_of_command_spec spec =
let string_print_of_command_spec spec quiet pretend =
let s, target, tags = string_target_and_tags_of_command_spec spec in
(s, (fun quiet pretend () -> if not quiet then Log.event ~pretend s target tags))
fun () -> if not quiet then Log.event ~pretend s target tags; s
(* ***)
let print_escaped_string f = Format.fprintf f "%S"
let rec print f =
function
| Cmd spec -> Format.pp_print_string f (string_of_command_spec spec)
@ -176,12 +179,12 @@ let rec list_rev_iter f =
| [] -> ()
| x :: xs -> list_rev_iter f xs; f x
let spec_list_of_cmd cmd =
let flatten_commands quiet pretend cmd =
let rec loop acc =
function
| [] -> acc
| Nop :: xs -> loop acc xs
| Cmd spec :: xs -> loop (string_print_of_command_spec spec :: acc) xs
| Cmd spec :: xs -> loop (string_print_of_command_spec spec quiet pretend :: acc) xs
| Seq l :: xs -> loop (loop acc l) xs
in List.rev (loop [] [cmd])
@ -198,27 +201,10 @@ let execute_many ?(quiet=false) ?(pretend=false) cmds =
None
else
begin
let konts =
List.map
begin fun cmd ->
let specs = spec_list_of_cmd cmd in
List.map
begin fun (cmd, print) ->
(cmd, (print quiet pretend))
end
specs
end
cmds
in
let konts = List.map (flatten_commands quiet pretend) cmds in
if pretend then
begin
List.iter
begin fun l ->
List.iter
begin fun (_, f) -> f () end
l
end
konts;
List.iter (List.iter (fun f -> ignore (f ()))) konts;
None
end
else
@ -230,13 +216,13 @@ let execute_many ?(quiet=false) ?(pretend=false) cmds =
match acc_exn with
| None ->
begin try
List.iter begin fun (cmd, print) ->
print ();
List.iter begin fun action ->
let cmd = action () in
let rc = sys_command cmd in
if rc <> 0 then begin
if not quiet then
eprintf "Exit code %d while executing this \
command:@\n%s" rc cmd;
command:@\n%s" rc cmd;
raise (Exit_with_code rc)
end
end cmds;
@ -259,6 +245,20 @@ let execute ?quiet ?pretend cmd =
| Some(_, exn) -> raise exn
| _ -> ()
let iter_tags f x =
let rec spec x =
match x with
| N | A _ | Sh _ | P _ | Px _ | V _ | Quote _ -> ()
| S l -> List.iter spec l
| T tags -> f tags
in
let rec cmd x =
match x with
| Nop -> ()
| Cmd(s) -> spec s
| Seq(s) -> List.iter cmd s in
cmd x
let rec reduce x =
let rec self x acc =
match x with

4
ocamlbuild/command.mli
View File

@ -15,12 +15,14 @@
(** Provides an abstract type for easily building complex shell commands without making
quotation mistakes. *)
include Signatures.COMMAND with type tags = Tags.t
include Signatures.COMMAND with type tags = Tags.t and type pathname = string
(** {6 For system use only, not for the casual user} *)
val string_target_and_tags_of_command_spec : spec -> string * string * Tags.t
val iter_tags : (Tags.t -> unit) -> t -> unit
(** Same as [to_string]. *)
val to_string_for_digest : t -> string

3
ocamlbuild/my_std.ml
View File

@ -244,11 +244,12 @@ let sys_file_exists x =
let sys_command =
match Sys.os_type with
| "Win32" -> fun cmd ->
if cmd = "" then 0 else
let cmd = "bash -c "^Filename.quote cmd in
(* FIXME fix Filename.quote for windows *)
let cmd = String.subst "\"&\"\"&\"" "&&" cmd in
Sys.command cmd
| _ -> Sys.command
| _ -> fun cmd -> if cmd = "" then 0 else Sys.command cmd
(* FIXME warning fix and use Filename.concat *)
let filename_concat x y =

2
ocamlbuild/my_unix.ml
View File

@ -36,7 +36,7 @@ type implem =
?ticker:(unit -> unit) ->
?period:float ->
?display:((out_channel -> unit) -> unit) ->
((string * (unit -> unit)) list list) ->
((unit -> string) list list) ->
(bool list * exn) option;
mutable report_error : Format.formatter -> exn -> unit;
mutable at_exit_once : (unit -> unit) -> unit;

4
ocamlbuild/my_unix.mli
View File

@ -36,7 +36,7 @@ val execute_many :
?ticker:(unit -> unit) ->
?period:float ->
?display:((out_channel -> unit) -> unit) ->
((string * (unit -> unit)) list list) ->
((unit -> string) list list) ->
(bool list * exn) option
val report_error : Format.formatter -> exn -> unit
@ -60,7 +60,7 @@ type implem =
?ticker:(unit -> unit) ->
?period:float ->
?display:((out_channel -> unit) -> unit) ->
((string * (unit -> unit)) list list) ->
((unit -> string) list list) ->
(bool list * exn) option;
mutable report_error : Format.formatter -> exn -> unit;
mutable at_exit_once : (unit -> unit) -> unit;

8
ocamlbuild/ocamlbuild_executor.ml
View File

@ -21,12 +21,12 @@ type error =
| Io_error
| Exceptionl_condition
type task = (string * (unit -> unit));;
type task = unit -> string;;
type job = {
job_id : int * int;
job_command : string;
job_next : (string * (unit -> unit)) list;
job_next : task list;
job_result : bool ref; (* Result of this sequence group *)
job_stdout : in_channel;
job_stdin : out_channel;
@ -129,9 +129,9 @@ let execute
in
(* ***)
(*** add_job *)
let add_job (cmd, action) rest result id =
let add_job action rest result id =
let cmd = action () in
(*display begin fun oc -> fp oc "Job %a is %s\n%!" print_job_id id cmd; end;*)
action ();
let (stdout', stdin', stderr') = open_process_full cmd env in
incr jobs_active;
set_nonblock (doi stdout');

15
ocamlbuild/ocamlbuild_executor.mli
View File

@ -24,12 +24,13 @@ type error =
(** [execute ~ticker ~period ~display ~exit commands] will execute the commands
in [commands] in parallel, correctly multiplexing their outputs.
A command is a pair [(cmd, action)] where [cmd] is a shell command string,
and [action] is a thunk that is to be called just before [cmd] is about to
be executed. If specified, it will call [ticker] at least every [period]
seconds. If specified, it will call [display f] when it wishes to print
something; [display] should then call [f] with then channel on which [f]
should print.
A command is a function that given a unit [()] returns the shell command
string to execute, commands are functions in order to do some job just
before executing the command. These functions will be called once. If
specified, it will call [ticker] at least every [period] seconds. If
specified, it will call [display f] when it wishes to print something;
[display] should then call [f] with then channel on which [f] should
print.
Note that [f] must be idempotent as it may well be called twice, once for
the log file, once for the actual output.
@ -46,5 +47,5 @@ val execute :
?period:float ->
?display:((out_channel -> unit) -> unit) ->
exit:(error -> unit) ->
((string * (unit -> unit)) list list) ->
((unit -> string) list list) ->
(bool list * exn) option

22
ocamlbuild/rule.ml
View File

@ -150,22 +150,12 @@ let build_deps_of_tags builder tags =
| [] -> []
| deps -> List.map Outcome.good (builder (List.map (fun x -> [x]) deps))
let build_deps_of_tags_on_cmd builder x =
let rec spec x =
match x with
| Command.N | Command.A _ | Command.Sh _ | Command.P _ | Command.Px _ | Command.V _ | Command.Quote _ -> ()
| Command.S l -> List.iter spec l
| Command.T tags ->
begin match deps_of_tags tags with
| [] -> ()
| deps -> List.iter ignore_good (builder (List.map (fun x -> [x]) deps))
end in
let rec cmd x =
match x with
| Command.Nop -> ()
| Command.Cmd(s) -> spec s
| Command.Seq(s) -> List.iter cmd s in
cmd x
let build_deps_of_tags_on_cmd builder =
Command.iter_tags begin fun tags ->
match deps_of_tags tags with
| [] -> ()
| deps -> List.iter ignore_good (builder (List.map (fun x -> [x]) deps))
end
let call builder r =
let dyndeps = ref Resources.empty in

2
ocamlbuild/shell.ml
View File

@ -40,7 +40,7 @@ let run args target =
()
end
else
match My_unix.execute_many ~ticker:Log.update ~display:Log.display [[(cmd, ignore)]] with
match My_unix.execute_many ~ticker:Log.update ~display:Log.display [[(fun () -> cmd)]] with
| None -> ()
| Some(_, x) ->
failwith (Printf.sprintf "Error during command %S: %s" cmd (Printexc.to_string x))

11
ocamlbuild/signatures.mli
View File

@ -156,6 +156,7 @@ end
quotation mistakes. *)
module type COMMAND = sig
type tags
type pathname
(** The type [t] is basically a sequence of command specifications. This avoids having to
flatten lists of lists. *)
@ -166,8 +167,8 @@ module type COMMAND = sig
| N (** No operation. *)
| S of spec list (** A sequence. This gets flattened in the last stages *)
| A of string (** An atom. *)
| P of string (** A pathname. *)
| Px of string (** A pathname, that will also be given to the call_with_target hook. *)
| P of pathname (** A pathname. *)
| Px of pathname (** A pathname, that will also be given to the call_with_target hook. *)
| Sh of string (** A bit of raw shell code, that will not be escaped. *)
| T of tags (** A set of tags, that describe properties and some semantics
information about the command, afterward these tags will be
@ -180,8 +181,8 @@ module type COMMAND = sig
[ `N
| `S of vspec list
| `A of string
| `P of string (* Pathname.t *)
| `Px of string (* Pathname.t *)
| `P of pathname
| `Px of pathname
| `Sh of string
| `Quote of vspec ]
@ -426,7 +427,7 @@ end
module type PLUGIN = sig
module Pathname : PATHNAME
module Tags : TAGS
module Command : COMMAND with type tags = Tags.t
module Command : COMMAND with type tags = Tags.t and type pathname = Pathname.t
module Outcome : OUTCOME
module String : STRING
module List : LIST