Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

[pin] Now pin uses the same code path as other download operations. T…

…his means that we could pin a package to a remote git repository if needed.
  • Loading branch information...
commit d894f34df447466ab4e32ed65b285aea916b9144 1 parent b43be60
@samoht samoht authored
View
208 src/client.ml
@@ -490,6 +490,45 @@ let update_repositories t ~show_compilers repos =
if not (Filename.exists default_compiler) then
create_default_compiler_description t
+let find_repo t nv =
+ log "find_repo %s" (NV.to_string nv);
+ let name = NV.name nv in
+ let rec aux = function
+ | [] -> None
+ | r :: repo_s ->
+ let repo = find_repository t r in
+ let repo_p = Path.R.create repo in
+ let opam_f = Path.R.opam repo_p nv in
+ if Filename.exists opam_f then (
+ Some (repo_p, repo)
+ ) else
+ aux repo_s in
+ if N.Map.mem name t.repo_index then
+ aux (N.Map.find name t.repo_index)
+ else
+ None
+
+let mem_repo t nv =
+ find_repo t nv <> None
+
+let with_repo t nv fn =
+ match find_repo t nv with
+ | None ->
+ Globals.error_and_exit
+ "Unable to find a repository containing %s"
+ (NV.to_string nv)
+ | Some (repo_p, repo) -> fn repo_p repo
+
+let update_pinned_package t nv pin =
+ let kind = kind_of_pin_option pin in
+ let path = Dirname.raw (path_of_pin_option pin) in
+ let module B = (val Repositories.find_backend kind: Repositories.BACKEND) in
+ let build = Path.C.build t.compiler nv in
+ match B.download_dir nv ~dst:build path with
+ | Up_to_date _ -> None
+ | Result _
+ | Not_available _ -> Some nv
+
let update_packages t ~show_packages repos =
log "update_packages";
(* Update the pinned packages *)
@@ -497,25 +536,13 @@ let update_packages t ~show_packages repos =
NV.Set.of_list (
Utils.filter_map
(function
- | n, Path p ->
- if mem_installed_package_by_name t n then
- let nv = find_installed_package_by_name t n in
- let build = Path.C.build t.compiler nv in
- Globals.msg "Synchronizing %s with %s ...\n" (NV.to_string nv) (Dirname.to_string p);
- (* XXX: make it more generic *)
- if Dirname.exists build then
- try
- let lines = Run.read_command_output
- [ "rsync"; "-arv"; "--exclude"; "'.git/*'"; Dirname.to_string p ^ "/"; Dirname.to_string build ] in
- match Utils.rsync_trim lines with
- | [] -> None
- | l -> Some nv
- with _ ->
- None
- else
- None
- else
- None
+ | n, (Path p | Git p as k) ->
+ if mem_installed_package_by_name t n then
+ let nv = find_installed_package_by_name t n in
+ Globals.msg "Synchronizing with %s ...\n" (Dirname.to_string p);
+ update_pinned_package t nv k
+ else
+ None
| _ -> None)
(N.Map.bindings t.pinned)) in
@@ -1138,40 +1165,12 @@ let pinned_path t nv =
let name = NV.name nv in
if N.Map.mem name t.pinned then
match N.Map.find name t.pinned with
- | Path p -> Some p
- | _ -> None
+ | Path _
+ | Git _ as k -> Some k
+ | _ -> None
else
None
-let find_repo t nv =
- log "find_repo %s" (NV.to_string nv);
- let name = NV.name nv in
- let rec aux = function
- | [] -> None
- | r :: repo_s ->
- let repo = find_repository t r in
- let repo_p = Path.R.create repo in
- let opam_f = Path.R.opam repo_p nv in
- if Filename.exists opam_f then (
- Some (repo_p, repo)
- ) else
- aux repo_s in
- if N.Map.mem name t.repo_index then
- aux (N.Map.find name t.repo_index)
- else
- None
-
-let mem_repo t nv =
- find_repo t nv <> None
-
-let with_repo t nv fn =
- match find_repo t nv with
- | None ->
- Globals.error_and_exit
- "Unable to find a repository containing %s"
- (NV.to_string nv)
- | Some (repo_p, repo) -> fn repo_p repo
-
let get_archive t nv =
let aux repo_p repo =
Repositories.download repo nv;
@@ -1192,24 +1191,25 @@ let get_files t nv =
let extract_package t nv =
log "extract_package: %s" (NV.to_string nv);
let p_build = Path.C.build t.compiler nv in
- Dirname.rmdir p_build;
match pinned_path t nv with
- | None ->
- (match get_archive t nv with
- | None -> None
- | Some archive ->
- Globals.msg "Extracting %s ...\n" (Filename.to_string archive);
- Filename.extract archive p_build;
- Some p_build)
- | Some p ->
- (* XXX: make it a bit more generic ... *)
- Globals.msg "Synchronizing %s with %s ...\n" (NV.to_string nv) (Dirname.to_string p);
- Run.command [ "rsync"; "-arv"; "--exclude"; "'.git/*'"; Dirname.to_string p ^ "/"; Dirname.to_string p_build ];
- let files = get_files t nv in
- List.iter (fun f -> Filename.copy_in f p_build) files;
+ | Some (Git p| Path p as pin) ->
+ Globals.msg "Synchronizing pinned package ...\n";
+ ignore (update_pinned_package t nv pin);
+ Dirname.mkdir p_build;
+ let _files = with_repo t nv (fun repo _ ->
+ Dirname.in_dir p_build (fun () -> Repositories.copy_files repo nv)
+ ) in
+ Some p_build
+ | _ ->
+ Dirname.rmdir p_build;
+ match get_archive t nv with
+ | None -> None
+ | Some archive ->
+ Globals.msg "Extracting %s ...\n" (Filename.to_string archive);
+ Filename.extract archive p_build;
Some p_build
-let proceed_todelete t nv =
+let proceed_todelete ~rm_build t nv =
log "deleting %s" (NV.to_string nv);
Globals.msg "Uninstalling %s ...\n" (NV.to_string nv);
let name = NV.name nv in
@@ -1219,25 +1219,27 @@ let proceed_todelete t nv =
if Filename.exists opam_f then (
let opam = OpamFile.OPAM.read opam_f in
let remove = substitute_commands t (OpamFile.OPAM.remove opam) in
- let remove = filter_commands t remove in
- let p_build = Path.C.build t.compiler nv in
- (* We try to run the remove scripts in the folder where it was extracted
- If it does not exist, we try to download and extract the archive again,
- if that fails, we don't really care. *)
- if not (Dirname.exists p_build) && mem_repo t nv then (
- try ignore (extract_package t nv)
- with _ -> Dirname.mkdir p_build;
- );
- begin
+ match filter_commands t remove with
+(* | [] -> () *)
+ | remove ->
+ let p_build = Path.C.build t.compiler nv in
+ (* We try to run the remove scripts in the folder where it was extracted
+ If it does not exist, we try to download and extract the archive again,
+ if that fails, we don't really care. *)
+ if not (Dirname.exists p_build) && mem_repo t nv then (
+ try ignore (extract_package t nv)
+ with _ -> Dirname.mkdir p_build;
+ );
try Dirname.exec ~add_to_path:[Path.C.bin t.compiler] p_build remove
with _ -> ();
- end;
- Dirname.rmdir p_build;
);
(* Remove the libraries *)
Dirname.rmdir (Path.C.lib t.compiler name);
- Dirname.rmdir (Path.C.build t.compiler nv);
+
+ (* Remove build/<package> if requested *)
+ if rm_build then
+ Dirname.rmdir (Path.C.build t.compiler nv);
(* Clean-up the repositories *)
log "Cleaning-up the repositories";
@@ -1371,7 +1373,7 @@ let proceed_tochange t nv_old nv =
(* First, uninstall any previous version *)
(match nv_old with
- | Some nv_old -> proceed_todelete t nv_old
+ | Some nv_old -> proceed_todelete ~rm_build:true t nv_old
| None -> ());
let opam = OpamFile.OPAM.read (Path.G.opam t.global nv) in
@@ -1380,13 +1382,11 @@ let proceed_tochange t nv_old nv =
let env0 = get_env t in
let env = update_env t env0 (OpamFile.OPAM.build_env opam) in
- (* Prepare the package for the build.
- This function is run before the build and after an error has
- occured, to help debugging. *)
- let prepare_package () =
+ (* Prepare the package for the build. *)
+ let p_build =
(* First, untar the archive *)
match extract_package t nv with
- | None -> None
+ | None -> Path.C.root t.compiler
| Some p_build ->
(* Substitute the configuration files. We should be in the right
@@ -1400,11 +1400,7 @@ let proceed_tochange t nv_old nv =
let env_f = Path.C.build_env t.compiler nv in
OpamFile.Env.write env_f env.new_env;
- Some p_build in
-
- let p_build = match prepare_package () with
- | None -> Path.C.root t.compiler
- | Some p_build -> p_build in
+ p_build in
(* Call the build script and copy the output files *)
let commands = substitute_commands t (OpamFile.OPAM.build opam) in
@@ -1422,10 +1418,8 @@ let proceed_tochange t nv_old nv =
commands;
proceed_toinstall t nv;
with e ->
- proceed_todelete t nv;
- let p_build = match prepare_package () with
- | None -> Path.C.root t.compiler
- | Some p_build -> p_build in
+ (* We keep the build dir to help debugging *)
+ proceed_todelete ~rm_build:false t nv;
begin match nv_old with
| None ->
Globals.error
@@ -1680,7 +1674,7 @@ module Heuristic = struct
(fun nv ->
if NV.Set.mem nv !installed then begin
try
- proceed_todelete t nv;
+ proceed_todelete ~rm_build:true t nv;
installed := NV.Set.remove nv !installed;
write_installed ()
with _ ->
@@ -1742,7 +1736,7 @@ module Heuristic = struct
(Solver.P [debpkg_of_nv `remove t nv]) in
let depends = NV.Set.of_list (List.rev_map NV.of_dpkg depends) in
let depends = NV.Set.filter (fun nv -> NV.Set.mem nv t.installed) depends in
- NV.Set.iter (proceed_todelete t) depends;
+ NV.Set.iter (proceed_todelete ~rm_build:true t) depends;
installed := NV.Set.diff !installed depends;
write_installed ();
| To_delete nv -> assert false in
@@ -2025,7 +2019,6 @@ let install names =
let name = NV.name nv in
NV.Set.exists (fun nv -> NV.name nv = name) t.installed
) depends in
- NV.Set.iter (fun nv -> log "might_change<2>: %s" (NV.to_string nv)) depends;
let name_might_change = List.map NV.name (NV.Set.elements depends) in
@@ -2034,7 +2027,6 @@ let install names =
let pkg_might_change f_h =
let pkgs = Heuristic.get_installed t f_h in
let pkgs = N.Map.filter (fun n _ -> List.mem n name_might_change) pkgs in
- N.Map.iter (fun n _ -> log "might_change: %s" (N.to_string n)) pkgs;
N.Map.values pkgs in
(* The collection of packages which should change very rarely (so the NOT is a bit misleading
@@ -2044,7 +2036,6 @@ let install names =
let pkgs = Heuristic.get_installed t f_h in
let pkgs = N.Map.filter (fun n _ -> not (List.mem n name_new)) pkgs in
let pkgs = N.Map.filter (fun n _ -> not (List.mem n name_might_change)) pkgs in
- N.Map.iter (fun n _ -> log "not_change: %s" (N.to_string n)) pkgs;
N.Map.values pkgs in
let pkg_new =
@@ -2101,7 +2092,7 @@ let remove names =
) ([], N.Set.empty, []) wish_remove in
if does_not_exist <> [] then (
- List.iter (proceed_todelete t) does_not_exist;
+ List.iter (proceed_todelete ~rm_build:true t) does_not_exist;
let installed_f = Path.C.installed t.compiler in
let installed = OpamFile.Installed.read installed_f in
let installed = NV.Set.filter (fun nv -> not (List.mem nv does_not_exist)) installed in
@@ -2493,8 +2484,13 @@ let pin action =
let t = load_state () in
let pin_f = Path.C.pinned t.compiler in
let pins = OpamFile.Pinned.safe_read pin_f in
- let update_config pins = OpamFile.Pinned.write pin_f pins in
let name = action.pin_package in
+ let update_config pins =
+ V.Set.iter (fun version ->
+ let nv = NV.create name version in
+ Dirname.rmdir (Path.C.build t.compiler nv)
+ ) (Path.G.available_versions t.global name);
+ OpamFile.Pinned.write pin_f pins in
if mem_installed_package_by_name t name then (
let reinstall_f = Path.C.reinstall t.compiler in
let reinstall = OpamFile.Reinstall.safe_read reinstall_f in
@@ -2508,17 +2504,21 @@ let pin action =
let current = N.Map.find name pins in
Globals.error_and_exit "Cannot pin %s to %s, it is already associated to %s."
(N.to_string name)
- (string_of_pin_option action.pin_arg)
- (string_of_pin_option current);
+ (path_of_pin_option action.pin_arg)
+ (path_of_pin_option current);
);
- log "Adding %s => %s" (string_of_pin_option action.pin_arg) (N.to_string name);
+ log "Adding %s(%s) => %s"
+ (path_of_pin_option action.pin_arg)
+ (kind_of_pin_option action.pin_arg)
+ (N.to_string name);
update_config (N.Map.add name action.pin_arg pins)
let pin_list () =
log "pin_list";
let t = load_state () in
let pins = OpamFile.Pinned.safe_read (Path.C.pinned t.compiler) in
- let print n a = Globals.msg "%-20s %s\n" (N.to_string n) (string_of_pin_option a) in
+ let print n a =
+ Globals.msg "%-20s %-8s %s\n" (N.to_string n) (kind_of_pin_option a) (path_of_pin_option a) in
N.Map.iter print pins
let compiler_list () =
View
7 src/opam.ml
@@ -412,18 +412,21 @@ let switch =
(* opam pin [-list|<package> <version>|<package> <path>] *)
let pin =
let list = ref false in
+ let kind = ref None in
+ let set_kind s = kind := Some s in
{
name = "pin";
usage = "<package> [<version>|<url>|none]";
synopsis = "Pin a given package to a specific version";
help = "";
specs = [
- ("-list" , Arg.Set list, " List the current status of pinned packages");
+ ("-list", Arg.Set list , " List the current status of pinned packages");
+ ("-kind", Arg.String set_kind, " Force the pin action (options are: 'git', 'rsync', 'version'");
];
anon;
main = parse_args (function
| [] when !list -> Client.pin_list ()
- | [name; arg] -> Client.pin { pin_package = N.of_string name; pin_arg = pin_option_of_string arg }
+ | [name; arg] -> Client.pin { pin_package = N.of_string name; pin_arg = pin_option_of_string ?kind:!kind arg }
| _ -> bad_argument "pin" "Wrong arguments")
}
View
7 src/opamFile.ml
@@ -283,12 +283,13 @@ module Pinned = struct
let of_string filename str =
let m = Repo_index.of_string filename str in
N.Map.map (function
- | [x] -> pin_option_of_string x
- | _ -> Globals.error_and_exit "too many pinning options"
+ | [x] -> pin_option_of_string x
+ | [k;x] -> pin_option_of_string ?kind:(Some k) x
+ | _ -> Globals.error_and_exit "too many pinning options"
) m
let to_string filename map =
- let aux x = [ string_of_pin_option x ] in
+ let aux x = [ kind_of_pin_option x; path_of_pin_option x ] in
Repo_index.to_string filename (N.Map.map aux map)
end
View
2  src/repo/curl.ml
@@ -187,7 +187,7 @@ module B = struct
let not_supported action =
failwith (action ^ ": not supported by CURL backend")
- let download_dir nv dir =
+ let download_dir nv ?dst dir =
not_supported ("Downloading " ^ Dirname.to_string dir)
let upload_dir ~address remote_dir =
View
11 src/repo/git.ml
@@ -69,15 +69,18 @@ module B = struct
let file = Path.R.tmp_dir local_repo nv // Basename.to_string basename in
check_file file
- let rec download_dir nv remote_address =
+ let rec download_dir nv ?dst remote_address =
let local_repo = Path.R.cwd () in
- let basename = Dirname.basename remote_address in
- let dir = Path.R.tmp_dir local_repo nv / Basename.to_string basename in
+ let dir = match dst with
+ | None ->
+ let basename = Basename.to_string (Dirname.basename remote_address) in
+ Path.R.tmp_dir local_repo nv / basename
+ | Some d -> d in
match check_updates dir remote_address with
| None ->
Dirname.mkdir dir;
Dirname.in_dir dir (fun () -> git_init remote_address);
- download_dir nv remote_address
+ download_dir nv ?dst remote_address
| Some f ->
if Filename.Set.empty = f then
Up_to_date dir
View
29 src/repo/rsync.ml
@@ -10,13 +10,10 @@ let rsync ?(delete=true) src dst =
Run.mkdir dst;
let delete = if delete then ["--delete"] else [] in
try
- let lines = Run.read_command_output (["rsync" ; "-arv"; src; dst] @ delete) in
+ let lines = Run.read_command_output (["rsync" ; "-arv"; "--exclude"; ".git/*"; src; dst] @ delete) in
match Utils.rsync_trim lines with
| [] -> Up_to_date []
- | lines ->
- let cwd = Unix.getcwd () in
- List.iter (fun l -> log "updated: %s %s" cwd l) lines;
- Result lines
+ | lines -> Result lines
with _ ->
Not_available
) else
@@ -25,20 +22,10 @@ let rsync ?(delete=true) src dst =
let rsync_dirs ?delete src dst =
let src_s = Dirname.to_string src + "" in
let dst_s = Dirname.to_string dst in
- let dst_files0 = Filename.rec_list dst in
match rsync ?delete src_s dst_s with
| Not_available -> Not_available
| Up_to_date _ -> Up_to_date []
- | Result lines ->
- let src_files = Filename.rec_list src in
- let dst_files = Filename.rec_list dst in
- if delete = Some true && List.length src_files <> List.length dst_files then (
- List.iter (fun f -> Globals.msg "src-file: %s\n" (Filename.to_string f)) src_files;
- List.iter (fun f -> Globals.msg "dst-file0: %s\n" (Filename.to_string f)) dst_files0;
- List.iter (fun f -> Globals.msg "dst-file: %s\n" (Filename.to_string f)) dst_files;
- Globals.error_and_exit "rsync_dir failed!"
- );
- Result lines
+ | Result lines -> Result lines
let rsync_file src dst =
log "rsync_file src=%s dst=%s" (Filename.to_string src) (Filename.to_string dst);
@@ -66,10 +53,14 @@ module B = struct
let local_file = Filename.create tmp_dir (Filename.basename remote_file) in
rsync_file remote_file local_file
- let download_dir nv remote_dir =
+ let download_dir nv ?dst remote_dir =
let local_repo = Path.R.of_dirname (Dirname.cwd ()) in
- let tmp_dir = Path.R.tmp_dir local_repo nv in
- let local_dir = tmp_dir / Basename.to_string (Dirname.basename remote_dir) in
+ let local_dir = match dst with
+ | None ->
+ let tmp_dir = Path.R.tmp_dir local_repo nv in
+ let basename = Basename.to_string (Dirname.basename remote_dir) in
+ tmp_dir / basename
+ | Some d -> d in
match rsync_dirs ~delete:true remote_dir local_dir with
| Up_to_date _ -> Up_to_date local_dir
| Result _ -> Result local_dir
View
60 src/repositories.ml
@@ -25,7 +25,7 @@ module type BACKEND = sig
val update: address -> Filename.Set.t
val download_archive: address -> nv -> filename download
val download_file: nv -> filename -> filename download
- val download_dir: nv -> dirname -> dirname download
+ val download_dir: nv -> ?dst:dirname -> dirname -> dirname download
val upload_dir: address:address -> dirname -> Filename.Set.t
end
@@ -104,10 +104,10 @@ let download_file ~gener_digest k nv f c =
map rename (B.download_file nv f)
(* Download directory d in the current directory *)
-let download_dir k nv d =
+let download_dir k nv ?dst d =
log "download_dir %s %s %s" k (NV.to_string nv) (Dirname.to_string d);
let module B = (val find_backend_by_kind k: BACKEND) in
- B.download_dir nv d
+ B.download_dir nv ?dst d
(* Download either a file or a directory in the current directory *)
let download_one ?(gener_digest = false) k nv url checksum =
@@ -131,7 +131,28 @@ let download_archive r nv =
let module B = (val find_backend r: BACKEND) in
B.download_archive (Repository.address r) nv
-let make_archive ?(gener_digest = false) nv =
+(* Copy the file in local_repo in current dir *)
+let copy_files local_repo nv =
+ let local_dir = Dirname.cwd () in
+ (* Eventually add the <package>/files/* to the extracted dir *)
+ log "Adding the files to the archive";
+ let files = Path.R.available_files local_repo nv in
+ if files <> [] then (
+ if not (Dirname.exists local_dir) then
+ Dirname.mkdir local_dir;
+ List.iter (fun f ->
+ let dst = local_dir // Basename.to_string (Filename.basename f) in
+ if Filename.exists dst then
+ Globals.warning
+ "Skipping %s as it already exists in %s"
+ (Filename.to_string f)
+ (Dirname.to_string local_dir)
+ else
+ Filename.copy_in f local_dir) files;
+ );
+ Filename.Set.of_list files
+
+let make_archive ?(gener_digest=false) ?local_path nv =
(* download the archive upstream if the upstream address is
specified *)
let local_repo = Path.R.cwd () in
@@ -144,7 +165,7 @@ let make_archive ?(gener_digest = false) nv =
Dirname.with_tmp_dir (fun extract_root ->
let extract_dir = extract_root / NV.to_string nv in
- if Filename.exists url_f then (
+ if local_path = None && Filename.exists url_f then (
let url_file = OpamFile.URL.read url_f in
let checksum = OpamFile.URL.checksum url_file in
let kind = match OpamFile.URL.kind url_file with
@@ -181,30 +202,19 @@ let make_archive ?(gener_digest = false) nv =
Dirname.copy download_dir extract_dir
);
+ let extract_dir = match local_path with
+ | None -> extract_dir
+ | Some p -> p in
+
(* Eventually add the <package>/files/* to the extracted dir *)
- log "Adding the files to the archive";
- let files = Path.R.available_files local_repo nv in
- if files <> [] then (
- if not (Dirname.exists extract_dir) then
- Dirname.mkdir extract_dir;
- List.iter (fun f ->
- let dst = extract_dir // Basename.to_string (Filename.basename f) in
- if Filename.exists dst then
- Globals.warning
- "Skipping %s as it already exists in %s\n"
- (Filename.to_string f)
- (Dirname.to_string extract_dir)
- else
- Filename.copy_in f extract_dir) files;
- );
+ let files =
+ Dirname.in_dir extract_dir (fun () -> copy_files local_repo nv) in
(* And finally create the final archive *)
- (* XXX: we should add a suffix to the version to show that
- the archive has been repacked by opam *)
- if files <> [] || Filename.exists url_f then (
+ if local_path <> None || not (Filename.Set.is_empty files) || Filename.exists url_f then (
Dirname.mkdir (Path.R.archives_dir local_repo);
let local_archive = Path.R.archive local_repo nv in
- log "Creating the archive files in %s" (Filename.to_string local_archive);
+ Globals.msg "Creating the archive file in %s\n" (Filename.to_string local_archive);
Dirname.exec extract_root [
[ "tar" ; "czf" ; Filename.to_string local_archive ; NV.to_string nv ]
]
@@ -270,3 +280,5 @@ let update r =
let updated = NV.Set.union updated_packages updated_cached_packages in
OpamFile.Updated.write (Path.R.updated local_repo) updated
+
+let find_backend = find_backend_by_kind
View
16 src/repositories.mli
@@ -65,7 +65,7 @@ module type BACKEND = sig
(** Download a (remote) directory and return the local path to the
downloaded directory. If needed, the function can use {i
$repo/tmp/$nv/} to store transient states between downloads. *)
- val download_dir: nv -> dirname -> dirname download
+ val download_dir: nv -> ?dst:dirname -> dirname -> dirname download
(** Upload the content of the current directory to the directory
given as argument. Return the local paths corresponding to the
@@ -79,9 +79,15 @@ type kind = string
(** Register a repository backend *)
val register_backend: kind -> (module BACKEND) -> unit
+(** Find a backend *)
+val find_backend: kind -> (module BACKEND)
+
+(** Copy the additional package files in the current dir *)
+val copy_files: Path.R.t -> nv -> Filename.Set.t
+
(** [make_archive repo_kind nv] build ./$nv.tar.gz, assuming the
- repository kind is [repo_kind].
- By default, the digest that appear in
- {i $NAME.$VERSION/url} is not modified,
+ repository kind is [repo_kind].
+ By default, the digest that appear in
+ {i $NAME.$VERSION/url} is not modified,
unless [gener_digest = true] is given. *)
-val make_archive: ?gener_digest:bool -> nv -> unit
+val make_archive: ?gener_digest:bool -> ?local_path:dirname -> nv -> unit
View
43 src/types.ml
@@ -170,6 +170,7 @@ end = struct
Run.with_tmp_dir (fun dir -> fn (of_string dir))
let rmdir dirname =
+ log "rmdir %s" (to_string dirname);
Run.remove (to_string dirname)
let cwd () =
@@ -900,31 +901,51 @@ type config_option = {
type pin_option =
| Version of version
| Path of dirname
+ | Git of dirname
| Unpin
-let pin_option_of_string s =
- let d = Run.real_path s in
- if s = "none" then
- Unpin
- else if Sys.file_exists d then
- Path (Dirname.of_string s)
- else
- Version (V.of_string s)
+let pin_option_of_string ?kind s =
+ match kind with
+ | Some "version" -> Version (V.of_string s)
+ | Some "git" ->
+ if Sys.file_exists s then
+ Git (Dirname.of_string s)
+ else
+ Git (Dirname.raw s)
+ | Some "rsync" -> Path (Dirname.of_string s)
+ | None | Some _ ->
+ let d = Run.real_path s in
+ if s = "none" then
+ Unpin
+ else if Sys.file_exists d then
+ Path (Dirname.of_string s)
+ else if Utils.contains d ('/') then
+ Git (Dirname.raw s)
+ else
+ Version (V.of_string s)
type pin = {
pin_package: name;
pin_arg: pin_option;
}
-let string_of_pin_option = function
+let path_of_pin_option = function
| Version v -> V.to_string v
+ | Git p
| Path p -> Dirname.to_string p
| Unpin -> "none"
+let kind_of_pin_option = function
+ | Version _ -> "version"
+ | Git _ -> "git"
+ | Path _ -> "rsync"
+ | Unpin -> "<none>"
+
let string_of_pin p =
- Printf.sprintf "{package=%s; arg=%s}"
+ Printf.sprintf "{package=%s; path=%s; kind=%s}"
(N.to_string p.pin_package)
- (string_of_pin_option p.pin_arg)
+ (path_of_pin_option p.pin_arg)
+ (kind_of_pin_option p.pin_arg)
type config =
| Env
View
7 src/types.mli
@@ -514,6 +514,7 @@ val string_of_remote: remote -> string
type pin_option =
| Version of version
| Path of dirname
+ | Git of dirname
| Unpin
(** Pinned packages *)
@@ -526,9 +527,11 @@ type pin = {
val string_of_pin: pin -> string
(** Read pin options args *)
-val pin_option_of_string: string -> pin_option
+val pin_option_of_string: ?kind:string -> string -> pin_option
-val string_of_pin_option: pin_option -> string
+val path_of_pin_option: pin_option -> string
+
+val kind_of_pin_option: pin_option -> string
(** Configuration requests *)
type config_option = {
Please sign in to comment.
Something went wrong with that request. Please try again.