Skip to content
Browse files

Import from typerex a module to handle correctly synchronous command …

…processes.

Now a command is a list of words, which is much safer (and we are not allowed anymore to use pipes).
  • Loading branch information...
1 parent 88b0ff1 commit 54edd4914e1cf24a1da3a8411b5d45f5654a1cba @samoht samoht committed May 25, 2012
View
27 src/client.ml
@@ -498,7 +498,7 @@ let proceed_todelete t nv =
(* Run the remove script *)
let opam = File.OPAM.read (Path.G.opam t.global nv) in
- let remove = String.concat " " (File.OPAM.remove opam) in
+ let remove = File.OPAM.remove opam in
let err = Dirname.exec (Path.C.lib_dir t.compiler) [remove] in
if err <> 0 then
Globals.error_and_exit "Cannot uninstall %s" (NV.to_string nv);
@@ -586,8 +586,8 @@ let proceed_tochange t nv_old nv =
(* Call the build script and copy the output files *)
let commands = List.map (List.map (substitute_string t)) (File.OPAM.build opam) in
- let commands = List.map (fun cmd -> String.concat " " cmd) commands in
- Globals.msg "Build command: %s\n" (String.concat ";" commands);
+ let commands_s = List.map (fun cmd -> String.concat " " cmd) commands in
+ Globals.msg "Build command: %s\n" (String.concat ";" commands_s);
let err = Dirname.exec ~add_to_path:[Path.C.bin t.compiler] p_build commands in
if err = 0 then
proceed_toinstall t nv
@@ -1021,17 +1021,20 @@ let switch to_replicate oversion =
match
Dirname.exec build_dir
- [ Printf.sprintf "./configure %s -prefix %s" (*-bindir %s/bin -libdir %s/lib -mandir %s/man*)
- (String.concat " " (File.Comp.configure comp))
- (Dirname.to_string (Path.C.root new_oversion))
- (* NOTE In case it exists 2 '-prefix', in general the script ./configure will only consider the last one, others will be discarded. *)
- ; Printf.sprintf "make %s" (String.concat " " (File.Comp.make comp))
- ; Printf.sprintf "make install" ]
+ [ ( "./configure" :: File.Comp.configure comp )
+ @ [ "-prefix"; Dirname.to_string (Path.C.root new_oversion) ]
+ (*-bindir %s/bin -libdir %s/lib -mandir %s/man*)
+ (* NOTE In case it exists 2 '-prefix', in general the script
+ ./configure will only consider the last one, others will be
+ discarded. *)
+ ; ( "make" :: File.Comp.make comp )
+ ; [ "make" ; "install" ]
+ ]
with
- | 0 ->
+ | 0 ->
Some (fun _ -> try init_ocaml new_oversion with e ->
- begin
- File.Config.write (Path.G.config t.global) t.config; (* restore the previous configuration *)
+ begin
+ File.Config.write (Path.G.config t.global) t.config; (* restore the previous configuration *)
Dirname.rmdir (Path.C.root new_oversion);
raise e;
end),
View
6 src/file.ml
@@ -414,7 +414,7 @@ module OPAM = struct
let parse_command =
parse_or [
- ("string", parse_string |> Printf.sprintf "'%s'");
+ ("string", parse_string);
("symbol", parse_symbol)
]
@@ -812,7 +812,9 @@ module Make (F : F) = struct
let filename = Filename.of_string "/dummy/"
let of_raw raw =
- F.of_string filename raw
+ try F.of_string filename raw
+ with Bad_format msg ->
+ Globals.error_and_exit "%s:\n%s" msg (Raw.to_string raw)
let to_raw t =
F.to_string filename t
View
153 src/process.ml
@@ -0,0 +1,153 @@
+(**************************************************************************)
+(* *)
+(* TypeRex OCaml Studio *)
+(* *)
+(* Thomas Gazagnaire, Fabrice Le Fessant *)
+(* *)
+(* Copyright 2011-2012 OCamlPro *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Public License version 3.0. *)
+(* *)
+(* TypeRex is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
+(* GNU General Public License for more details. *)
+(* *)
+(**************************************************************************)
+
+type t = {
+ p_name : string; (* Command name *)
+ p_args : string list; (* Command args *)
+ p_pid : int; (* Process PID *)
+ p_time : float; (* Process start time *)
+ p_stdout : string option; (* stdout dump file *)
+ p_stderr : string option; (* stderr dump file *)
+ p_info : string option; (* dump info file *)
+}
+
+let open_flags = [Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC]
+
+let create ?info ?stdout ?stderr ?env cmd args =
+ let stdout_fd = match stdout with
+ | None -> Unix.stdout
+ | Some f -> Unix.openfile f open_flags 0o644 in
+ let stderr_fd = match stderr with
+ | None -> Unix.stderr
+ | Some f -> Unix.openfile f open_flags 0o644 in
+ let env = match env with
+ | None -> Unix.environment ()
+ | Some e -> e in
+ let time = Unix.gettimeofday () in
+ let pid =
+ Unix.create_process_env
+ cmd
+ (Array.of_list (cmd :: args))
+ env
+ Unix.stdin stdout_fd stderr_fd in
+ (match stdout with None -> () | Some _ -> Unix.close stdout_fd);
+ (match stderr with None -> () | Some _ -> Unix.close stderr_fd);
+ {
+ p_name = cmd;
+ p_args = args;
+ p_pid = pid;
+ p_time = time;
+ p_stdout = stdout;
+ p_stderr = stderr;
+ p_info = info;
+ }
+
+type result = {
+ r_proc : t; (* Process *)
+ r_code : int; (* Process exit code *)
+ r_duration : float; (* Process duration *)
+ r_stdout : string list; (* Content of stdout dump file *)
+ r_stderr : string list; (* Content of stderr dump file *)
+}
+
+(* XXX: the function might block for ever for some channels kinds *)
+let read_lines f =
+ let ic = open_in f in
+ let lines = ref [] in
+ begin
+ try
+ while true do
+ let line = input_line ic in
+ lines := line :: !lines;
+ done
+ with _ -> ()
+ end;
+ close_in ic;
+ List.rev !lines
+
+let option_map fn = function
+ | None -> None
+ | Some o -> Some (fn o)
+
+let option_default d = function
+ | None -> d
+ | Some v -> v
+
+let wait p =
+ try
+ let rec iter () =
+ let _, status = Unix.waitpid [] p.p_pid in
+ match status with
+ | Unix.WEXITED code ->
+ let duration = Unix.gettimeofday () -. p.p_time in
+ let stdout =
+ option_default [] (option_map read_lines p.p_stdout) in
+ let stderr =
+ option_default [] (option_map read_lines p.p_stderr) in
+ {
+ r_proc = p;
+ r_code = code;
+ r_duration = duration;
+ r_stdout = stdout;
+ r_stderr = stderr;
+ }
+ | _ -> iter () in
+ iter ()
+ with e ->
+ Printf.printf "Exception %s in waitpid\n%!" (Printexc.to_string e);
+ exit 2
+
+let output_lines oc lines =
+ List.iter (fun line ->
+ output_string oc line;
+ output_string oc "\n";
+ flush oc;
+ ) lines;
+ output_string oc "\n";
+ flush oc
+
+let run ?env ~name cmd args =
+ let stdout = Printf.sprintf "%s.out" name in
+ let stderr = Printf.sprintf "%s.err" name in
+ let info = Printf.sprintf "%s.info" name in
+
+ let env = match env with Some e -> e | None -> Unix.environment () in
+
+ (* Write info file *)
+ let chan = open_out info in
+ output_lines chan
+ [ String.concat " " (cmd :: args) ;
+ Unix.getcwd () ;
+ String.concat "\n" (Array.to_list env)
+ ];
+ close_out chan;
+
+ let p = create ~env ~info ~stdout ~stderr cmd args in
+ wait p
+
+let is_success r = r.r_code = 0
+
+let is_failure r = r.r_code <> 0
+
+let option_iter fn = function
+ | None -> ()
+ | Some v -> fn v
+
+let clean_files r =
+ option_iter Unix.unlink r.r_proc.p_stdout;
+ option_iter Unix.unlink r.r_proc.p_stderr;
+ option_iter Unix.unlink r.r_proc.p_info
View
65 src/process.mli
@@ -0,0 +1,65 @@
+(**************************************************************************)
+(* *)
+(* TypeRex OCaml Studio *)
+(* *)
+(* Thomas Gazagnaire, Fabrice Le Fessant *)
+(* *)
+(* Copyright 2011-2012 OCamlPro *)
+(* All rights reserved. This file is distributed under the terms of *)
+(* the GNU Public License version 3.0. *)
+(* *)
+(* TypeRex is distributed in the hope that it will be useful, *)
+(* but WITHOUT ANY WARRANTY; without even the implied warranty of *)
+(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the *)
+(* GNU General Public License for more details. *)
+(* *)
+(**************************************************************************)
+
+(** Process handling *)
+
+(** The type for processes *)
+type t = {
+ p_name : string; (** Command name *)
+ p_args : string list; (** Command args *)
+ p_pid : int; (** Process PID *)
+ p_time : float; (** Process start time *)
+ p_stdout : string option; (** stdout dump file *)
+ p_stderr : string option; (** stderr dump file *)
+ p_info : string option; (** dump info file *)
+}
+
+(** [create cmd args] create a new process to execute the command
+ [cmd] with arguments [args]. If stdout/stderr are set, the
+ channels are redirected to files. The current environment can also
+ be overriden if [env] is set. *)
+val create :
+ ?info:string -> ?stdout:string -> ?stderr:string -> ?env:string array
+ -> string -> string list -> t
+
+(** The type for result processes *)
+type result = {
+ r_proc : t; (** Process *)
+ r_code : int; (** Process exit code *)
+ r_duration : float; (** Process duration *)
+ r_stdout : string list; (** Content of stdout dump file *)
+ r_stderr : string list; (** Content of stderr dump file *)
+}
+
+(** [wait p] waits for the processus [p] to end and returns its results *)
+val wait : t -> result
+
+(** [run ~name cmd args] synchronously call the command [cmd] with
+ arguments [args]. It waits until the process is finished. The file
+ [name.out], [name.err] and [name.info] are created, which contains
+ the standard output, the standart error and some process info
+ respectively *)
+val run : ?env:string array -> name:string -> string -> string list -> result
+
+(** Is the process result a success ? *)
+val is_success : result -> bool
+
+(** Is the process result a failure ? *)
+val is_failure : result -> bool
+
+(** Clean-up process result files *)
+val clean_files : result -> unit
View
8 src/repo/git/download.ml
@@ -24,15 +24,19 @@ let git_archive () =
Globals.error_and_exit "Cannot find %s" p in
Run.mkdir "git";
Run.in_dir (local_path / "git") (fun () ->
- let err = Run.command "git clone %s %s" url package in
+ let err = Run.command [ "git" ; "clone" ; url ; package ] in
if err <> 0 then
Globals.error_and_exit "%s is not a valid git url" url
)
);
(* Then run git-archive to get a tar.gz *)
Run.in_dir dirname (fun () ->
+ let tar = package ^ ".tar" in
let err =
- Run.command "git archive --format=tar --prefix=%s/ HEAD | gzip > %s.tar.gz" package package in
+ Run.commands [
+ [ "git" ; "archive" ; "--format=tar" ; "--prefix="^package^"/" ; "HEAD" ; "-o" ; tar ] ;
+ [ "gzip" ; "-f" ; tar ] ;
+ ] in
if err <> 0 then
Globals.error_and_exit "Cannot run git-archive in %s" dirname
)
View
6 src/repo/git/init.ml
@@ -21,9 +21,9 @@ let remote_address = Sys.argv.(1)
let git_clone () =
let err =
Run.commands [
- "git init";
- Printf.sprintf "git remote add origin %s" remote_address;
- "git pull origin master"
+ [ "git" ; "init" ] ;
+ [ "git" ; "remote" ; "add" ; "origin" ; remote_address ] ;
+ [ "git" ; "pull" ; "origin" ; "master" ]
] in
exit err
View
7 src/repo/git/update.ml
@@ -19,17 +19,18 @@ let repositories = Filename.concat local_path "git"
at [dirname] *)
let get_updates dirname =
Run.in_dir dirname (fun () ->
- let err = Run.command "git fetch origin" in
+ let err = Run.command [ "git" ; "fetch" ; "origin" ] in
if err = 0 then
- Run.read_command_output "git diff remotes/origin/master --name-only"
+ Run.read_command_output
+ [ "git" ; "diff" ; "remotes/origin/master" ; "--name-only" ]
else
Globals.error_and_exit "Cannot fetch git repository %s" dirname
)
(* Update the git repository located at [dirname] *)
let update dirname =
Run.in_dir dirname (fun () ->
- let err = Run.command "git pull origin master" in
+ let err = Run.command [ "git" ; "pull" ; "origin" ; "master" ] in
if err <> 0 then
Globals.error_and_exit "Cannot update git repository %s" dirname
)
View
2 src/repo/rsync/download.ml
@@ -15,6 +15,6 @@ let (/) = Filename.concat
let () =
let remote_archive = remote_address / "archives" / package ^ ".tar.gz" in
let err =
- Run.command "rsync -ar %s archives/" remote_archive in
+ Run.command [ "rsync" ; "-ar"; remote_archive ; "archives/" ] in
if err <> 0 then
Globals.error_and_exit "rsync command failed"
View
12 src/repo/rsync/update.ml
@@ -12,24 +12,32 @@ let remote_address = Sys.argv.(1)
open Types
let (/) = Stdlib_filename.concat
-let log = Globals.log "opam-rsync-update"
+let log fmt = Globals.log "opam-rsync-update" fmt
let rsync ?fn dir =
let option, filter = match fn with
| None -> "" , (fun _ -> None)
| Some f -> "v", f in
let lines =
- Run.read_command_output "rsync -ar%s %s %s" option (remote_address / dir) dir in
+ Run.read_command_output [
+ "rsync"; "-ar"^option ; option ; (remote_address / dir) ; dir
+ ] in
let files = Utils.filter_map filter lines in
List.iter (fun x -> log "updated: %s" (NV.to_string x)) files;
List.fold_left (fun set f -> NV.Set.add f set) NV.Set.empty files
+let _ = log "FOO1"
+
let () =
let fn str = NV.of_filename (Filename.of_string str) in
+ log "FOO2";
let opam = rsync ~fn "opam/" in
+ log "FOO3";
let descr = rsync "descr/" in
let archives =
+ log "FOO";
let files = Run.files "archives" in
+ log "BAR";
List.fold_left (fun set f -> NV.Set.union (rsync ~fn f) set) NV.Set.empty files in
let updates = NV.Set.union archives (NV.Set.union opam descr) in
File.Updated.write
View
4 src/repo/rsync/upload.ml
@@ -14,7 +14,9 @@ let (/) = Filename.concat
let rsync dir =
let err =
- Run.command "rsync -ar upload/%s/ %s/" dir (remote_address / dir) in
+ Run.command [
+ "rsync" ; "-ar" ; ("upload" / dir / "") ; (remote_address / dir / "")
+ ] in
if err <> 0 then
Globals.error_and_exit "rsync (%s) command failed" dir
View
2 src/repo/server/update.ml
@@ -10,6 +10,8 @@ open Types
open Protocol
open Unix
+let log fmt = Globals.log Sys.argv.(0) fmt
+
let local_path = Path.R.of_path (Dirname.of_string (Run.cwd ()))
let remote_address =
try inet_addr_of_string Sys.argv.(1)
View
4 src/repositories.ml
@@ -22,7 +22,7 @@ let run cmd repo args =
let path = Path.R.root (Path.R.create repo) in
let cmd = Printf.sprintf "opam-%s-%s" (Repository.kind repo) cmd in
let i = Run.in_dir (Dirname.to_string path) (fun () ->
- Run.command "%s %s %s" cmd (Repository.address repo) (String.concat " " args);
+ Run.command ( cmd :: Repository.address repo :: args );
) in
if i <> 0 then
Globals.error_and_exit "%s failed" cmd
@@ -52,7 +52,7 @@ module Raw = struct
| [`A ; `R] | [`R ; `A] ->
let dst = Filename.to_string dst in
let err =
- Run.command "rsync -ar %s %s" src dst in
+ Run.command [ "rsync" ; "-ar" ; src ; dst ] in
if err <> 0 then
Globals.error_and_exit "rsync (%S, %S) command failed (%d)" src dst err
| _ -> failwith "TODO"
View
126 src/run.ml
@@ -15,7 +15,17 @@
let log fmt = Globals.log "RUN" fmt
-let tmp_dir = Filename.concat Filename.temp_dir_name "opam-archives"
+let (/) = Filename.concat
+
+let tmp_dir = Filename.temp_dir_name / "opam-archives"
+
+let lock_file () =
+ !Globals.root_path / "opam.lock"
+
+let log_file () =
+ Random.self_init ();
+ let f = "command" ^ string_of_int (Random.int 2048) in
+ !Globals.root_path / "log" / f
let mkdir dir =
log "mkdir %s" dir;
@@ -125,34 +135,6 @@ let rec root path =
else
root d
-(* XXX: the function might block for ever for some channels kinds *)
-let read_lines ic =
- let lines = ref [] in
- begin
- try
- while true do
- let line = input_line ic in
- lines := line :: !lines;
- done
- with _ -> ()
- end;
- List.rev !lines
-
-let read_command_output_ cmd =
- let ic = Unix.open_process_in cmd in
- let lines = read_lines ic in
- if Unix.close_process_in ic <> Unix.WEXITED 0 then
- None
- else
- Some lines
-
-let read_command_output fmt =
- Printf.kprintf (fun cmd ->
- match read_command_output_ cmd with
- | None -> Globals.error_and_exit "command %s failed" cmd
- | Some lines -> lines
- ) fmt
-
(** Expand '..' and '.' *)
let normalize s =
if Sys.file_exists s then
@@ -161,7 +143,6 @@ let normalize s =
s
let real_path p =
- let (/) = Filename.concat in
let dir = normalize (Filename.dirname p) in
let dir =
if Filename.is_relative dir then
@@ -193,57 +174,60 @@ let add_path bins =
path := new_path;
done;
env, !path
-
-let command_with_path bins fmt =
- Printf.kprintf (fun cmd ->
- let env, path = add_path bins in
- log "cwd=%s path=%s %s" (Unix.getcwd ()) path cmd;
- let (o,i,e as chans) = Unix.open_process_full cmd env in
- (* we MUST read the input_channels otherwise [close_process] will fail *)
- let err = read_lines e in
- let out = read_lines o in
- let str () =
- Printf.sprintf "out: %s\nerr: %s"
- (String.concat "\n" out)
- (String.concat "\n" err) in
- let msg () =
- Globals.msg "%s\n" (str ()) in
- match Unix.close_process_full chans with
- | Unix.WEXITED 0 -> 0
- | Unix.WEXITED i -> msg (); i
- | _ -> msg (); 1
- ) fmt
-
-let command fmt =
- Printf.kprintf (fun str ->
- log "cwd=%s '%s'" (Unix.getcwd ()) str;
- Sys.command str;
- ) fmt
-
-let fold f = List.fold_left (function 0 -> f | err -> fun _ -> err) 0
+
+type command = string list
+
+let run_process ?(add_to_path = []) = function
+ | [] -> invalid_arg "run_process"
+ | cmd :: args ->
+ let env, path = add_path add_to_path in
+ let name = log_file () in
+ mkdir (Filename.dirname name);
+ let str = String.concat " " (cmd :: args) in
+ log "cwd=%s path=%s %s" (Unix.getcwd ()) path str;
+ let r = Process.run ~env ~name cmd args in
+ if Process.is_failure r then (
+ Globals.error "Command %S failed (see %s.{info,err,out})" str name;
+ List.iter (Globals.error "%s") r.Process.r_stderr;
+ ) else
+ Process.clean_files r;
+ r
+
+let command ?(add_to_path = []) cmd =
+ let r = run_process ~add_to_path cmd in
+ r.Process.r_code
+
+let fold f =
+ List.fold_left (fun err cmd ->
+ match err, cmd with
+ | _ , [] -> err
+ | 0 , _ -> f cmd
+ | err, _ -> err
+ ) 0
let commands ?(add_to_path = []) =
- fold
- (match add_to_path with
- | [] -> command "%s"
- | _ -> command_with_path add_to_path "%s")
+ fold (command ~add_to_path)
+
+let read_command_output ?(add_to_path = []) cmd =
+ let r = run_process ~add_to_path cmd in
+ r.Process.r_stdout
let is_archive file =
List.fold_left
(function
| Some s -> fun _ -> Some s
| None -> fun (ext, c) ->
if List.exists (Filename.check_suffix file) ext then
- Some (command "tar xf%c %s -C %s" c file)
+ Some (fun dir -> command [ "tar" ; "xf"^c ; file; "-C" ; dir ])
else
None)
None
- [ [ "tar.gz" ; "tgz" ], 'z'
- ; [ "tar.bz2" ; "tbz" ], 'j' ]
+ [ [ "tar.gz" ; "tgz" ], "z"
+ ; [ "tar.bz2" ; "tbz" ], "j" ]
let extract file dst =
log "untar %s" file;
- let files = read_command_output "tar tf %s" file in
+ let files = read_command_output [ "tar" ; "tf" ; file ] in
log "%s contains %d files: %s" file (List.length files) (String.concat ", " files);
mkdir tmp_dir;
let err =
@@ -254,11 +238,11 @@ let extract file dst =
Globals.error_and_exit "Error while extracting %s" file
else
let aux accu name =
- if not (Sys.is_directory (Filename.concat tmp_dir name)) then
+ if not (Sys.is_directory (tmp_dir / name)) then
let root = root name in
let n = String.length root in
let rest = String.sub name n (String.length name - n) in
- (Filename.concat tmp_dir name, dst ^ rest) :: accu
+ (tmp_dir / name, dst ^ rest) :: accu
else
accu in
let moves = List.fold_left aux [] files in
@@ -274,11 +258,9 @@ let link src dst =
remove_file dst;
Unix.link src dst
-let file () = Filename.concat !Globals.root_path "opam.lock"
-
let flock () =
let l = ref 0 in
- let file = file () in
+ let file = lock_file () in
let id = string_of_int (Unix.getpid ()) in
let max_l = 5 in
let rec loop () =
@@ -306,7 +288,7 @@ let flock () =
let funlock () =
let id = string_of_int (Unix.getpid ()) in
- let file = file () in
+ let file = lock_file () in
if Sys.file_exists file then begin
let ic = open_in file in
let s = input_line ic in
View
13 src/run.mli
@@ -55,17 +55,20 @@ val files: string -> string list
(** [files dir] returns the directories in the directory [dir] *)
val directories: string -> string list
-(** [command fmt] executes the command [fmt] *)
-val command: ('a, unit, string, int) format4 -> 'a
+(** a command is a list of words *)
+type command = string list
+
+(** [command cmd] executes the command [cmd]. Return the exit code. *)
+val command: ?add_to_path:string list -> command -> int
(** [commands ~add_to_path cmds] executes the commands [cmds]
in a context where $PATH contains [add_to_path] at the beginning.
It stops whenever one command fails. *)
-val commands: ?add_to_path:string list -> string list -> int
+val commands: ?add_to_path:string list -> command list -> int
-(** [read_command_output fmt] executes the command [fmt] and return
+(** [read_command_output cmd] executes the command [cmd] and return
the lines from stdout *)
-val read_command_output: ('a, unit, string, string list) format4 -> 'a
+val read_command_output: ?add_to_path:string list -> command -> string list
(** [extract filename dirname] untar the archive [filename] to
[dirname] *)
View
17 src/scripts/opam_mk_repo.ml
@@ -75,8 +75,8 @@ let tmp_dir nv =
let wget src =
match Globals.os with
- | Globals.Darwin -> Printf.sprintf "ftp %s" src
- | _ -> Printf.sprintf "wget %s" src
+ | Globals.Darwin -> [ "ftp" ; src ]
+ | _ -> [ "wget"; src ]
let archive_name src =
let name = F.basename src in
@@ -90,9 +90,9 @@ let archive_name src =
let mv src =
let name = archive_name src in
if (F.basename src) = name then
- ""
+ []
else
- Printf.sprintf "mv %s %s" (F.basename src) name
+ [ "mv" ; F.basename src ; name ]
let () =
Dirname.mkdir (Path.R.archive_dir root);
@@ -116,12 +116,9 @@ let () =
List.iter (fun f ->
Filename.copy_in f tmp_dir
) (files nv);
- let err = Dirname.exec (Dirname.of_string tmp_dir0)
- [ Printf.sprintf
- "tar cz %s/ > %s"
- (NV.to_string nv)
- (Filename.to_string (Path.R.archive root nv))
- ] in
+ let err = Dirname.exec (Dirname.of_string tmp_dir0) [
+ [ "tar" ; "cz" ; NV.to_string nv ; ">" ; Filename.to_string (Path.R.archive root nv) ]
+ ] in
if err <> 0 then
Globals.error_and_exit "Cannot compress %s" (Dirname.to_string tmp_dir)
) opams
View
2 src/solver.ml
@@ -203,7 +203,7 @@ module CudfDiff : sig
end = struct
module Cudf_set = struct
- module S = Set.MK (Common.CudfAdd.Cudf_set)
+ module S = Utils.Set.MK (Common.CudfAdd.Cudf_set)
let to_string s =
Printf.sprintf "{%s}"
View
35 src/types.ml
@@ -15,28 +15,7 @@
let log fmt = Globals.log "TYPES" fmt
-module Set = struct
- module type S = sig
- include Set.S
-
- (** Like [choose] and [Assert_failure _] in case the set is not a singleton. *)
- val choose_one : t -> elt
- end
-
- module MK (S : Set.S) = struct
- include S
-
- let choose_one s =
- match elements s with
- | [x] -> x
- | [] -> raise Not_found
- | _ -> assert false
- end
-
- module Make (O : Set.OrderedType) = struct
- include MK (Set.Make (O))
- end
-end
+open Utils
module type Abstract = sig
type t
@@ -68,7 +47,7 @@ module Dirname: sig
val cwd: unit -> t
val rmdir: t -> unit
val mkdir: t -> unit
- val exec: t -> ?add_to_path:t list -> string list -> int
+ val exec: t -> ?add_to_path:t list -> string list list -> int
val chdir: t -> unit
val basename: t -> string
val exists: t -> bool
@@ -92,7 +71,8 @@ end = struct
Run.in_dir (to_string dirname)
(fun () ->
Run.commands
- ~add_to_path:(List.map of_string add_to_path) cmds)
+ ~add_to_path:(List.map of_string add_to_path)
+ cmds)
let chdir dirname =
Run.chdir (to_string dirname)
@@ -370,7 +350,12 @@ end = struct
}
let create ~name ~kind ~address =
- let address = Run.real_path address in
+ let address =
+ if Pcre.pmatch (Pcre.regexp "://") address
+ || Utils.is_inet_address address then
+ address
+ else
+ Run.real_path address in
{ name; kind; address }
let of_string _ =
View
18 src/types.mli
@@ -15,21 +15,7 @@
(** The OPAM types and then main function which operates on them. *)
-(** {2 Pervasives} *)
-
-module Set : sig
- module type S = sig
- include Set.S
-
- (** Like [choose] and [Assert_failure _] in case the set is not a singleton. *)
- val choose_one : t -> elt
- end
-
- module MK : functor (S : Set.S) -> S
- with type t = S.t with type elt = S.elt
- module Make : functor (Ord : Set.OrderedType) -> S
- with type elt = Ord.t
-end
+open Utils
(** {2 Abstract types} *)
@@ -69,7 +55,7 @@ module Dirname: sig
val mkdir: t -> unit
(** Execute a list of commands in a given directory *)
- val exec: t -> ?add_to_path:t list -> string list -> int
+ val exec: t -> ?add_to_path:t list -> string list list -> int
(** Change the current directory *)
val chdir: t -> unit
View
29 src/utils.ml
@@ -45,3 +45,32 @@ let string_strip str =
decr l;
done;
String.sub str p (!l - p + 1)
+
+let is_inet_address address =
+ try
+ let (_:Unix.inet_addr) = Unix.inet_addr_of_string address
+ in true
+ with _ -> false
+
+module Set = struct
+ module type S = sig
+ include Set.S
+
+ (* Like [choose] and [Assert_failure _] in case the set is not a singleton. *)
+ val choose_one : t -> elt
+ end
+
+ module MK (S : Set.S) = struct
+ include S
+
+ let choose_one s =
+ match elements s with
+ | [x] -> x
+ | [] -> raise Not_found
+ | _ -> assert false
+ end
+
+ module Make (O : Set.OrderedType) = struct
+ include MK (Set.Make (O))
+ end
+end

0 comments on commit 54edd49

Please sign in to comment.
Something went wrong with that request. Please try again.