ocamlbuild/ocamlbuild_unix_plugin.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 open Format
  15 open Ocamlbuild_pack
  16 open My_unix
  17
  18 let report_error f =
  19   function
  20   | Unix.Unix_error(err, fun_name, arg) ->
  21       fprintf f "%s: %S failed" Sys.argv.(0) fun_name;
  22       if String.length arg > 0 then
  23         fprintf f " on %S" arg;
  24       fprintf f ": %s" (Unix.error_message err)
  25   | exn -> raise exn
  26
  27 let mkstat unix_stat x =
  28   let st =
  29     try unix_stat x
  30     with Unix.Unix_error _ as e -> raise (Sys_error (My_std.sbprintf "%a" report_error e))
  31   in
  32   { stat_key = sprintf "(%d,%d)" st.Unix.st_dev st.Unix.st_ino;
  33     stat_file_kind =
  34       match st.Unix.st_kind with
  35       | Unix.S_LNK -> FK_link
  36       | Unix.S_DIR -> FK_dir
  37       | Unix.S_CHR | Unix.S_BLK | Unix.S_FIFO | Unix.S_SOCK -> FK_other
  38       | Unix.S_REG -> FK_file }
  39
  40 let is_link s = (Unix.lstat s).Unix.st_kind = Unix.S_LNK
  41
  42 let at_exit_once callback =
  43   let pid = Unix.getpid () in
  44   at_exit begin fun () ->
  45     if pid = Unix.getpid () then callback ()
  46   end
  47
  48 let run_and_open s kont =
  49   let ic = Unix.open_process_in s in
  50   let close () =
  51     match Unix.close_process_in ic with
  52     | Unix.WEXITED 0 -> ()
  53     | Unix.WEXITED _ | Unix.WSIGNALED _ | Unix.WSTOPPED _ ->
  54         failwith (Printf.sprintf "Error while running: %s" s) in
  55   try
  56     let res = kont ic in close (); res
  57   with e -> (close (); raise e)
  58
  59 let stdout_isatty () =
  60   Unix.isatty Unix.stdout
  61
  62 let execute_many =
  63   let exit = function
  64     | Ocamlbuild_executor.Subcommand_failed -> exit Exit_codes.rc_executor_subcommand_failed
  65     | Ocamlbuild_executor.Subcommand_got_signal -> exit Exit_codes.rc_executor_subcommand_got_signal
  66     | Ocamlbuild_executor.Io_error -> exit Exit_codes.rc_executor_io_error
  67     | Ocamlbuild_executor.Exceptionl_condition -> exit Exit_codes.rc_executor_excetptional_condition
  68   in
  69   Ocamlbuild_executor.execute ~exit
  70
  71 let setup () =
  72   implem.is_degraded <- false;
  73   implem.stdout_isatty <- stdout_isatty;
  74   implem.gettimeofday <- Unix.gettimeofday;
  75   implem.report_error <- report_error;
  76   implem.execute_many <- execute_many;
  77   implem.readlink <- Unix.readlink;
  78   implem.run_and_open <- run_and_open;
  79   implem.at_exit_once <- at_exit_once;
  80   implem.is_link <- is_link;
  81   implem.stat <- mkstat Unix.stat;
  82   implem.lstat <- mkstat Unix.lstat;