Skip to content
Browse files

Provide the recursive option for "ocp-get config".

  • Loading branch information...
1 parent e405091 commit 4e8412dc89d02bfbed379a15e194b693f298ffd3 @tuong tuong committed Mar 21, 2012
Showing with 179 additions and 64 deletions.
  1. +90 −40 src/client.ml
  2. +89 −24 src/solver.ml
View
130 src/client.ml
@@ -241,12 +241,24 @@ module Client : CLIENT = struct
proceed_torecompile t (name, v);
File.Installed.modify_def (Path.installed t.home) (N_map.add name v)
+ let debpkg_of_nv t map_installed =
+ List.fold_left
+ (fun l n_v ->
+ let opam = File.Opam.find_err (Path.index_opam t.home (Some n_v)) in
+ let pkg =
+ File.Opam.package opam
+ (match N_map.Exceptionless.find (fst n_v) map_installed with
+ | Some v -> v = snd n_v
+ | _ -> false) in
+ pkg :: l)
+ []
+
let resolve t l_index map_installed request =
let rec aux = function
| [x] ->
(* Only 1 solution exists *)
- Globals.msg "The following actions will be performed:\n";
+ Globals.msg "The following solution has been found:\n";
Solver.solution_print Namespace.string_of_user x;
if delete_or_update x then
if confirm "Continue ?" then
@@ -258,7 +270,7 @@ module Client : CLIENT = struct
| x :: xs ->
(* Multiple solution exist *)
- Globals.msg "The following actions will be performed:\n";
+ Globals.msg "The following solution has been found:\n";
Solver.solution_print Namespace.string_of_user x;
if delete_or_update x then
if confirm "Continue ? (press [n] to try another solution)" then
@@ -268,29 +280,23 @@ module Client : CLIENT = struct
else
Some x
- | [] -> None in
+ | [] -> assert false in
- let l_pkg =
- List.fold_left
- (fun l n_v ->
- let opam = File.Opam.find_err (Path.index_opam t.home (Some n_v)) in
- let pkg =
- File.Opam.package opam
- (match N_map.Exceptionless.find (fst n_v) map_installed with
- | Some v -> v = snd n_v
- | _ -> false) in
- pkg :: l) [] l_index in
-
- match aux (Solver.resolve l_pkg request) with
- | Some sol ->
- List.iter (fun(Solver.P l) ->
- List.iter (function
- | Solver.To_change (o,n) -> proceed_tochange t o n
- | Solver.To_delete n_v -> proceed_todelete t n_v
- | Solver.To_recompile n_v -> proceed_torecompile t n_v
- ) l
- ) sol
- | None -> ()
+ let l_pkg = debpkg_of_nv t map_installed l_index in
+
+ match Solver.resolve l_pkg request with
+ | [] -> Globals.msg "No solution has been found.\n"
+ | l ->
+ match aux l with
+ | Some sol ->
+ List.iter (fun(Solver.P l) ->
+ List.iter (function
+ | Solver.To_change (o,n) -> proceed_tochange t o n
+ | Solver.To_delete n_v -> proceed_todelete t n_v
+ | Solver.To_recompile n_v -> proceed_torecompile t n_v
+ ) l
+ ) sol
+ | None -> ()
let vpkg_of_nv (name, v) = Namespace.string_of_name name, Some ("=", v.Namespace.deb)
@@ -395,10 +401,33 @@ module Client : CLIENT = struct
type config_request = Dir | Bytelink | Asmlink
- let config _ req name =
+ let config is_rec req name =
log "config %s" (Namespace.string_of_name name);
let t = load_state () in
- match find_from_name name (Path.index_opam_list t.home), req with
+
+ let l_index = Path.index_opam_list t.home in
+
+ let f_is_rec f_true f_false =
+ let installed = File.Installed.find_map (Path.installed t.home) in
+ match N_map.Exceptionless.find name installed with
+ | None -> unknown_package name
+ | Some version ->
+
+ if is_rec then
+ let l_deb = debpkg_of_nv t installed l_index in
+ f_true
+ (Solver.filter_dependencies
+ (List.find
+ (fun pkg ->
+ Namespace.Name pkg.Debian.Packages.name = name
+ &&
+ pkg.Debian.Packages.version = version.Namespace.deb)
+ l_deb)
+ l_deb)
+ else
+ f_false version in
+
+ match find_from_name name l_index, req with
| None, _ ->
Globals.msg
@@ -408,20 +437,41 @@ module Client : CLIENT = struct
update_t t
| Some _, Dir ->
- Globals.msg "%s"
- (match Path.ocaml_options_of_library t.home name with I s -> s)
-
- | Some v, _ ->
- let l_f, s_cma =
- (match req with
- | Bytelink -> [ File.Descr.link ], ".cma"
- | Asmlink -> [ File.Descr.link ; File.Descr.asmlink ], ".cmxa"
- | Dir -> assert false) in
- let descr = File.Descr.find_err (Path.descr t.home (name, V_set.max_elt v)) in
- let flags = List.flatten (List.map (fun f -> f descr) l_f) in
- Globals.msg "%s %s%s"
- (String.concat " " flags)
- (File.Descr.library descr) s_cma
+ f_is_rec
+ (fun l ->
+ Globals.msg "%s"
+ (BatIO.to_string
+ (let i = "-I " in
+ BatList.print ~first:i ~last:"" ~sep:(" " ^ i) BatString.print)
+ (List.map
+ (fun pkg -> match Path.ocaml_options_of_library t.home (Namespace.Name pkg.Debian.Packages.name) with I s -> s)
+ l)))
+ (fun _ ->
+ Globals.msg "%s"
+ (match Path.ocaml_options_of_library t.home name with I s -> s))
+
+ | _ ->
+ let display name version =
+ let l_f, s_cma =
+ match req with
+ | Bytelink -> [ File.Descr.link ], ".cma"
+ | Asmlink -> [ File.Descr.link ; File.Descr.asmlink ], ".cmxa"
+ | Dir -> assert false in
+ let descr = File.Descr.find_err (Path.descr t.home (name, version)) in
+
+ List.flatten (List.map (fun f -> f descr) l_f),
+ File.Descr.library descr ^ s_cma in
+
+ f_is_rec
+ (fun l ->
+ let l_opt, l_cma =
+ List.split (List.map (fun pkg -> display (Namespace.Name pkg.Debian.Packages.name) { Namespace.deb = pkg.Debian.Packages.version }) l) in
+ Globals.msg "%s %s"
+ (String.concat " " (List.flatten l_opt))
+ (BatIO.to_string (BatList.print ~first:"" ~last:"" ~sep:" " BatString.print) l_cma))
+ (fun version ->
+ let l, s_cma = display name version in
+ Globals.msg "%s %s" (String.concat " " l) s_cma)
end
View
113 src/solver.ml
@@ -40,6 +40,11 @@ sig
val resolve :
Debian.Packages.package list -> Debian.Format822.vpkg request
-> name_version solution list
+
+ (** Return the recursive dependencies of a package
+ Note : the given package exists in the list in input because this list describes the entire universe.
+ However, by convention, it does not appear in output. *)
+ val filter_dependencies : Debian.Packages.package -> Debian.Packages.package list -> Debian.Packages.package list
end
module Solver : SOLVER = struct
@@ -68,13 +73,19 @@ module Solver : SOLVER = struct
let solution_print f =
let pf = Globals.msg in
- List.iter (fun (P l) ->
- List.iter (function
- | To_recompile p -> pf "Recompile: %s\n" (f p)
- | To_delete p -> pf "Remove: %s\n" (f p)
- | To_change (Was_not_installed, p) -> pf "Install: %s\n" (f p)
- | To_change (Was_installed o, p) -> pf "Update: %s (Remove) -> %s (Install)\n" (f o) (f p)
- ) l)
+ function
+ | [] -> pf "No actions will be performed, the current state satisfies the request.\n"
+ | l ->
+ let l_total = List.fold_left (fun acc (P l) -> acc + List.length l) 0 l in
+ List.iteri (fun i1 (P l) ->
+ List.iteri (fun i2 ->
+ let pf f = Printf.kprintf (pf "[%d/%d] %s" (succ (i1 + i2)) l_total) f in
+ function
+ | To_recompile p -> pf "Recompile: %s\n" (f p)
+ | To_delete p -> pf "Remove: %s\n" (f p)
+ | To_change (Was_not_installed, p) -> pf "Install: %s\n" (f p)
+ | To_change (Was_installed o, p) -> pf "Update: %s (Remove) -> %s (Install)\n" (f o) (f p)
+ ) l) l
let request_map f r =
let f = List.map f in
@@ -177,17 +188,26 @@ module Solver : SOLVER = struct
end
module PO = Defaultgraphs.GraphOper (PG)
- module PG_bfs =
- struct
- include Graph.Traverse.Bfs (PG)
+ module type FS = sig
+ type iterator
+ val start : PG.t -> iterator
+ val step : iterator -> iterator
+ val get : iterator -> PG.V.t
+ end
+
+ module Make_fs (F : FS) = struct
let fold f acc g =
let rec aux acc iter =
- match try Some (get iter, step iter) with Exit -> None with
+ match try Some (F.get iter, F.step iter) with Exit -> None with
| None -> acc
| Some (x, iter) -> aux (f acc x) iter in
- aux acc (start g)
+ aux acc (F.start g)
end
+ module PG_bfs = Make_fs (Graph.Traverse.Bfs (PG))
+ module PG_dfs = Make_fs (Graph.Traverse.Dfs (PG))
+ module PG_topo = Graph.Topological.Make (PG)
+
module O_pkg = struct type t = Cudf.package let compare = compare end
module PkgMap = BatMap.Make (O_pkg)
module PkgSet = BatSet.Make (O_pkg)
@@ -197,16 +217,62 @@ module Solver : SOLVER = struct
let () = PO.transitive_reduction g in
g
- let resolve l_pkg_pb req =
+ let tocudf table pkg =
+ let p = Debian.Debcudf.tocudf table pkg in
+ { p with Cudf.conflicts = List.tl p.Cudf.conflicts
+ (* we cancel the 'self package conflict' notion introduced in [loadlc] in debcudf.ml *) }
+
+ let cudfpkg_of_debpkg table = List.map (tocudf table)
+
+ let get_table l_pkg_pb f =
let table = Debian.Debcudf.init_tables l_pkg_pb in
- let pkglist =
- List.map
- (fun pkg ->
- let p = Debian.Debcudf.tocudf table pkg in
- { p with Cudf.conflicts = List.tl p.Cudf.conflicts
- (* we cancel the 'self package conflict' notion introduced in [loadlc] in debcudf.ml *) } ) l_pkg_pb in
+ let v = f table (cudfpkg_of_debpkg table l_pkg_pb) in
+ let () = Debian.Debcudf.clear table in
+ v
+
+ let filter_dependencies pkg l_pkg_pb =
+ let pkg_map =
+ List.fold_left
+ (fun map pkg ->
+ NV_map.add
+ (Namespace.Name pkg.Debian.Packages.name, { Namespace.deb = pkg.Debian.Packages.version })
+ pkg
+ map)
+ NV_map.empty
+ l_pkg_pb in
+ get_table l_pkg_pb
+ (fun table pkglist ->
+ let g = dep_reduction pkglist in
+ let _, l =
+ PG_topo.fold
+ (fun p (set, l) ->
+ let add_succ_rem pkg set act =
+ (let set = PkgSet.remove pkg set in
+ try
+ List.fold_left (fun set x ->
+ PkgSet.add x set) set (PG.succ g pkg)
+ with _ -> set),
+ act :: l in
+
+ if PkgSet.mem p set then
+ add_succ_rem p set p
+ else
+ set, l)
+ g
+ (PkgSet.add (tocudf table pkg) PkgSet.empty, []) in
+ List.map (fun pkg ->
+ NV_map.find
+ (Namespace.Name pkg.Cudf.package,
+ { Namespace.deb =
+ Debian.Debcudf.get_real_version
+ table
+ (pkg.Cudf.package, pkg.Cudf.version) }) pkg_map) l)
+
+ let resolve l_pkg_pb req =
+ get_table l_pkg_pb
+ (fun table pkglist ->
let universe = Cudf.load_universe pkglist in
- let l =
+
[ match
BatOption.bind
(let cons pkg act = Some (pkg, act) in
@@ -227,7 +293,7 @@ module Solver : SOLVER = struct
| To_recompile _ -> assert false) l) in
let graph_installed =
- PO.O.mirror
+ PO.O.mirror
(dep_reduction
(Cudf.get_packages
~filter:(fun p -> p.Cudf.installed || PkgMap.mem p map_add)
@@ -273,10 +339,9 @@ module Solver : SOLVER = struct
Debian.Debcudf.get_real_version
table
(pkg.Cudf.package, pkg.Cudf.version) })
- (List.map (fun x -> P [ x ]) l) ] in
- let () = Debian.Debcudf.clear table in
- l
+ (List.map (fun x -> P [ x ]) l) ])
end
+ let filter_dependencies = Graph.filter_dependencies
let resolve = Graph.resolve
end

0 comments on commit 4e8412d

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