ocamlbuild/command.ml

   1 (***********************************************************************)
   2 (*                             ocamlbuild                              *)
   3 (*                                                                     *)
   4 (*  Nicolas Pouillard, Berke Durak, projet Gallium, INRIA Rocquencourt *)
   5 (*                                                                     *)
   6 (*  Copyright 2007 Institut National de Recherche en Informatique et   *)
   7 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   8 (*  under the terms of the Q Public License version 1.0.               *)
   9 (*                                                                     *)
  10 (***********************************************************************)
  11
  12 (* $Id$ *)
  13 (* Original author: Nicolas Pouillard *)
  14 (* Command *)
  15
  16 open My_std
  17 open Log
  18
  19 type tags = Tags.t
  20 type pathname = string
  21
  22 let jobs = ref 1
  23
  24 type t =
  25 | Seq of t list
  26 | Cmd of spec
  27 | Echo of string list * pathname
  28 | Nop
  29 and spec =
  30 | N (* nop or nil *)
  31 | S of spec list
  32 | A of string
  33 | P of pathname
  34 | Px of pathname
  35 | Sh of string
  36 | T of Tags.t
  37 | V of string
  38 | Quote of spec
  39
  40 (*type v = [ `Seq of v list | `Cmd of vspec | `Nop ]
  41 and vspec =
  42   [ `N
  43   | `S of vspec list
  44   | `A of string
  45   | `P of pathname
  46   | `Px of pathname
  47   | `Sh of string
  48   | `Quote of vspec ]
  49
  50 let rec spec_of_vspec =
  51   function
  52   | `N -> N
  53   | `S vspecs -> S (List.map spec_of_vspec vspecs)
  54   | `A s -> A s
  55   | `P s -> P s
  56   | `Px s -> Px s
  57   | `Sh s -> Sh s
  58   | `Quote vspec -> Quote (spec_of_vspec vspec)
  59
  60 let rec vspec_of_spec =
  61   function
  62   | N -> `N
  63   | S specs -> `S (List.map vspec_of_spec specs)
  64   | A s -> `A s
  65   | P s -> `P s
  66   | Px s -> `Px s
  67   | Sh s -> `Sh s
  68   | T _ -> invalid_arg "vspec_of_spec: T not supported"
  69   | Quote spec -> `Quote (vspec_of_spec spec)
  70
  71 let rec t_of_v =
  72   function
  73   | `Nop -> Nop
  74   | `Cmd vspec -> Cmd (spec_of_vspec vspec)
  75   | `Seq cmds -> Seq (List.map t_of_v cmds)
  76
  77 let rec v_of_t =
  78   function
  79   | Nop -> `Nop
  80   | Cmd spec -> `Cmd (vspec_of_spec spec)
  81   | Seq cmds -> `Seq (List.map v_of_t cmds)*)
  82
  83 let no_tag_handler _ = failwith "no_tag_handler"
  84
  85 let tag_handler = ref no_tag_handler
  86
  87 (*** atomize *)
  88 let atomize l = S(List.map (fun x -> A x) l)
  89 let atomize_paths l = S(List.map (fun x -> P x) l)
  90 (* ***)
  91
  92 let env_path = lazy begin
  93   let path_var = Sys.getenv "PATH" in
  94   Lexers.colon_sep_strings (Lexing.from_string path_var)
  95 end
  96
  97 let virtual_solvers = Hashtbl.create 32
  98 let setup_virtual_command_solver virtual_command solver =
  99   Hashtbl.replace virtual_solvers virtual_command solver
 100 let virtual_solver virtual_command =
 101   let solver =
 102     try
 103       Hashtbl.find virtual_solvers virtual_command
 104     with Not_found ->
 105       failwith (sbprintf "no solver for the virtual command %S \
 106                           (setup one with Command.setup_virtual_command_solver)"
 107                 virtual_command)
 108   in
 109   try solver ()
 110   with Not_found ->
 111     failwith (Printf.sprintf "the solver for the virtual command %S \
 112                               has failed finding a valid command" virtual_command)
 113
 114
 115 (* FIXME windows *)
 116 let search_in_path cmd =
 117   if Filename.is_implicit cmd then
 118     let path = List.find begin fun path ->
 119       if path = Filename.current_dir_name then sys_file_exists cmd
 120       else sys_file_exists (filename_concat path cmd)
 121     end !*env_path in
 122     filename_concat path cmd
 123   else cmd
 124
 125 (*** string_of_command_spec{,_with_calls *)
 126 let rec string_of_command_spec_with_calls call_with_tags call_with_target resolve_virtuals spec =
 127   let self = string_of_command_spec_with_calls call_with_tags call_with_target resolve_virtuals in
 128   let b = Buffer.create 256 in
 129   let first = ref true in
 130   let put_space () =
 131     if !first then
 132       first := false
 133     else
 134       Buffer.add_char b ' '
 135   in
 136   let put_filename p =
 137     Buffer.add_string b (Shell.quote_filename_if_needed p)
 138   in
 139   let rec do_spec = function
 140     | N -> ()
 141     | A u -> put_space (); put_filename u
 142     | Sh u -> put_space (); Buffer.add_string b u
 143     | P p -> put_space (); put_filename p
 144     | Px u -> put_space (); put_filename u; call_with_target u
 145     | V v -> if resolve_virtuals then do_spec (virtual_solver v)
 146              else (put_space (); Printf.bprintf b "<virtual %s>" (Shell.quote_filename_if_needed v))
 147     | S l -> List.iter do_spec l
 148     | T tags -> call_with_tags tags; do_spec (!tag_handler tags)
 149     | Quote s -> put_space (); put_filename (self s)
 150   in
 151   do_spec spec;
 152   Buffer.contents b
 153
 154 let string_of_command_spec x = string_of_command_spec_with_calls ignore ignore false x
 155
 156 let string_target_and_tags_of_command_spec spec =
 157   let rtags = ref Tags.empty in
 158   let rtarget = ref "" in
 159   let s = string_of_command_spec_with_calls ((:=) rtags) ((:=) rtarget) true spec in
 160   let target = if !rtarget = "" then s else !rtarget in
 161   s, target, !rtags
 162
 163 let string_print_of_command_spec spec quiet pretend =
 164   let s, target, tags = string_target_and_tags_of_command_spec spec in
 165   fun () -> if not quiet then Log.event ~pretend s target tags; s
 166 (* ***)
 167
 168 let print_escaped_string f = Format.fprintf f "%S"
 169
 170 let rec print f =
 171   function
 172   | Cmd spec -> Format.pp_print_string f (string_of_command_spec spec)
 173   | Seq seq -> List.print print f seq
 174   | Nop -> Format.pp_print_string f "nop"
 175   | Echo(texts, dest_path) ->
 176       Format.fprintf f "@[<2>Echo(%a,@ %a)@]"
 177         (List.print print_escaped_string) texts print_escaped_string dest_path
 178
 179 let to_string x = sbprintf "%a" print x
 180
 181 let add_parallel_stat, dump_parallel_stats =
 182   let xmin = ref max_int in
 183   let xmax = ref 0 in
 184   let xsum = ref 0 in
 185   let xsumall = ref 0 in
 186   let xcount = ref 0 in
 187   let xcountall = ref 0 in
 188   let add_parallel_stat x =
 189     if x > 0 then begin
 190       incr xcountall;
 191       xsumall := x + !xsumall;
 192     end;
 193     if x > 1 then begin
 194       incr xcount;
 195       xsum := x + !xsum;
 196       xmax := max !xmax x;
 197       xmin := min !xmin x;
 198     end
 199   in
 200   let dump_parallel_stats () =
 201     if !jobs <> 1 then
 202       if !xcount = 0 then
 203         dprintf 1 "# No parallelism done"
 204       else
 205         let xaverage = float_of_int !xsumall /. float_of_int !xcountall in
 206         let xaveragepara = float_of_int !xsum /. float_of_int !xcount in
 207         dprintf 1 "# Parallel statistics: { count(total): %d(%d), max: %d, min: %d, average(total): %.3f(%.3f) }"
 208                   !xcount !xcountall !xmax !xmin xaveragepara xaverage
 209   in
 210   add_parallel_stat, dump_parallel_stats
 211
 212 module Primitives = struct
 213   let do_echo texts dest_path =
 214     with_output_file dest_path begin fun oc ->
 215       List.iter (output_string oc) texts
 216     end
 217   let echo x y () = (* no print here yet *) do_echo x y; ""
 218 end
 219
 220 let rec list_rev_iter f =
 221   function
 222   | [] -> ()
 223   | x :: xs -> list_rev_iter f xs; f x
 224
 225 let flatten_commands quiet pretend cmd =
 226   let rec loop acc =
 227     function
 228     | [] -> acc
 229     | Nop :: xs -> loop acc xs
 230     | Cmd spec :: xs -> loop (string_print_of_command_spec spec quiet pretend :: acc) xs
 231     | Echo(texts, dest_path) :: xs -> loop (Primitives.echo texts dest_path :: acc) xs
 232     | Seq l :: xs -> loop (loop acc l) xs
 233   in List.rev (loop [] [cmd])
 234
 235 let execute_many ?(quiet=false) ?(pretend=false) cmds =
 236   add_parallel_stat (List.length cmds);
 237   let degraded = !*My_unix.is_degraded || Sys.os_type = "Win32" in
 238   let jobs = !jobs in
 239   if jobs < 0 then invalid_arg "jobs < 0";
 240   let max_jobs = if jobs = 0 then None else Some jobs in
 241
 242   let ticker = Log.update in
 243   let display = Log.display in
 244
 245   if cmds = [] then
 246     None
 247   else
 248     begin
 249       let konts = List.map (flatten_commands quiet pretend) cmds in
 250       if pretend then
 251         begin
 252           List.iter (List.iter (fun f -> ignore (f ()))) konts;
 253           None
 254         end
 255       else
 256         begin
 257           reset_filesys_cache ();
 258           if degraded then
 259             let res, opt_exn =
 260               List.fold_left begin fun (acc_res, acc_exn) cmds ->
 261                 match acc_exn with
 262                 | None ->
 263                     begin try
 264                       List.iter begin fun action ->
 265                         let cmd = action () in
 266                         let rc = sys_command cmd in
 267                         if rc <> 0 then begin
 268                           if not quiet then
 269                             eprintf "Exit code %d while executing this \
 270                                     command:@\n%s" rc cmd;
 271                           raise (Exit_with_code rc)
 272                         end
 273                       end cmds;
 274                       true :: acc_res, None
 275                     with e -> false :: acc_res, Some e
 276                     end
 277                 | Some _ -> false :: acc_res, acc_exn
 278               end ([], None) konts
 279             in match opt_exn with
 280             | Some(exn) -> Some(res, exn)
 281             | None -> None
 282           else
 283             My_unix.execute_many ~ticker ?max_jobs ~display konts
 284         end
 285     end
 286 ;;
 287
 288 let execute ?quiet ?pretend cmd =
 289   match execute_many ?quiet ?pretend [cmd] with
 290   | Some(_, exn) -> raise exn
 291   | _ -> ()
 292
 293 let iter_tags f x =
 294   let rec spec x =
 295     match x with
 296     | N | A _ | Sh _ | P _ | Px _ | V _ | Quote _ -> ()
 297     | S l -> List.iter spec l
 298     | T tags -> f tags
 299   in
 300   let rec cmd x =
 301     match x with
 302     | Nop | Echo _ -> ()
 303     | Cmd(s) -> spec s
 304     | Seq(s) -> List.iter cmd s in
 305   cmd x
 306
 307 let rec reduce x =
 308   let rec self x acc =
 309     match x with
 310     | N -> acc
 311     | A _ | Sh _ | P _ | Px _ | V _ -> x :: acc
 312     | S l -> List.fold_right self l acc
 313     | T tags -> self (!tag_handler tags) acc
 314     | Quote s -> Quote (reduce s) :: acc in
 315   match self x [] with
 316   | [] -> N
 317   | [x] -> x
 318   | xs -> S xs
 319
 320 let digest =
 321   let list = List.fold_right in
 322   let text x acc = Digest.string x :: acc in
 323   let rec cmd =
 324     function
 325     | Cmd spec -> fun acc -> string_of_command_spec spec :: acc
 326     | Seq seq -> list cmd seq
 327     | Nop -> fun acc -> acc
 328     | Echo(texts, dest_path) -> list text (dest_path :: texts)
 329   in
 330   fun x ->
 331     match cmd x [] with
 332     | [x] -> x
 333     | xs  -> Digest.string ("["^String.concat ";" xs^"]")
 334
 335 (*
 336 let to_string_for_digest x =
 337   let rec cmd_of_spec =
 338     function
 339     | [] -> None
 340     | N :: xs -> cmd_of_spec xs
 341     | (A x | P x | P x) :: _ -> Some x
 342     | Sh x :: _ ->
 343         if Shell.is_simple_filename x then Some x
 344         else None (* Sh"ocamlfind ocamlc" for example will not be digested. *)
 345     | S specs1 :: specs2 -> cmd_of_spec (specs1 @ specs2)
 346     | (T _ | Quote _) :: _ -> assert false in
 347   let rec cmd_of_cmds =
 348     function
 349     | Nop | Seq [] -> None
 350     | Cmd spec -> cmd_of_spec [spec]
 351     | Seq (cmd :: _) -> cmd_of_cmds cmd in
 352   let s = to_string x in
 353   match cmd_of_cmds x with
 354   | Some x ->
 355       if sys_file_exists x then sprintf "(%S,%S)" s (Digest.file x)
 356       else s
 357   | None -> s
 358 *)