pkglab (1.4.2-11) distcheck/common.ml

--- pkglab-1.4.2.orig/distcheck/common.ml
+++ pkglab-1.4.2/distcheck/common.ml
@@ -7,20 +7,31 @@
 open Napkin
 open Rapids
 open Waterway
+open Str
 
 let show_successes = ref true
 and show_failures = ref true
 and explain_results = ref false
 and quiet = ref false
 and output_xml= ref false
-and dist_type = ref `Debian
-and source_added = ref false;;
+and dist_type = ref `Debian;;
+let pkgs_to_check = ref Package_set.empty;;
+let units_to_check = ref []         (* units given by command line argument *)
+and units_to_check_set = ref false  (* indicates whether units_to check set on command line *)
+and packages_are_missing = ref false;; (* indicates that some packages that were asked to be *)
+                                       (* checked are not available. *)
+let checklist = ref [];;
+let rpm_synthesis = ref false;;
 
 let db = create_database ();;
 let architecture_index = get_architecture_index db;;
 let unit_index = get_unit_index db;;
 let package_index = get_package_index db;;
+let version_index = get_version_index db;;
+let release_index = get_release_index db;;
+let source_index = get_source_index db;;
 let not_to_check = ref Package_set.empty;;
+let tmpfile = ref "";; (* temporary file for input *)
 
 let add_source add_to_check s =
 let merge x = if !quiet then
@@ -28,21 +39,23 @@
 else
 	Waterway.merge db x in
 begin
-  source_added := true;
 	(* This is not very effective, but hey... *)
 	let pkgs_old = Functions.packages db in
 	(let s2 = if s = "-" then
   begin
-    let (n, c) = Filename.open_temp_file "distcheck" "" in
+    let (n, c) = Filename.open_temp_file "distcheck"
+      (if !rpm_synthesis then "synthesis" else "")
+    in
       begin
-      try
-        while true
-        do
-          Printf.fprintf c "%s\n" (read_line ())
-        done
-      with End_of_file -> close_out c
-    end;
-    n
+	tmpfile := n;
+	try
+          while true
+          do
+            Printf.fprintf c "%s\n" (read_line ())
+          done
+	with End_of_file -> close_out c;
+      end;
+      n
   end
   else s in
   match !dist_type with
@@ -54,6 +67,31 @@
 		not_to_check := Package_set.union !not_to_check new_packages	
 end;;
 
+let add_pkg_to_check s =
+begin
+  try
+    let eq = String.index s '=' in 
+    let u = String.sub s 0 eq in
+    let unit_id = Unit_index.search unit_index u in
+    let v = String.sub s (eq+1) (String.length s-eq-1) in
+    let (v_id, r_id) = 
+    try
+      let dash = String.rindex v '-' in
+      let rv = String.sub v 0 dash
+      and r = String.sub v (dash+1) (String.length v-dash-1) in
+      (Version_index.search version_index rv,
+      Release_index.search release_index (Some r))
+    with Not_found -> (Version_index.search version_index v, 
+      Release_index.search release_index None) in
+    let ps = Functions.unit_id_to_package_set db unit_id in
+    Package_set.iter (fun p_id ->
+      let pkg = Functions.get_package_from_id db p_id in
+      if pkg.pk_version = (v_id, r_id) then
+        pkgs_to_check := Package_set.add p_id !pkgs_to_check
+    ) ps;
+  with Not_found -> ()
+end;;
+
 let unit_name_of u_id =
 	Unit_index.find unit_index u_id;;
 
@@ -67,6 +105,15 @@
 		| None -> ""
 		| Some rn -> "-" ^ rn);;
 
+let myunit_name_of p_id = 
+  let (_, pkg) = Package_index.find package_index p_id in
+    Unit_index.find unit_index pkg.pk_unit 
+
+(* gives the name of the source of a package *)
+let source_name_of p_id = 
+  let (_, pkg) = Package_index.find package_index p_id in
+    fst (Source_index.find source_index pkg.pk_source)
+
 let pkg_xml_of p_id =
 	let (_, pkg) = Package_index.find package_index p_id in
 	let unit_name = Unit_index.find unit_index pkg.pk_unit 
@@ -79,23 +126,37 @@
 		| None -> ""
 		| Some rn -> "-" ^ rn);;
 
+(* xmlesc escapes some special caracters into XML *)
+let xmlesc s =
+  global_replace (regexp_string ">") ">"
+    (global_replace (regexp_string "<") "&lt;" s)
+;;
+
 let spec_string s =
-let version_string (v, r) =
-	let vn = Version_index.get_version v
-	and rn = Release_index.get_version r in
-	vn ^ (match rn with None -> "" | Some r -> r) in
-begin
-	match s with
+  let version_string (v, r) =
+    let vn = Version_index.get_version v
+    and rn = Release_index.get_version r in
+      vn ^ (match rn with None -> "" | Some r -> ("-"^r)) in
+    if !output_xml
+    then
+      match s with
 	| Sel_ANY -> ""
