ocamlbuild/shell.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 My_std
  15
  16 let is_simple_filename s =
  17   let ls = String.length s in
  18   ls <> 0 &&
  19   let rec loop pos =
  20     if pos >= ls then true else
  21     match s.[pos] with
  22     | 'a'..'z' | 'A'..'Z' | '0'..'9' | '.' | '-' | '/' | '_' | ':' | '@' | '+' | ',' -> loop (pos + 1)
  23     | _ -> false in
  24   loop 0
  25 let quote_filename_if_needed s =
  26   if is_simple_filename s then s else Filename.quote s
  27 let chdir dir =
  28   reset_filesys_cache ();
  29   Sys.chdir dir
  30 let run args target =
  31   reset_readdir_cache ();
  32   let cmd = String.concat " " (List.map quote_filename_if_needed args) in
  33   if !*My_unix.is_degraded || Sys.os_type = "Win32" then
  34     begin
  35       Log.event cmd target Tags.empty;
  36       let st = sys_command cmd in
  37       if st <> 0 then
  38         failwith (Printf.sprintf "Error during command `%s'.\nExit code %d.\n" cmd st)
  39       else
  40         ()
  41     end
  42   else
  43     match My_unix.execute_many ~ticker:Log.update ~display:Log.display [[(fun () -> cmd)]] with
  44     | None -> ()
  45     | Some(_, x) ->
  46       failwith (Printf.sprintf "Error during command %S: %s" cmd (Printexc.to_string x))
  47 let rm = sys_remove
  48 let rm_f x =
  49   if sys_file_exists x then rm x
  50 let mkdir dir =
  51   reset_filesys_cache_for_file dir;
  52   (*Sys.mkdir dir (* MISSING in ocaml *) *)
  53   run ["mkdir"; dir] dir
  54 let try_mkdir dir = if not (sys_file_exists dir) then mkdir dir
  55 let rec mkdir_p dir =
  56   if sys_file_exists dir then ()
  57   else (mkdir_p (Filename.dirname dir); mkdir dir)
  58
  59 let cp_pf src dest =
  60   reset_filesys_cache_for_file dest;
  61   run["cp";"-pf";src;dest] dest
  62
  63 (* L'Arrêté du 2007-03-07 prend en consideration
  64    differement les archives. Pour les autres fichiers
  65    le décret du 2007-02-01 est toujours valable :-) *)
  66 let cp src dst =
  67   if Filename.check_suffix src ".a"
  68   && Filename.check_suffix dst ".a"
  69   then cp_pf src dst
  70   else copy_file src dst
  71
  72 let readlink = My_unix.readlink
  73 let is_link = My_unix.is_link
  74 let rm_rf x =
  75   reset_filesys_cache ();
  76   run["rm";"-Rf";x] x
  77 let mv src dest =
  78   reset_filesys_cache_for_file src;
  79   reset_filesys_cache_for_file dest;
  80   run["mv"; src; dest] dest
  81   (*Sys.rename src dest*)