let challenged
?(downgrades=false)
?(broken=false)
?(cluster=false)
?(clusterlist=None)
repository =
let print_cluster = cluster in
let worktable = ref [] in
let clusters = Debian.Debutil.cluster repository in
let version_acc = ref [] in
let constraints_table = Debian.Evolution.constraints repository in
let cluster_iter (sn,sv) l =
List.iter (fun (version,realversion,cluster) ->
let (versionlist, constr) =
Debian.Evolution.all_ver_constr constraints_table cluster
in
version_acc := versionlist @ !version_acc;
worktable := ((sn,sv,realversion),(cluster,versionlist,constr))::!worktable
) l
in
if Option.is_none clusterlist then
Hashtbl.iter cluster_iter clusters
else
List.iter (fun (sn,_,sv) ->
begin try
let l = Hashtbl.find clusters (sn,sv) in
cluster_iter (sn,sv) l
with Not_found -> fatal "cluster %s %s is not correctly specified" sn sv end
) (Option.get clusterlist)
;
let versionlist = Util.list_unique !version_acc in
let tables = Debian.Debcudf.init_tables ~step:2 ~versionlist repository in
let getv v = Debian.Debcudf.get_cudf_version tables ("",v) in
let pp = pp tables in
let pkglist = List.map (Debian.Debcudf.tocudf tables) repository in
let universe = Cudf.load_universe pkglist in
let brokenlist = Depsolver.find_broken universe in
let pkgset = pkgset universe in
Util.Progress.set_total predbar (List.length !worktable);
info "Total versions: %d" (List.length versionlist);
let results =
let map f l =
IFDEF HASPARMAP THEN
let ncores = OptParse.Opt.get Options.ncores in
match OptParse.Opt.opt Options.chunksize with
None ->
Parmap.parmap ~ncores f (Parmap.L l)
| Some chunksize ->
Parmap.parmap ~ncores ~chunksize f (Parmap.L l)
ELSE
List.map f l
END
in
map (fun ((sn,sv,version),(cluster,vl,constr)) ->
let startd=Unix.gettimeofday() in
let cluster_results = ref [] in
Util.Progress.progress predbar;
debug "\nSource: %s %s" sn sv;
if sv <> version then debug "Subscluter: %s %s" sn version;
debug "Clustersize: %d" (List.length cluster);
debug "Versions: %s" (String.concat ";" vl);
debug "Constraints: %s" (String.concat " ; " (
List.map (fun (c,v) -> Printf.sprintf "%s" v) constr
)
);
let discr = Debian.Evolution.discriminant ~bottom:true (evalsel getv) vl constr in
debug "Discriminants: %d" (List.length discr);
if print_cluster then begin
let pp fmt pkg =
let pp_io_property fmt (n, s) = Format.fprintf fmt "%s: %s@," n s in
Cudf_printer.pp_package_gen pp_io_property fmt pkg
in
let pp_list = Diagnostic.pp_list pp in
let cudf_cluster =
List.map (fun pkg ->
let (pn,pv) = (pkg.Debian.Packages.name, getv pkg.Debian.Packages.version) in
Cudf.lookup_package universe (pn,pv)
) cluster
in
Format.printf "@[<v 1>clusters:@,%a@]@," pp_list cudf_cluster
end;
List.iter (function
| (target,equiv) when not(downgrades) &&
(lesser_or_equal getv target equiv version) ->
debug "Target: %s" (Debian.Evolution.string_of_range target);
debug "Equiv: %s" (String.concat " , " (
List.map (Debian.Evolution.string_of_range) equiv
));
debug "ignored"
| (target,equiv) ->
debug "Considering target %s" (Debian.Evolution.string_of_range target);
debug "Target: %s" (Debian.Evolution.string_of_range target);
debug "Equiv: %s" (String.concat " , " (
List.map (Debian.Evolution.string_of_range) equiv
));
let migrationlist = Debian.Evolution.migrate cluster target in
let future = upgrade tables pkgset universe brokenlist migrationlist in
let callback d =
let fmt = Format.std_formatter in
if broken then Diagnostic.fprintf ~pp ~failure:true ~explain:true fmt d
in
if broken then Format.printf "Distcheck: @,";
let i = Depsolver.univcheck ~callback future in
if broken then Format.printf "@.";
debug "Broken: %d" i;
cluster_results := (((sn,sv,version),(target,equiv)),i)::!cluster_results ;
) discr;
debug "<%s,%s> : %f" sn sv (Unix.gettimeofday() -. startd);
!cluster_results
) !worktable
in List.concat results