-	| Sel_LT v -> Printf.sprintf " (&lt; %s)" (version_string v) 
-	| Sel_LEQ v -> Printf.sprintf " (&lt;= %s)" (version_string v) 
+	| Sel_LT v -> Printf.sprintf " (&lt; %s)" (xmlesc (version_string v)) 
+	| Sel_LEQ v -> Printf.sprintf " (&lt;= %s)" (xmlesc (version_string v))
+	| Sel_EQ v -> Printf.sprintf " (= %s)" (xmlesc (version_string v)) 
+	| Sel_GEQ v -> Printf.sprintf " (&gt;= %s)" (xmlesc (version_string v)) 
+	| Sel_GT v -> Printf.sprintf " (&gt; %s)"  (xmlesc (version_string v)) 
+    else
+      match s with
+	| Sel_ANY -> ""
+	| Sel_LT v -> Printf.sprintf " (< %s)" (version_string v) 
+	| Sel_LEQ v -> Printf.sprintf " (<= %s)" (version_string v) 
 	| Sel_EQ v -> Printf.sprintf " (= %s)" (version_string v) 
-	| Sel_GEQ v -> Printf.sprintf " (&gt;= %s)" (version_string v) 
-	| Sel_GT v -> Printf.sprintf " (&gt; %s)" (version_string v) 
-end;;
+	| Sel_GEQ v -> Printf.sprintf " (>= %s)" (version_string v) 
+	| Sel_GT v -> Printf.sprintf " (> %s)"  (version_string v) 
+;;
 
 let check () =
-let pkgs_to_check = ref (Package_set.diff (Functions.packages db) !not_to_check) in
 let result_ht = Hashtbl.create (Package_set.cardinal !pkgs_to_check) in
 let progress =
 	if !quiet then Progress.dummy
@@ -113,6 +174,7 @@
 end;;
 
 let show_results ht =
+  (* returns true when all checks successful, otherwise false *)
 begin
 	if !output_xml then print_endline "<results>";
 	Hashtbl.iter  
@@ -189,26 +251,82 @@
 		end
 	) ht;
 	if !output_xml then print_endline "</results>";
+	(* we return true when all checks have been successful, otherwise false *)
+	Hashtbl.fold
+	  (fun _ (result,_) accumulator -> result && accumulator)
+	  ht
+	  true
 end;;
 
-let speclist = [
+let speclist = ref [
 	("-explain", Set explain_results, "Explain the results");
 	("-failures", Clear show_successes, "Only show failures");
 	("-successes", Clear show_failures, "Only show successes");
-	("-base FILE", String (add_source false), "Additional binary package control file providing packages that are not checked but used for resolving dependencies");
+	("-i", String (add_source true), "Additional input file providing control stanzas of packages that are checked and used for resolving dependencies");
+	("-I", String (add_source false), "Additional input file providing control stanzas of packages that are NOT checked but used only for resolving dependencies");
+	("-checkonly", 
+	  String (fun s -> units_to_check := Util.split_at ',' s; units_to_check_set := true),
+	  "Check only these packages");
 	("-quiet", Set quiet, "Do not emit warnings nor progress/timing information");
 	("-xml", Set output_xml, "Output results in XML format");
-	("-", Unit (fun () -> add_source true "-"), "");
 ];; 	
 
 let _ =
 	if Util.string_contains Sys.argv.(0) "debcheck" then
 		dist_type := `Debian
 	else if Util.string_contains Sys.argv.(0) "rpmcheck" then
-		dist_type := `RPM
+  begin
+		dist_type := `RPM;
+    speclist := ("-synthesis", Set rpm_synthesis, "Use synthesis hdlist")::!speclist
+  end
 	else if Util.string_contains Sys.argv.(0) "pscheck" then
 		dist_type := `Pkgsrc
 	else (Printf.eprintf "Warning: unknown name '%s', behaving like debcheck\n%!" Sys.argv.(0); dist_type := `Debian);
-	Arg.parse speclist (add_source true) "Distcheck v1.4.1";
-  if not !source_added then add_source true "-";
-	show_results (check ());;
+	Arg.parse !speclist (fun s -> checklist := s::!checklist) "Distcheck $Revision$";
+  add_source true "-";
+  if !units_to_check_set
+  then
+    let rec separate_source_packages = function
+	[] -> [],[]
+      | h::r ->
+	  let br,sr = separate_source_packages r 
+	  and h_length = String.length h
+	  in if h_length >= 5 && String.sub h 0 4 = "src:"
+	    then br,(String.sub h 4 (h_length-4))::sr
+	    else h::br,sr
+    in let bin_units_to_check, src_units_to_check = separate_source_packages !units_to_check
+    in let filtered_packages =
+      (Package_set.filter
+	 (fun p -> List.mem  (myunit_name_of p) bin_units_to_check || List.mem (source_name_of p) src_units_to_check)
+	 (Functions.packages db))
+    in let found_package_names =
+	List.map myunit_name_of (Package_set.elements filtered_packages)
+    in let missing_package_names =   
+	List.filter
+	  (fun pn -> not (List.mem pn found_package_names))
+	  bin_units_to_check
+    in if missing_package_names <> []
+      then begin
+	packages_are_missing := true;
+	prerr_string "Warning: some packages not found:";
+	List.iter
+	  (fun pn -> prerr_char ' '; prerr_string pn) 
+	  missing_package_names;
+	prerr_newline ();
+	flush stderr
+      end;
+      pkgs_to_check := filtered_packages
+  else begin
+    List.iter add_pkg_to_check !checklist;
+    if Package_set.is_empty !pkgs_to_check then
+      pkgs_to_check := Package_set.diff (Functions.packages db) !not_to_check;
+  end;
+  if !tmpfile <> "" then Sys.remove !tmpfile;
+  exit (if (show_results (check ()))
+	then 
+	  if !packages_are_missing
+	  then 2 (* some packages that were asked to be checked are missing *)
+	  else 0 (* all checks successful *)
+	else 1 (* some package are not installable *)
+);;
+