debrpmcheck-1.0/0000755000042300001440000000000010451773530012114 5ustar dicosmodebrpmcheck-1.0/Makefile0000644000042300001440000000162310451773471013562 0ustar dicosmo OCAMLC=ocamlc OCAMLOPT=ocamlopt OCAMLDEP=ocamldep OBJS = util.cmx common.cmx solver.cmx OPTLINKFLAGS=unix.cmxa str.cmxa all: debcheck rpmcheck rpmcheck: $(OBJS) rpm.cmx $(OCAMLOPT) -o $@ $(OPTLINKFLAGS) $^ $(LINKFLAGS) debcheck: $(OBJS) deb.cmx $(OCAMLOPT) -o $@ $(OPTLINKFLAGS) $^ $(LINKFLAGS) # ocamlopt -o check unix.cmxa str.cmxa check.ml ##### clean:: find . -regex ".*\\.\(cm[oix]\|o\)" | xargs rm -f .SUFFIXES: .cmo .cmi .cmx .ml .mli .mly .mll .idl .o .c .ml.cmx: $(OCAMLOPT) $(OPTCOMPFLAGS) $(COMPFLAGS) -c $< .ml.cmo: $(OCAMLC) $(BYTECOMPFLAGS) $(COMPFLAGS) -c $< .mli.cmi: $(OCAMLC) $(COMPFLAGS) -c $< .idl.ml: $(OCAMLIDL) $< .mly.ml: $(OCAMLYACC) $< .mly.mli: $(OCAMLYACC) $< .mll.ml: $(OCAMLLEX) $< .c.o: $(OCAMLC) -ccopt "-o $@" $(COMPFLAGS) -ccopt "$(CFLAGS)" -c $< depend: find . -regex ".*\\.mli?" | xargs \ $(OCAMLDEP) $(DEPFLAGS) $$i \ > .depend include .depend debrpmcheck-1.0/.depend0000644000042300001440000000053610451773554013366 0ustar dicosmo./rpm.cmo: util.cmi solver.cmi common.cmi ./rpm.cmx: util.cmx solver.cmx common.cmx ./deb.cmo: util.cmi solver.cmi common.cmi ./deb.cmx: util.cmx solver.cmx common.cmx ./util.cmo: ./util.cmi ./util.cmx: ./util.cmi ./solver.cmo: ./solver.cmi ./solver.cmx: ./solver.cmi ./common.cmo: util.cmi ./common.cmi ./common.cmx: util.cmx ./common.cmi debrpmcheck-1.0/common.ml0000644000042300001440000000335210451773302013736 0ustar dicosmo type st = { time : float; active : bool; channel : in_channel; length : int; mutable count : int; mutable percent : float } let start_parsing active ch = { time = Unix.gettimeofday (); active = active; channel = ch; length = begin try in_channel_length ch with Sys_error _ -> 0 end; count = 0; percent = 0. } let parsing_tick st = st.count <- st.count + 1; if st.active then begin if st.length > 0 then begin let p = pos_in st.channel in let pc = float p *. 100. /. float st.length in if pc >= st.percent then begin Util.set_msg (Format.sprintf "Parsing package file... %3.f%% %6d packages" pc st.count); st.percent <- pc +. 1. end end else if st.count mod 10 = 0 then Util.set_msg (Format.sprintf "Parsing package file... %6d packages" st.count) end let stop_parsing st = Util.set_msg ""; Format.eprintf "Parsing package file... %.1f seconds %6d packages@." (Unix.gettimeofday () -. st.time) st.count (****) type st' = { time : float; active : bool; num : int; step : int; mutable count : int } let start_generate active num = if active then Util.set_msg "Generating constraints..."; { time = Unix.gettimeofday (); active = active; num = num; step = max 1 (num / 100); count = 0 } let generate_next st = st.count <- st.count + 1; if st.active && st.count mod st.step = 0 then Util.set_msg (Format.sprintf "Generating constraints... %3.f%%" (float st.count *. 100. /. float st.num)) let stop_generate st = Util.set_msg ""; Format.eprintf "Generating constraints... %.1f seconds@." (Unix.gettimeofday () -. st.time); debrpmcheck-1.0/README0000644000042300001440000000131410451773302012770 0ustar dicosmo The programs "debcheck" and "rpmcheck" tests respectively whether a set of Debian or RPM packages can all be installed. They take as input a binary package control file (in the Debian case) or an uncompressed hdlist.cz file (in the RPM case), which provides a list of packages together with their dependencies. They then check that for each package their exists a consistent (all constraints are satisfied) set of packages containing this package. COMPILATION The ocaml compiler must be installed. Then, just run "make". USAGE The commands "./debcheck -help" and "./rpmcheck -help" provides a short description of the programs and lists the options. AUTHOR Jerome Vouillon (Jerome.Vouillon@pps.jussieu.fr) debrpmcheck-1.0/solver.ml0000644000042300001440000003211110451773302013753 0ustar dicosmo(* Solver *) (* SAT solver by Jerôme Vouillon *) let debug = ref false module type S = sig type reason end module M (X : S) = struct (* Variables *) type var = int (* Literals *) type lit = int (* A clause is an array of literals *) type clause = { lits : lit array; reasons : X.reason list } type value = True | False | Unknown type state = { (* Indexed by var *) st_assign : value array; st_reason : clause option array; st_level : int array; st_seen_var : int array; st_refs : int array; st_pinned : bool array; (* Indexed by lit *) st_simpl_prop : (lit * clause) list array; st_watched : clause list array; st_associated_vars : var list array; (* Queues *) mutable st_trail : lit list; mutable st_trail_lim : lit list list; st_prop_queue : lit Queue.t; (* Misc *) mutable st_cur_level : int; mutable st_min_level : int; mutable st_seen : int; mutable st_var_queue_head : var list; st_var_queue : var Queue.t; mutable st_cost : int; (* Total computational cost so far *) st_print_var : Format.formatter -> int -> unit; mutable st_coherent : bool } (****) let charge st x = st.st_cost <- st.st_cost + x let get_bill st = st.st_cost (****) let pin_var st x = st.st_pinned.(x) <- true let unpin_var st x = st.st_pinned.(x) <- false let enqueue_var st x = charge st 1; pin_var st x; Queue.push x st.st_var_queue let requeue_var st x = pin_var st x; st.st_var_queue_head <- x :: st.st_var_queue_head (* Returns -1 if no variable remains *) let rec dequeue_var st = let x = match st.st_var_queue_head with x :: r -> st.st_var_queue_head <- r; x | [] -> try Queue.take st.st_var_queue with Queue.Empty -> -1 in if x = -1 then x else begin unpin_var st x; if st.st_refs.(x) = 0 || st.st_assign.(x) <> Unknown then dequeue_var st else x end (****) let var_of_lit p = p lsr 1 let pol_of_lit p = p land 1 = 0 let lit_of_var v s = if s then v + v else v + v + 1 let lit_neg p = p lxor 1 let val_neg v = match v with True -> False | False -> True | Unknown -> Unknown let val_of_bool b = if b then True else False let val_of_lit st p = let v = st.st_assign.(var_of_lit p) in if pol_of_lit p then v else val_neg v (****) let print_val ch v = Format.fprintf ch "%s" (match v with True -> "True" | False -> "False" | Unknown -> "Unknown") let print_lits st ch lits = Format.fprintf ch "{"; Array.iter (fun p -> if pol_of_lit p then Format.fprintf ch " +%a" st.st_print_var (var_of_lit p) else Format.fprintf ch " -%a" st.st_print_var (var_of_lit p)) lits; Format.fprintf ch " }" let print_rule st ch r = print_lits st ch r.lits (****) exception Conflict of clause option let enqueue st p reason = charge st 1; if !debug then begin match reason with Some r -> Format.eprintf "Applying rule %a@." (print_rule st) r | _ -> () end; match val_of_lit st p with False -> if !debug then begin if pol_of_lit p then Format.eprintf "Cannot install %a@." st.st_print_var (var_of_lit p) else Format.eprintf "Already installed %a@." st.st_print_var (var_of_lit p) end; raise (Conflict reason) | True -> () | Unknown -> if !debug then begin if pol_of_lit p then Format.eprintf "Installing %a@." st.st_print_var (var_of_lit p) else Format.eprintf "Should not install %a@." st.st_print_var (var_of_lit p); end; let x = var_of_lit p in st.st_assign.(x) <- val_of_bool (pol_of_lit p); st.st_reason.(x) <- reason; st.st_level.(x) <- st.st_cur_level; st.st_trail <- p :: st.st_trail; List.iter (fun x -> charge st 1; let refs = st.st_refs.(x) in if refs = 0 then enqueue_var st x; st.st_refs.(x) <- st.st_refs.(x) + 1) st.st_associated_vars.(p); Queue.push p st.st_prop_queue let rec find_not_false st lits i l = if i = l then -1 else if val_of_lit st lits.(i) <> False then i else find_not_false st lits (i + 1) l let propagate_in_clause st r p = charge st 1; let p' = lit_neg p in if r.lits.(0) = p' then begin r.lits.(0) <- r.lits.(1); r.lits.(1) <- p' end; if val_of_lit st r.lits.(0) = True then st.st_watched.(p) <- r :: st.st_watched.(p) else begin let i = find_not_false st r.lits 2 (Array.length r.lits) in if i = -1 then begin st.st_watched.(p) <- r :: st.st_watched.(p); enqueue st r.lits.(0) (Some r) end else begin r.lits.(1) <- r.lits.(i); r.lits.(i) <- p'; let p = lit_neg r.lits.(1) in st.st_watched.(p) <- r :: st.st_watched.(p) end end let propagate st = try while not (Queue.is_empty st.st_prop_queue) do charge st 1; let p = Queue.take st.st_prop_queue in List.iter (fun (p, r) -> enqueue st p (Some r)) st.st_simpl_prop.(p); let l = ref (st.st_watched.(p)) in st.st_watched.(p) <- []; begin try while match !l with r :: rem -> l := rem; propagate_in_clause st r p; true | [] -> false do () done with Conflict _ as e -> st.st_watched.(p) <- !l @ st.st_watched.(p); raise e end done with Conflict _ as e -> Queue.clear st.st_prop_queue; raise e (****) let raise_level st = st.st_cur_level <- st.st_cur_level + 1; st.st_trail_lim <- st.st_trail :: st.st_trail_lim; st.st_trail <- [] let assume st p = raise_level st; enqueue st p None let protect st = propagate st; raise_level st; st.st_min_level <- st.st_cur_level let undo_one st p = let x = var_of_lit p in if !debug then Format.eprintf "Cancelling %a@." st.st_print_var x; st.st_assign.(x) <- Unknown; st.st_reason.(x) <- None; st.st_level.(x) <- -1; List.iter (fun x -> charge st 1; st.st_refs.(x) <- st.st_refs.(x) - 1) st.st_associated_vars.(p); if st.st_refs.(x) > 0 && not st.st_pinned.(x) then enqueue_var st x let cancel st = st.st_cur_level <- st.st_cur_level - 1; List.iter (fun p -> undo_one st p) st.st_trail; match st.st_trail_lim with [] -> assert false | l :: r -> st.st_trail <- l; st.st_trail_lim <- r let reset st = if !debug then Format.eprintf "Reset@."; while st.st_trail_lim <> [] do cancel st done; for i = 0 to Array.length st.st_refs - 1 do st.st_refs.(i) <- 0; st.st_pinned.(i) <- false done; st.st_var_queue_head <- []; st.st_min_level <- 0; Queue.clear st.st_var_queue; st.st_coherent <- true (****) let rec find_next_lit st = match st.st_trail with [] -> assert false | p :: rem -> st.st_trail <- rem; if st.st_seen_var.(var_of_lit p) = st.st_seen then let reason = st.st_reason.(var_of_lit p) in undo_one st p; (p, reason) else begin undo_one st p; find_next_lit st end let analyze st conflict = st.st_seen <- st.st_seen + 1; let counter = ref 0 in let learnt = ref [] in let bt_level = ref 0 in let reasons = ref [] in let r = ref conflict in while if !debug then begin Array.iter (fun p -> Format.eprintf "%d:%a (%b/%d) " p print_val (val_of_lit st p) (st.st_reason.(var_of_lit p) <> None) st.st_level.(var_of_lit p)) !r.lits; Format.eprintf "@." end; reasons := !r.reasons @ !reasons; for i = 0 to Array.length !r.lits - 1 do let p = !r.lits.(i) in let x = var_of_lit p in if st.st_seen_var.(x) <> st.st_seen then begin assert (val_of_lit st p = False); st.st_seen_var.(x) <- st.st_seen; let level = st.st_level.(x) in if level = st.st_cur_level then begin incr counter end else (* if level > 0 then*) begin learnt := p :: !learnt; bt_level := max level !bt_level end end done; let (p, reason) = find_next_lit st in decr counter; if !counter = 0 then learnt := lit_neg p :: !learnt else begin match reason with Some r' -> r := r' | None -> assert false end; !counter > 0 do () done; if !debug then begin List.iter (fun p -> Format.eprintf "%d:%a/%d " p print_val (val_of_lit st p) st.st_level.(var_of_lit p)) !learnt; Format.eprintf "@." end; (Array.of_list !learnt, !reasons, !bt_level) let find_highest_level st lits = let level = ref (-1) in let i = ref 0 in Array.iteri (fun j p -> if st.st_level.(var_of_lit p) > !level then begin level := st.st_level.(var_of_lit p); i := j end) lits; !i let rec solve_rec st = match try propagate st; None with Conflict r -> Some r with None -> let x = dequeue_var st in x < 0 || begin assume st (lit_of_var x false); solve_rec st end | Some r -> let r = match r with None -> assert false | Some r -> r in let (learnt, reasons, level) = analyze st r in let level = max st.st_min_level level in while st.st_cur_level > level do cancel st done; assert (val_of_lit st learnt.(0) = Unknown); let rule = { lits = learnt; reasons = reasons } in if !debug then Format.eprintf "Learning %a@." (print_rule st) rule; if Array.length learnt > 1 then begin let i = find_highest_level st learnt in assert (i > 0); let p' = learnt.(i) in learnt.(i) <- learnt.(1); learnt.(1) <- p'; let p = lit_neg learnt.(0) in let p' = lit_neg p' in st.st_watched.(p) <- rule :: st.st_watched.(p); st.st_watched.(p') <- rule :: st.st_watched.(p') end; enqueue st learnt.(0) (Some rule); st.st_cur_level > st.st_min_level && solve_rec st let rec solve st x = assert (st.st_cur_level = st.st_min_level); propagate st; try let p = lit_of_var x true in assume st p; assert (st.st_cur_level = st.st_min_level + 1); if solve_rec st then begin protect st; true end else solve st x with Conflict _ -> st.st_coherent <- false; false let rec solve_lst_rec st l0 l = match l with [] -> true | x :: r -> protect st; List.iter (fun x -> enqueue st (lit_of_var x true) None) l0; propagate st; if solve st x then begin if r <> [] then reset st; solve_lst_rec st (x :: l0) r end else false let solve_lst st l = solve_lst_rec st [] l let initialize_problem ?(print_var = (fun fmt -> Format.fprintf fmt "%d")) n = { st_assign = Array.make n Unknown; st_reason = Array.make n None; st_level = Array.make n (-1); st_seen_var = Array.make n (-1); st_refs = Array.make n 0; st_pinned = Array.make n false; st_simpl_prop = Array.make (2 * n) []; st_watched = Array.make (2 * n) []; st_associated_vars = Array.make (2 * n) []; st_trail = []; st_trail_lim = []; st_prop_queue = Queue.create (); st_cur_level = 0; st_min_level = 0; st_seen = 0; st_var_queue_head = []; st_var_queue = Queue.create (); st_cost = 0; st_print_var = print_var; st_coherent = true } let insert_simpl_prop st r p p' = let p = lit_neg p in if not (List.mem_assoc p' st.st_simpl_prop.(p)) then st.st_simpl_prop.(p) <- (p', r) :: st.st_simpl_prop.(p) let add_bin_rule st p p' reasons = let r = { lits = [|p; p'|]; reasons = reasons } in insert_simpl_prop st r p p'; insert_simpl_prop st r p' p let add_un_rule st p reasons = let r = { lits = [|p|]; reasons = reasons } in enqueue st p (Some r) let add_rule st lits reasons = let is_true = ref false in let j = ref 0 in for i = 0 to Array.length lits - 1 do match val_of_lit st lits.(i) with True -> is_true := true | False -> () | Unknown -> lits.(!j) <- lits.(i); incr j done; let lits = Array.sub lits 0 !j in if not !is_true then match Array.length lits with 0 -> assert false | 1 -> add_un_rule st lits.(0) reasons | 2 -> add_bin_rule st lits.(0) lits.(1) reasons | _ -> let rule = { lits = lits; reasons = reasons } in let p = lit_neg rule.lits.(0) in let p' = lit_neg rule.lits.(1) in assert (val_of_lit st p <> False); assert (val_of_lit st p' <> False); st.st_watched.(p) <- rule :: st.st_watched.(p); st.st_watched.(p') <- rule :: st.st_watched.(p') let associate_vars st lit l = st.st_associated_vars.(lit) <- l @ st.st_associated_vars.(lit) let rec collect_rec st x l = if st.st_seen_var.(x) = st.st_seen then l else begin st.st_seen_var.(x) <- st.st_seen; match st.st_reason.(x) with None -> l | Some r -> r.reasons @ Array.fold_left (fun l p -> collect_rec st (var_of_lit p) l) l r.lits end let collect_reasons st x = st.st_seen <- st.st_seen + 1; collect_rec st x [] let collect_reasons_lst st l = st.st_seen <- st.st_seen + 1; let x = List.find (fun x -> st.st_assign.(x) = False) l in collect_rec st x [] let assignment st = st.st_assign end debrpmcheck-1.0/deb.ml0000644000042300001440000005626410451773302013212 0ustar dicosmo(* References ---------- - http://www.debian.org/doc/debian-policy/ch-controlfields.html http://www.debian.org/doc/debian-policy/ch-relationships.html - Eén and Sörensson, An Extensible SAT-Solver (An_Extensible_SAT-solver.ps) Mitchell, A SAT Solver Primer (colLogCS85.pdf) *) type t = { mutable next : unit -> string; mutable cur : string; mutable eof : bool } let eof i = i.eof let cur i = assert (not i.eof); i.cur let parse_error i = failwith "Parse error" let next i = assert (not i.eof); try i.cur <- i.next () with End_of_file -> i.eof <- true let start_from_fun f = let res = { next = f; cur = ""; eof = false } in next res; res let start_from_channel ch = start_from_fun (fun () -> input_line ch) (****) let is_blank i = not (eof i) && cur i = "" let skip_blank_lines i = while is_blank i do next i done let field_re = Str.regexp "^\\([^:]*\\)*:[ \t]*\\(.*\\)$" let remove_ws s = let l = String.length s in let p = ref (l - 1) in while !p >= 0 && (s.[!p] = ' ' || s.[!p] = '\t') do decr p done; if !p + 1 = l then s else String.sub s 0 (!p + 1) let parse_paragraph i = skip_blank_lines i; if eof i then None else begin let fields = ref [] in while let l = cur i in if not (Str.string_match field_re l 0) then parse_error i; let name = Str.matched_group 1 l in let data1 = remove_ws (Str.matched_group 2 l) in let data = ref [data1] in (* Format.eprintf "%s@." name; *) next i; while not (eof i || is_blank i) && let l = cur i in l.[0] = ' ' || l.[0] = '\t' do data := remove_ws (cur i) :: !data; next i done; fields := (name, List.rev !data) :: !fields; not (eof i || is_blank i) do () done; Some (List.rev !fields) end let single_line f l = match l with [s] -> s | _ -> Util.print_warning (Format.sprintf "field '%s' should be a single line" f); String.concat " " l let strict_package_re = Str.regexp "^[a-z0-9][a-z0-9.+-]+$" let package_re = Str.regexp "^[A-Za-z0-9][A-Za-z0-9._+-]+$" let check_package_name s = if not (Str.string_match strict_package_re s 0) then begin Util.print_warning (Format.sprintf "bad package name '%s'" s); if not (Str.string_match package_re s 0) then failwith (Format.sprintf "Bad package name '%s'@." s) end let parse_package s = check_package_name s; s let strict_version_re_1 = Str.regexp ("^\\(\\([0-9]+\\):\\)?" ^ "\\([0-9][A-Za-z0-9.:+-]*\\)" ^ "-\\([A-Za-z0-9.+]+\\)$") let strict_version_re_2 = Str.regexp ("^\\(\\([0-9]+\\):\\)?" ^ "\\([0-9][A-Za-z0-9.:+]*\\)\\( \\)?$") (* Some upstream version do not start with a digit *) let version_re_1 = Str.regexp "^\\(\\([0-9]+\\):\\)?\\([A-Za-z0-9._:+-]+\\)-\\([A-Za-z0-9.+]+\\)$" let version_re_2 = Str.regexp "^\\(\\([0-9]+\\):\\)?\\([A-Za-z0-9._:+]+\\)\\( \\)?$" let split_version s = if not (Str.string_match strict_version_re_1 s 0 || Str.string_match strict_version_re_2 s 0) && (Util.print_warning (Format.sprintf "bad version '%s'" s); not (Str.string_match version_re_1 s 0 || Str.string_match version_re_2 s 0)) then begin failwith ("Bad version " ^ s) end else begin let epoch = try int_of_string (Str.matched_group 2 s) with Not_found -> 0 in let upstream_version = Str.matched_group 3 s in let debian_revision = try Some (Str.matched_group 4 s) with Not_found -> None in (epoch, upstream_version, debian_revision) end let parse_version s = split_version s (* May need to accept package name containing "_" *) let token_re = Str.regexp ("[ \t]+\\|\\(" ^ String.concat "\\|" [","; "|"; "("; ")"; "<<"; "<="; "="; ">="; ">>"; "<"; ">"; "[A-Za-z0-9.:_+-]+"] ^ "\\)") let rec next_token s p = if !p = String.length s then raise End_of_file else if Str.string_match token_re s !p then begin p := Str.match_end (); try Str.matched_group 1 s with Not_found -> next_token s p end else failwith (Format.sprintf "Bad token in '%s' at %d" s !p) let start_token_stream s = let p = ref 0 in start_from_fun (fun () -> next_token s p) let expect s v = assert (not (eof s) && cur s = v); next s type rel = SE | E | EQ | L | SL let parse_package_dep f vers s = let name = cur s in check_package_name name; next s; if not (eof s) && cur s = "(" then begin if not vers then failwith (Format.sprintf "Package version not allowed in '%s'" f); next s; let comp = match cur s with "<<" -> SE | "<=" | "<" -> E | "=" -> EQ | ">=" | ">" -> L | ">>" -> SL | _ -> failwith (Format.sprintf "Bad relation '%s'" (cur s)) in next s; let version = split_version (cur s) in next s; expect s ")"; (name, Some (comp, version)) end else (name, None) let rec parse_package_disj f vers disj s = let nm = parse_package_dep f vers s in if eof s || cur s <> "|" then [nm] else begin if not disj then begin if f = "Enhances" then (*XXX Turn disjunction into conjunction? *) Util.print_warning (Format.sprintf "package disjunction not allowed in field '%s'" f) else failwith (Format.sprintf "Package disjunction not allowed in '%s'" f) end; next s; nm :: parse_package_disj f vers disj s end let rec parse_package_conj f vers disj s = let nm = parse_package_disj f vers disj s in if eof s then [nm] else if cur s = "," then begin next s; nm :: parse_package_conj f vers disj s end else failwith (Format.sprintf "Bad token '%s'" (cur s)) let parse_rel f vers disj s = let s = start_token_stream s in parse_package_conj f vers disj s type version = int * string * string option type dep = (string * (rel * version) option) list list type p = { mutable num : int; mutable package : string; mutable version : version; mutable depends : dep; mutable recommends : dep; mutable suggests : dep; mutable enhances : dep; mutable pre_depends : dep; mutable provides : dep; mutable conflicts : dep; mutable replaces : dep } let dummy_version = (-1, "", None) let print_version ch v = let (epoch, upstream_version, debian_revision) = v in if epoch <> 0 then Format.fprintf ch "%d:" epoch; Format.fprintf ch "%s" upstream_version; match debian_revision with None -> () | Some r -> Format.fprintf ch "-%s" r let parse_fields p = let q = { num = 0; package = " "; version = dummy_version; depends = []; recommends = []; suggests = []; enhances = []; pre_depends = []; provides = []; conflicts = []; replaces = [] } in List.iter (fun (f, l) -> match f with "Package" -> q.package <- parse_package (single_line f l) | "Version" -> q.version <- parse_version (single_line f l) | "Depends" -> q.depends <- parse_rel f true true (single_line f l) | "Recommends" -> q.recommends <- parse_rel f true true (single_line f l) | "Suggests" -> q.suggests <- parse_rel f true true (single_line f l) | "Enhances" -> q.enhances <- parse_rel f true false (single_line f l) | "Pre-Depends" -> q.pre_depends <- parse_rel f true true (single_line f l) | "Provides" -> q.provides <- parse_rel f false false (single_line f l) | "Conflicts" -> q.conflicts <- parse_rel f true false (single_line f l) | "Replaces" -> q.replaces <- parse_rel f true false (single_line f l) | _ -> ()) p; assert (q.package <> " "); assert (q.version <> dummy_version); q (****) type pool = { mutable size : int; packages : (string * version, p) Hashtbl.t; packages_by_name : (string, p list ref) Hashtbl.t; packages_by_num : (int, p) Hashtbl.t; provided_packages : (string, p list ref) Hashtbl.t } let new_pool () = { size = 0; packages = Hashtbl.create 101; packages_by_name = Hashtbl.create 101; packages_by_num = Hashtbl.create 101; provided_packages = Hashtbl.create 101 } let get_package_list' h n = try Hashtbl.find h n with Not_found -> let r = ref [] in Hashtbl.add h n r; r let add_to_package_list h n p = let l = get_package_list' h n in l := p :: !l let get_package_list h n = try !(Hashtbl.find h n) with Not_found -> [] let rec parse_packages_rec pool st i = Common.parsing_tick st; match parse_paragraph i with None -> () | Some p -> let p = parse_fields p in if not (Hashtbl.mem pool.packages (p.package, p.version)) then begin p.num <- pool.size; pool.size <- pool.size + 1; (* Format.eprintf "%s %a@." p.package print_version p.version; *) Hashtbl.add pool.packages (p.package, p.version) p; Hashtbl.add pool.packages_by_num p.num p; add_to_package_list pool.packages_by_name p.package p; add_to_package_list pool.provided_packages p.package p; List.iter (fun l -> match l with [(n, None)] -> add_to_package_list pool.provided_packages n p | _ -> assert false) p.provides end; parse_packages_rec pool st i let parse_packages ch = let i = start_from_channel ch in let pool = new_pool () in let st = Common.start_parsing true ch in parse_packages_rec pool st i; Common.stop_parsing st; pool (****) let is_letter c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') let is_num c = c >= '0' && c <= '9' let char_map = Array.init 256 (fun c -> if is_letter (Char.chr c) then c else c + 256) let compare_ver_char c1 c2 = compare (char_map.(Char.code c1)) (char_map.(Char.code c2)) let compare_ver_str s1 s2 = let l1 = String.length s1 in let l2 = String.length s2 in let p1 = ref 0 in let p2 = ref 0 in while !p1 < l1 && !p2 < l2 && s1.[!p1] = s2.[!p2] do incr p1; incr p2 done; if !p1 = l1 then begin if !p2 = l2 then 0 else -1 end else if !p2 = l2 then 1 else compare_ver_char s1.[!p1] s2.[!p2] let first_num s p l = let p = ref p in while !p < l && (s.[!p] < '0' || s.[!p] > '9') do incr p done; !p let last_num s p l = let p = ref p in while !p < l && (s.[!p] >= '0' && s.[!p] <= '9') do incr p done; !p let rec compare_rev_rec s1 p1 l1 s2 p2 l2 = let p1' = first_num s1 p1 l1 in let p2' = first_num s2 p2 l2 in let s1' = String.sub s1 p1 (p1' - p1) in let s2' = String.sub s2 p2 (p2' - p2) in let c = compare_ver_str s1' s2' in if c <> 0 then c else let p1'' = last_num s1 p1' l1 in let p2'' = last_num s2 p2' l2 in let s1' = String.sub s1 p1' (p1'' - p1') in let s2' = String.sub s2 p2' (p2'' - p2') in let i1 = if s1' = "" then 0. else float_of_string s1' in let i2 = if s2' = "" then 0. else float_of_string s2' in let c = compare i1 i2 in if c <> 0 then c else if p1'' = l1 && p2'' = l2 then 0 else compare_rev_rec s1 p1'' l1 s2 p2'' l2 let compare_rev s1 s2 = (* Printf.eprintf "'%s' '%s' %!" s1 s2; *) let c = compare_rev_rec s1 0 (String.length s1) s2 0 (String.length s2) in (* Printf.eprintf "%d\n%!" c; *) c let compare_version v1 v2 = let (epoch1, upstream_version1, debian_revision1) = v1 in let (epoch2, upstream_version2, debian_revision2) = v2 in let c = compare epoch1 epoch2 in if c <> 0 then c else let c = compare_rev upstream_version1 upstream_version2 in if c <> 0 then c else match debian_revision1, debian_revision2 with None, None -> 0 | None, _ -> -1 | _, None -> 1 | Some r1, Some r2 -> compare_rev r1 r2 (****) let print_pack pool ch n = let p = Hashtbl.find pool.packages_by_num n in Format.fprintf ch "%s (= %a)" p.package print_version p.version (****) let rec remove_duplicates_rec x (l : int list) = match l with [] -> [x] | y :: r -> if x = y then remove_duplicates_rec x r else x :: remove_duplicates_rec y r let remove_duplicates l = match l with [] -> [] | x :: r -> remove_duplicates_rec x r let normalize_set (l : int list) = remove_duplicates (List.sort (fun x y -> compare x y) l) (****) type deb_reason = R_conflict of int * int | R_depends of int * (string * (rel * (int * string * string option)) option) list (****) module Solver = Solver.M (struct type reason = deb_reason end) let print_rules = ref false let add_conflict st l = let l = normalize_set l in if List.length l > 1 then begin if !print_rules then begin Format.printf "conflict ("; List.iter (fun c -> Format.printf " %d" c) l; Format.printf ")@." end; let a = Array.of_list l in let len = Array.length a in for i = 0 to len - 2 do for j = i + 1 to len - 1 do let p = Solver.lit_of_var a.(i) false in let p' = Solver.lit_of_var a.(j) false in Solver.add_bin_rule st p p' [R_conflict (a.(i), a.(j))] done done end let add_depend st deps n l = let l = normalize_set l in (* Some packages depend on themselves... *) if not (List.memq n l) then begin if !print_rules then begin Format.printf "%d -> any-of (" n; List.iter (fun c -> Format.printf " %d" c) l; Format.printf ")@." end; Solver.add_rule st (Array.of_list (Solver.lit_of_var n false :: List.map (fun n' -> Solver.lit_of_var n' true) l)) [R_depends (n, deps)]; match l with [] | [_] -> () | _ -> Solver.associate_vars st (Solver.lit_of_var n true) l end (****) let filter_rel rel c = match rel with SE -> c < 0 | E -> c <= 0 | EQ -> c = 0 | L -> c >= 0 | SL -> c > 0 let resolve_package_dep pool (n, cstr) = match cstr with None -> List.map (fun p -> p.num) (get_package_list pool.provided_packages n) | Some (rel, vers) -> List.map (fun p -> p.num) (List.filter (fun p -> filter_rel rel (compare_version p.version vers)) (get_package_list pool.packages_by_name n)) let single l = match l with [x] -> x | _ -> assert false let generate_rules pool = let st = Common.start_generate (not !print_rules) pool.size in let pr = Solver.initialize_problem ~print_var:(print_pack pool) pool.size in (* Cannot install two packages with the same name *) Hashtbl.iter (fun _ l -> add_conflict pr (List.map (fun p -> p.num) !l)) pool.packages_by_name; Hashtbl.iter (fun _ p -> Common.generate_next st; if !print_rules then Format.eprintf "%s %a@." p.package print_version p.version; (* Dependences *) List.iter (fun l -> add_depend pr l p.num (List.flatten (List.map (fun p -> resolve_package_dep pool p) l))) p.depends; List.iter (fun l -> add_depend pr l p.num (List.flatten (List.map (fun p -> resolve_package_dep pool p) l))) p.pre_depends; (* Conflicts *) List.iter (fun n -> add_conflict pr [p.num; n]) (normalize_set (List.flatten (List.map (fun p -> resolve_package_dep pool (single p)) p.conflicts)))) pool.packages; Common.stop_generate st; Solver.propagate pr; pr (****) let print_rel ch rel = Format.fprintf ch "%s" (match rel with SE -> "<<" | E -> "<=" | EQ -> "=" | L -> ">=" | SL -> ">>") let print_package_ref ch (p, v) = Format.fprintf ch "%s" p; match v with None -> () | Some (rel, vers) -> Format.fprintf ch " (%a %a)" print_rel rel print_version vers let rec print_package_disj ch l = match l with [] -> () | [p] -> print_package_ref ch p | p :: r -> print_package_ref ch p; Format.fprintf ch " | "; print_package_disj ch r let check pool st = let assign = Solver.assignment st in Array.iteri (fun i v -> if v = Solver.True then begin let p = Hashtbl.find pool.packages_by_num i in Format.printf "Package: %a@." (print_pack pool) i; (* XXX No other package of the same name *) List.iter (fun p -> if p.num <> i && assign.(p.num) = Solver.True then begin Format.eprintf "PACKAGE %a ALSO INSTALLED!@." (print_pack pool) p.num; exit 1 end) !(Hashtbl.find pool.packages_by_name p.package); if p.depends <> [] then begin Format.printf "Depends: "; List.iter (fun l -> Format.printf "%a " print_package_disj l; try let n = List.find (fun n -> assign.(n) = Solver.True) (List.flatten (List.map (resolve_package_dep pool) l)) in Format.printf "{%a}, " (print_pack pool) n with Not_found -> Format.printf "{UNSATISFIED}@."; exit 1) p.depends; Format.printf "@." end; if p.pre_depends <> [] then begin Format.printf "Pre-Depends: "; List.iter (fun l -> Format.printf "%a " print_package_disj l; try let n = List.find (fun n -> assign.(n) = Solver.True) (List.flatten (List.map (resolve_package_dep pool) l)) in Format.printf "{%a}, " (print_pack pool) n with Not_found -> Format.printf "{UNSATISFIED}@."; exit 1) p.pre_depends; Format.printf "@." end; if p.conflicts <> [] then begin Format.printf "Conflicts: "; List.iter (fun l -> Format.printf "%a " print_package_disj l; try let n = List.find (fun n -> n <> i && assign.(n) = Solver.True) (resolve_package_dep pool (single l)) in Format.printf "{CONFLICT: %a}" (print_pack pool) n; exit 1 with Not_found -> Format.printf "{ok}, ") p.conflicts; Format.printf "@." end end) assign (****) let show_success = ref true let show_failure = ref true let print_results = ref true let check_results = ref false let explain_results = ref false let success pool tested st i = if !show_success then begin if !print_results then begin Format.printf "%a: OK@." (print_pack pool) i; let assign = Solver.assignment st in for j = i + 1 to pool.size - 1 do if not tested.(j) && assign.(j) = Solver.True then begin tested.(j) <- true; Format.printf " %a: OK@." (print_pack pool) j end done end; if !explain_results || !check_results then check pool st end let rec print_package_list_rec pool ch l = match l with [] -> Format.fprintf ch "NOT AVAILABLE" | [x] -> print_pack pool ch x | x :: r -> Format.fprintf ch "%a, %a" (print_pack pool) x (print_package_list_rec pool) r let print_package_list pool ch l = Format.fprintf ch "{%a}" (print_package_list_rec pool) l let show_reasons pool l = if l <> [] then begin Format.printf "The following constraints cannot be satisfied:@."; List.iter (fun r -> match r with R_conflict (n1, n2) -> Format.printf " %a conflicts with %a@." (print_pack pool) n1 (print_pack pool) n2 | R_depends (n, l) -> Format.printf " %a depends on %a %a@." (print_pack pool) n print_package_disj l (print_package_list pool) (List.flatten (List.map (resolve_package_dep pool) l))) l end let failure pool st i = if !show_failure then begin if !print_results then begin Format.printf "%a: FAILED@." (print_pack pool) i; end; if !explain_results || !check_results then begin (* Find reasons for the failure *) (* Solver.reset st; let res = Solver.solve_2 st i in assert (res = false); *) show_reasons pool (Solver.collect_reasons st i) end end let _ = let packages = ref [] in Arg.parse ["-check", Arg.Unit (fun () -> check_results := true), " Double-check the results"; "-explain", Arg.Unit (fun () -> explain_results := true), " Explain the results"; "-rules", Arg.Unit (fun () -> print_rules := true), " Print generated rules"; "-failures", Arg.Unit (fun () -> show_success := false), " Only show failures"; "-successes", Arg.Unit (fun () -> show_failure := false), " Only show successes"] (fun p -> packages := p :: !packages) ("Usage: " ^ Sys.argv.(0) ^ " [OPTION]... [PACKAGE]...\n\ Check whether the given packages can be installed. A binary package\n\ control file is read from the standard input. The names (for instance,\n\ 'emacsen') of the packages to be tested should be given on the command\n\ line. A specific version of a package can be selected by following\n\ the package name with an equals and the version of the package to test\n\ (for instance, 'xemacs21=21.4.17-1'). When no package name is provided,\n\ all packages in the control file are tested.\n\ \n\ Options:"); let ch = stdin (*(open_in "Packages-pool")*) in let pool = parse_packages ch in let st = generate_rules pool in let tested = Array.make pool.size (!packages <> []) in List.iter (fun p -> let ref = try let i = String.index p '=' in let vers = String.sub p (i + 1) (String.length p - i - 1) in let p = String.sub p 0 i in (p, Some (EQ, (split_version vers))) with Not_found -> (p, None) in List.iter (fun i -> tested.(i) <- false) (resolve_package_dep pool ref)) !packages; let t = Unix.gettimeofday () in let step = max 1 (pool.size / 1000) in for i = 0 to pool.size - 1 do if not tested.(i) then begin if !packages <> [] then begin (* Slower but generates smaller set of installed packages *) Solver.reset st; if Solver.solve st i then success pool tested st i else failure pool st i end else begin if i mod step = 0 && not (!show_success && (!print_results || !explain_results || !check_results)) then Util.set_msg (Format.sprintf "Checking packages... %3.f%% %6d packages" (float i *. 100. /. float pool.size) i); if Solver.solve st i then success pool tested st i else begin (*Format.printf "%a: RETRYING@." (print_pack pool) i;*) Solver.reset st; if Solver.solve st i then begin success pool tested st i end else begin Util.hide_msg (); failure pool st i; Util.show_msg (); Solver.reset st; end end end end done; Util.set_msg ""; Format.eprintf "Checking packages... %.1f seconds@." (Unix.gettimeofday () -. t); (* TODO Deal with suggests, recommends, enhances Difference check (silent)/explain Line numbers in warnings, errors during parsing Provide package file on command line *) debrpmcheck-1.0/solver.mli0000644000042300001440000000152210451773302014126 0ustar dicosmo module type S = sig type reason end module M (X : S) : sig type state type var = int type lit val lit_of_var : var -> bool -> lit val initialize_problem : ?print_var:(Format.formatter -> int -> unit) -> int -> state val propagate : state -> unit val protect : state -> unit val reset : state -> unit type value = True | False | Unknown val assignment : state -> value array val add_un_rule : state -> lit -> X.reason list -> unit val add_bin_rule : state -> lit -> lit -> X.reason list -> unit val add_rule : state -> lit array -> X.reason list -> unit val associate_vars : state -> lit -> var list -> unit val solve : state -> var -> bool val solve_lst : state -> var list -> bool val collect_reasons : state -> var -> X.reason list val collect_reasons_lst : state -> var list -> X.reason list end debrpmcheck-1.0/rpm.ml0000644000042300001440000007420410451773302013250 0ustar dicosmo(* References ---------- http://rpm.org/ rpm sources *) (* XXXX Validator (check that the fields all have the right type) XXXX Check results XXXX Print generated rules XXXX Share more code with deb.ml *) type typ = NULL | CHAR | INT8 | INT16 | INT32 | INT64 | STRING | BIN | STRING_ARRAY | I18NSTRING | UNKOWNTYPE of int let intern_typ i = match i with 0 -> NULL | 1 -> CHAR | 2 -> INT8 | 3 -> INT16 | 4 -> INT32 | 5 -> INT64 | 6 -> STRING | 7 -> BIN | 8 -> STRING_ARRAY | 9 -> I18NSTRING | _ -> Util.print_warning (Format.sprintf "unknown type %d" i); UNKOWNTYPE i let substring ch l = let s = String.create l in really_input ch s 0 l; s let int ch = let s = substring ch 4 in Char.code s.[0] lsl 24 + Char.code s.[1] lsl 16 + Char.code s.[2] lsl 8 + Char.code s.[3] let sstring store pos = let len = ref 0 in while store.[pos + !len] <> '\000' do incr len done; String.sub store pos !len let rec sstring_array_rec store pos count = if count = 0 then [] else let s = sstring store pos in s :: sstring_array_rec store (pos + String.length s + 1) (count - 1) let sstring_array store pos count = Array.of_list (sstring_array_rec store pos count) let rec sarray_rec l f store pos count = if count = 0 then [] else let s = f store pos in s :: sarray_rec l f store (pos + l) (count - 1) let sarray l f store pos count = Array.of_list (sarray_rec l f store pos count) let sint32 s pos = Char.code s.[pos] lsl 24 + Char.code s.[pos + 1] lsl 16 + Char.code s.[pos + 2] lsl 8 + Char.code s.[pos + 3] let sint32_array = sarray 4 sint32 let sint16 s pos = Char.code s.[pos] lsl 8 + Char.code s.[pos + 1] let sint16_array = sarray 2 sint16 (****) let pr_typ ch t = Format.fprintf ch "%s" (match t with NULL -> "NULL" | CHAR -> "CHAR" | INT8 -> "INT8" | INT16 -> "INT16" | INT32 -> "INT32" | INT64 -> "INT64" | STRING -> "STRING" | BIN -> "BIN" | STRING_ARRAY -> "STRING_ARRAY" | I18NSTRING -> "I18NSTRING" | UNKOWNTYPE i -> "UNKOWNTYPE(" ^ string_of_int i ^ ")") let tags = [( 63, (BIN, "HEADERIMMUTABLE", false)); ( 100, (STRING_ARRAY, "HEADERI18NTABLE", false)); ( 257, (INT32, "SIGSIZE", false)); ( 261, (BIN, "SIGMD5", false)); ( 262, (BIN, "SIGGPG", false)); ( 267, (BIN, "DSAHEADER", false)); ( 269, (STRING, "SHA1HEADER", false)); (1000, (STRING, "NAME", true)); (* ! *) (1001, (STRING, "VERSION", true)); (* ! *) (1002, (STRING, "RELEASE", true)); (* ! *) (1003, (INT32, "EPOCH", true)); (* ! *) (1004, (I18NSTRING, "SUMMARY", false)); (1005, (I18NSTRING, "DESCRIPTION", false)); (1006, (INT32, "BUILDTIME", false)); (1007, (STRING, "BUILDHOST", false)); (1009, (INT32, "SIZE", false)); (1010, (STRING, "DISTRIBUTION", false)); (1011, (STRING, "VENDOR", false)); (1012, (BIN, "GIF", false)); (1013, (BIN, "XPM", false)); (1014, (STRING, "LICENSE", false)); (1015, (STRING, "PACKAGER", false)); (1016, (I18NSTRING, "GROUP", false)); (1020, (STRING, "URL", false)); (1021, (STRING, "OS", false)); (1022, (STRING, "ARCH", false)); (1023, (STRING, "PREIN", false)); (1024, (STRING, "POSTIN", false)); (1025, (STRING, "PREUN", false)); (1026, (STRING, "POSTUN", false)); (1028, (INT32, "FILESIZES", false)); (1030, (INT16, "FILEMODES", true)); (* ! *) (1033, (INT16, "FILERDEVS", false)); (1034, (INT32, "FILEMTIMES", false)); (1035, (STRING_ARRAY, "FILEMD5S", true)); (* ! *) (1036, (STRING_ARRAY, "FILELINKTOS", true)); (* ! *) (1037, (INT32, "FILEFLAGS", false)); (1039, (STRING_ARRAY, "FILEUSERNAME", false)); (1040, (STRING_ARRAY, "FILEGROUPNAME", false)); (1044, (STRING, "SOURCERPM", false)); (1045, (INT32, "FILEVERIFYFLAGS", false)); (1046, (INT32, "ARCHIVESIZE", false)); (1047, (STRING_ARRAY, "PROVIDENAME", true)); (* ! *) (1048, (INT32, "REQUIREFLAGS", true)); (* ! *) (1049, (STRING_ARRAY, "REQUIRENAME", true)); (* ! *) (1050, (STRING_ARRAY, "REQUIREVERSION", true)); (* ! *) (1053, (INT32, "CONFLICTFLAGS", true)); (* ! *) (1054, (STRING_ARRAY, "CONFLICTNAME", true)); (* ! *) (1055, (STRING_ARRAY, "CONFLICTVERSION", true)); (* ! *) (1064, (STRING, "RPMVERSION", false)); (1065, (STRING_ARRAY, "TRIGGERSCRIPTS", false)); (1066, (STRING_ARRAY, "TRIGGERNAME", false)); (1067, (STRING_ARRAY, "TRIGGERVERSION", false)); (1068, (INT32, "TRIGGERFLAGS", false)); (1069, (INT32, "TRIGGERINDEX", false)); (1079, (STRING, "VERIFYSCRIPT", false)); (1080, (INT32, "CHANGELOGTIME", false)); (1081, (STRING_ARRAY, "CHANGELOGNAME", false)); (1082, (STRING_ARRAY, "CHANGELOGTEXT", false)); (1085, (STRING, "PREINPROG", false)); (1086, (STRING, "POSTINPROG", false)); (1087, (STRING, "PREUNPROG", false)); (* (1087, (STRING_ARRAY, "PREUNPROG", false)); *) (1088, (STRING, "POSTUNPROG", false)); (1090, (STRING_ARRAY, "OBSOLETENAME", false)); (1091, (STRING, "VERIFYSCRIPTPROG", false)); (1092, (STRING_ARRAY, "TRIGGERSCRIPTPROG", false)); (1094, (STRING, "COOKIE", false)); (1095, (INT32, "FILEDEVICES", false)); (1096, (INT32, "FILEINODES", false)); (1097, (STRING_ARRAY, "FILELANGS", false)); (1098, (STRING_ARRAY, "PREFIXES", false)); (* ? *) (1112, (INT32, "PROVIDEFLAGS", true)); (* ! *) (1113, (STRING_ARRAY, "PROVIDEVERSION", true)); (* ! *) (1114, (INT32, "OBSOLETEFLAGS", false)); (1115, (STRING_ARRAY, "OBSOLETEVERSION", false)); (1116, (INT32, "DIRINDEXES", true)); (* ! *) (1117, (STRING_ARRAY, "BASENAMES", true)); (* ! *) (1118, (STRING_ARRAY, "DIRNAMES", true)); (* ! *) (1122, (STRING, "OPTFLAGS", false)); (1124, (STRING, "PAYLOADFORMAT", false)); (1125, (STRING, "PAYLOADCOMPRESSOR", false)); (1126, (STRING, "PAYLOADFLAGS", false)); (1131, (STRING, "RHNPLATFORM", false)); (1132, (STRING, "PLATFORM", false)); (1140, (INT32, "FILECOLORS", false)); (* ? *) (* 1 = elf32, 2 = elf64, 0 = other *) (1141, (INT32, "FILECLASS", false)); (1142, (STRING_ARRAY, "CLASSDICT", false)); (1143, (INT32, "FILEDEPENDSX", false)); (* ? *) (1144, (INT32, "FILEDEPENDSN", false)); (* ? *) (1145, (INT32, "DEPENDSDICT", false)); (* ? *) (1146, (BIN, "SOURCEPKGID", false)); (1152, (STRING, "POSTTRANS", false)); (1154, (STRING, "POSTTRANSPROG", false)); (1000000, (STRING, "FILENAME", false)); (1000001, (INT32, "FILESIZE", false)); (1000005, (STRING, "MD5", false)); (1000010, (STRING, "DIRECTORY", false))] let tag_name tag typ = try List.assoc tag tags with Not_found -> Util.print_warning (Format.sprintf "unknown tag %d" tag); (typ, Format.sprintf "UNKNOWN(%d)" tag, true) let pr_tag ch tag = let (_, nm, _) = tag_name tag BIN (* Dummy type*) in Format.fprintf ch "%s" nm let pr_field_contents ch (store, (_, typ, pos, count)) = match typ with STRING -> Format.fprintf ch "\"%s\"" (String.escaped (sstring store pos)) | STRING_ARRAY -> Array.iter (fun s -> Format.fprintf ch "\"%s\" " (String.escaped s)) (sstring_array store pos count) | INT32 -> Array.iter (fun i -> Format.fprintf ch "0x%x " i) (sint32_array store pos count) | INT16 -> Array.iter (fun i -> Format.fprintf ch "0x%x " i) (sint16_array store pos count) | _ -> Format.fprintf ch "(not shown)" let show_all = ref false let pr_field ch ((store, (tag, typ, pos, count)) as field) = let (typ', nm, shown) = tag_name tag typ in if typ <> typ' then Util.print_warning (Format.sprintf "wrong type for tag %s" nm); if shown || !show_all then begin Format.fprintf ch "%s %a 0x%x %d" nm pr_typ typ pos count; Format.fprintf ch " %a@." pr_field_contents field end let pr_fields store entry = for i = 0 to Array.length entry - 1 do let (tag, typ, pos, count) as field = entry.(i) in Format.printf "%a" pr_field (store, field) done; Format.printf "@." (****) let _NAME = 1000 let _VERSION = 1001 let _RELEASE = 1002 let _EPOCH = 1003 let _FILEMODES = 1030 let _FILEMD5S = 1035 let _FILELINKTOS = 1036 let _PROVIDENAME = 1047 let _REQUIREFLAGS = 1048 let _REQUIRENAME = 1049 let _REQUIREVERSION = 1050 let _CONFLICTFLAGS = 1053 let _CONFLICTNAME = 1054 let _CONFLICTVERSION = 1055 let _OBSOLETENAME = 1090 let _PROVIDEFLAGS = 1112 let _PROVIDEVERSION = 1113 let _OBSOLETEFLAGS = 1114 let _OBSOLETENVERSION = 1115 let _DIRINDEXES = 1116 let _BASENAMES = 1117 let _DIRNAMES = 1118 let etag entry i = let (tag, _, _, _) = entry.(i) in tag let rec move_to entry i tag = if etag entry i >= tag then i else move_to entry (i + 1) tag let check_entry tag typ tag' typ' = if tag <> tag' then begin let b = Buffer.create 80 in Format.bprintf b "Expected tag %a but actual tag is %a@?" pr_tag tag pr_tag tag'; Util.fail (Buffer.contents b) end; if typ <> typ' then begin let b = Buffer.create 80 in Format.bprintf b "Entry %a has expected type %a but actual typ is %a@?" pr_tag tag pr_typ typ pr_typ typ'; Util.fail (Buffer.contents b) end let estring store entry i tag = let (tag', typ, pos, count) = entry.(i) in check_entry tag STRING tag' typ; if count <> 1 then begin let b = Buffer.create 80 in Format.bprintf b "Entry %a has type STRING with count %d > 1@?" pr_tag tag count; Util.fail (Buffer.contents b) end; sstring store pos let estring_array store entry i tag = let (tag', typ, pos, count) = entry.(i) in check_entry tag STRING_ARRAY tag' typ; sstring_array store pos count let eint32 store entry i tag = let (tag', typ, pos, count) = entry.(i) in check_entry tag INT32 tag' typ; if count <> 1 then begin let b = Buffer.create 80 in Format.bprintf b "Expecting a single INT32 for entry %a but got %d@?" pr_tag tag count; Util.fail (Buffer.contents b) end; sint32 store pos let eint32_array store entry i tag = let (tag', typ, pos, count) = entry.(i) in check_entry tag INT32 tag' typ; sint32_array store pos count let eint16_array store entry i tag = let (tag', typ, pos, count) = entry.(i) in check_entry tag INT16 tag' typ; sint16_array store pos count (****) type file_info = Dir | Char | Block | Link of string | Sock | Pipe | Reg of string let intern_file filemodes filemd5s filelinktos i = let mode = filemodes.(i) in match mode land 0o170000 with 0o40000 -> Dir | 0o20000 -> Char | 0o60000 -> Block | 0o120000 -> Link (filelinktos.(i)) | 0o140000 -> Sock | 0o10000 -> Pipe | 0o100000 -> Reg (filemd5s.(i)) | _ -> Util.fail (Format.sprintf "unknown mode %o" mode) (****) type rel = SE | E | EQ | L | SL | ALL let pr_rel ch rel = Format.fprintf ch "%s" (match rel with SE -> "<<" | E -> "<=" | EQ -> "=" | L -> ">=" | SL -> ">>" | ALL -> "ALL") let intern_flags f = match f land 15 with 0 -> ALL | 2 -> SE | 10 -> E | 8 -> EQ | 12 -> L | 4 -> SL | _ -> Util.fail (Format.sprintf "Wrong flag %d" (f land 15)) let rpmlib_dep name flags i = flags.(i) land (1 lsl 24) <> 0 || let nm = name.(i) in (String.length nm > 8 && nm.[0] = 'r' && nm.[1] = 'p' && nm.[2] = 'm' && nm.[3] = 'l' && nm.[4] = 'i' && nm.[5] = 'b' && nm.[6] = '(') type vers = int option * string * string option type pack_ref = string * rel * vers option type p = { num : int; name : string; version : string; release : string; epoch : int option; provide : pack_ref list; require : pack_ref list; conflict : pack_ref list } let files = Hashtbl.create 300000 let add_file f v = let l = try Hashtbl.find files f with Not_found -> let l = ref [] in Hashtbl.add files f l; l in l := v :: !l let provides = Hashtbl.create 10000 let add_provide p (nm, rel, vers) = let l = try Hashtbl.find provides nm with Not_found -> let l = ref [] in Hashtbl.add provides nm l; l in l := (rel, vers, p) :: !l let num = ref 0 let packages = ref [] let packages_by_num = Hashtbl.create 1000 (****) let pr_version ch (epoch, version, release) = begin match epoch with None -> () | Some e -> Format.fprintf ch "%d:" e end; Format.fprintf ch "%s" version; match release with Some r -> Format.fprintf ch "-%s" r | None -> () let is_lower c = c >= 'a' && c <= 'z' let is_upper c = c >= 'A' && c <= 'Z' let is_digit c = c >= '0' && c <= '9' let is_alpha c = is_lower c || is_upper c let is_alnum c = is_alpha c || is_digit c (* parseEVR, rpmds.c *) let version_re_1 = Str.regexp "^\\(\\([0-9]*\\):\\)?\\(.*\\)-\\([^-]*\\)$" let version_re_2 = Str.regexp "^\\(\\([0-9]*\\):\\)?\\(.*\\)\\(-\\)?$" (* HACK: last parenthesis never matched *) let check_version s = s <> "" && not (is_alnum s.[String.length s - 1]) let parse_version s = if s = "" then None else if not (Str.string_match version_re_1 s 0 || Str.string_match version_re_2 s 0) then failwith ("Bad version " ^ s) else begin let epoch = try let s = Str.matched_group 2 s in Some (if s = "" then 0 else int_of_string s) with Not_found -> None in let version = Str.matched_group 3 s in let release = try Some (Str.matched_group 4 s) with Not_found -> None in if check_version s || match release with Some r -> check_version r | _ -> false then begin let b = Buffer.create 80 in Format.bprintf b "version '%a' not ending with an alphanumeric character@?" pr_version (epoch, version, release); Util.print_warning (Buffer.contents b) end; Some (epoch, version, release) end let rec split_vers_rec s p l = let q = ref p in while !q < l && not (is_alnum s.[!q]) do incr q done; if !q = l then begin if p = !q then [] else [`Other] end else begin let p = !q in if is_digit s.[p] then begin let q = ref p in while !q < l && s.[!q] = '0' do incr q done; let p = !q in while !q < l && is_digit s.[!q] do incr q done; `Num (String.sub s p (!q - p)) :: split_vers_rec s !q l end else (* if is_alpha s.[p] then*) begin let q = ref (p + 1) in while !q < l && is_alpha s.[!q] do incr q done; `Alpha (String.sub s p (!q - p)) :: split_vers_rec s !q l end end let split_vers s = split_vers_rec s 0 (String.length s) let rec compare_vers_rec l1 l2 = match l1, l2 with `Alpha s1 :: r1, `Alpha s2 :: r2 -> let c = compare s1 s2 in if c <> 0 then c else compare_vers_rec r1 r2 | `Num n1 :: r1, `Num n2 :: r2 -> let c = compare (String.length n1) (String.length n2) in if c <> 0 then c else let c = compare n1 n2 in if c <> 0 then c else compare_vers_rec r1 r2 | `Num _ :: _, `Alpha _ :: _ | `Num _ :: _, `Other :: _ -> 1 | `Alpha _ :: _, `Num _ :: _ | `Alpha _ :: _, `Other :: _ -> -1 | `Other :: _, `Alpha _ :: _ | `Other :: _, `Num _ :: _ (* Should have been 1 *) | `Other :: _, `Other :: _ -> (* Should have been 0 *) -1 | [], [] -> 0 | _, [] -> 1 | [], _ -> -1 (* Not stable by extension 10 < 10a 10a.5 < 10.5 Not a total order 10. < 10, 10, < 10. 10.a < 10. 10. < 10.a (but 10.1 > 10. 10. < 10.1) *) (*rpmvercmp.c*) let compare_vers s1 s2 = if s1 = s2 then 0 else compare_vers_rec (split_vers s1) (split_vers s2) let promote = ref false let compare_versions ver1 ver2 = match ver1, ver2 with Some (e1, v1, r1), Some (e2, v2, r2) -> let c2 = let c = compare_vers v1 v2 in if c <> 0 then c else match r1, r2 with Some r1, Some r2 -> compare_vers r1 r2 | _ -> 0 in let c1 = match e1, e2 with None, None | None, Some 0 | Some 0, None -> 0 | Some e1, Some e2 -> compare (e1 : int) e2 | None, Some _ -> -1 | Some _, None -> if !promote then 0 else 1 in if c1 <> 0 then c1 else c2 | _ -> (* Checked in function validate_deps *) assert false (* rpmdsCompare, rpmds.c *) let compare_pack_refs (n1, r1, v1) (n2, r2, v2) = n1 = n2 && match r1, r2 with ALL, _ | _, ALL | (SE | E), (SE | E) | (SL | L), (SL | L) -> true | (EQ | L | SL), SE | SL, (EQ | E) -> compare_versions v1 v2 < 0 | SE, (EQ | L | SL) | (EQ | E), SL -> compare_versions v1 v2 > 0 | EQ, E | L, E | L, EQ -> compare_versions v1 v2 <= 0 | E, EQ | E, L | EQ, L -> compare_versions v1 v2 >= 0 | EQ, EQ -> compare_versions v1 v2 = 0 let pr_pack_ref ch (name, rel, ver) = Format.fprintf ch "%s" name; match ver with Some v -> Format.fprintf ch " (%a %a)" pr_rel rel pr_version v | None -> () let pr_pack ch p = pr_pack_ref ch (p.name, EQ, Some (p.epoch, p.version, Some p.release)) let resolve_file_dep (nm, rel, ver) = if nm = "" || nm.[0] <> '/' then [] else begin let i = String.rindex nm '/' in let d = String.sub nm 0 (i + 1) in let f = String.sub nm (i + 1) (String.length nm - i - 1) in let l = try !(Hashtbl.find files (d, f)) with Not_found -> [] in List.map (fun (_, p) -> p) l end let resolve_pack_ref ((nm, rel, ver) as rf) = let l = try let l = !(Hashtbl.find provides nm) in List.filter (fun (rel, vers, p) -> (* The order here is important: the comparison is not symmetric! *) compare_pack_refs (nm, rel, vers) rf) l with Not_found -> [] in resolve_file_dep rf @ List.map (fun (rel, vers, p) -> p) l let validate_deps l = List.iter (fun (nm, rel, ver) -> match rel, ver with ALL, Some _ -> assert false | ALL, None -> () | _, None -> assert false | _, Some _ -> ()) l let parse_deps name flags version = let l = ref [] in for i = Array.length name - 1 downto 0 do if not (rpmlib_dep name flags i) then begin l := (name.(i), intern_flags flags.(i), parse_version version.(i)) :: !l end done; validate_deps !l; !l let dump_fields = ref false let parse_header ch = let h = substring ch 8 in if not (h.[0] = '\142' && h.[1] = '\173' && h.[2] = '\232') then Util.fail "Bad header"; let entry_count = int ch in let sz = int ch in (*Format.eprintf "%d %d@." entry_count sz;*) let entry = Array.make entry_count (0, NULL, 0, 0) in for i = 0 to entry_count - 1 do let tag = int ch in let typ = intern_typ (int ch) in let pos = int ch in let count = int ch in (* Format.eprintf "%d %a@." tag pr_typ typ;*) entry.(i) <- (tag, typ, pos, count) done; Array.sort (fun (tag1, _, _, _) (tag2, _, _, _) -> compare tag1 tag2) entry; let store = substring ch sz in let i = move_to entry 0 _NAME in let name = estring store entry i _NAME in let version = estring store entry (i + 1) _VERSION in let release = estring store entry (i + 2) _RELEASE in assert (version <> ""); assert (release <> ""); let epoch = if etag entry (i + 3) <> _EPOCH then None else Some (eint32 store entry (i + 3) _EPOCH) in Util.set_warning_location (match epoch with None -> Format.sprintf "in package %s = %s-%s" name version release | Some e -> Format.sprintf "in package %s = %d:%s-%s" name e version release); if !dump_fields then pr_fields store entry; let i = move_to entry i _FILEMODES in let file_info = etag entry i = _FILEMODES in let filemodes = if file_info then eint16_array store entry i _FILEMODES else [||] in let i = move_to entry i _FILEMD5S in let filemd5s = if file_info then estring_array store entry i _FILEMD5S else [||] in let filelinktos = if file_info then estring_array store entry (i + 1) _FILELINKTOS else [||] in let i = move_to entry i _PROVIDENAME in let providename = estring_array store entry i _PROVIDENAME in let requireflags = eint32_array store entry (i + 1) _REQUIREFLAGS in let requirename = estring_array store entry (i + 2) _REQUIRENAME in let requireversion = estring_array store entry (i + 3) _REQUIREVERSION in let i = move_to entry i _CONFLICTFLAGS in let has_confl = etag entry i = _CONFLICTFLAGS in let conflictflags = if has_confl then eint32_array store entry i _CONFLICTFLAGS else [||] in let conflictname = if has_confl then estring_array store entry (i + 1) _CONFLICTNAME else [||] in let conflictversion = if has_confl then estring_array store entry (i + 2) _CONFLICTVERSION else [||] in let i = move_to entry i _PROVIDEFLAGS in let provideflags = eint32_array store entry i _PROVIDEFLAGS in let provideversion = estring_array store entry (i + 1) _PROVIDEVERSION in let i = move_to entry i _DIRINDEXES in let non_empty = etag entry i = _DIRINDEXES in let dirindexes = if non_empty then eint32_array store entry i _DIRINDEXES else [||] in let basenames = if non_empty then estring_array store entry (i + 1) _BASENAMES else [||] in let dirnames = if non_empty then estring_array store entry (i + 2) _DIRNAMES else [||] in let p = { num = !num; name = name; version = version; release = release; epoch = epoch; provide = parse_deps providename provideflags provideversion; require = parse_deps requirename requireflags requireversion; conflict = parse_deps conflictname conflictflags conflictversion } in packages := p :: !packages; Hashtbl.add packages_by_num !num p; List.iter (fun pr -> add_provide p pr) p.provide; incr num; if file_info then Array.iteri (fun i f -> let d = dirnames.(dirindexes.(i)) in add_file (d, f) (intern_file filemodes filemd5s filelinktos i, p)) basenames else Array.iteri (fun i f -> let d = dirnames.(dirindexes.(i)) in add_file (d, f) (Dir (* Dummy value *), p)) basenames; Util.reset_warning_location () let parse_headers ch = let st = Common.start_parsing (not !dump_fields) ch in begin try while true do parse_header ch; Common.parsing_tick st done with End_of_file -> () end; Common.stop_parsing st (****) type conflict_reason = R_File of string * string | R_Explicit of pack_ref type rpm_reason = R_conflict of p * p * conflict_reason | R_depends of p * pack_ref let print_pack ch n = let p = Hashtbl.find packages_by_num n in Format.fprintf ch "%a" pr_pack p module Solver = Solver.M (struct type reason = rpm_reason end) let print_rules = ref false let add_conflict st p1 p2 reason = let p = Solver.lit_of_var p1.num false in let p' = Solver.lit_of_var p2.num false in Solver.add_bin_rule st p p' [R_conflict (p1, p2, reason)] let add_depend st n l r = let l = List.map (fun p -> p.num) l in Solver.add_rule st (Array.of_list (Solver.lit_of_var n.num false :: List.map (fun n' -> Solver.lit_of_var n' true) l)) [R_depends (n, r)]; match l with [] | [_] -> () | _ -> Solver.associate_vars st (Solver.lit_of_var n.num true) l let add_dependencies pr p dep kind = (* if !print_rules then begin Format.printf "%d -> any-of (" n; List.iter (fun c -> Format.printf " %d" c) l; Format.printf ")@." end; *) List.iter (fun r -> let l = resolve_pack_ref r in match kind with `Require -> add_depend pr p l r | `Conflict -> List.iter (fun p' -> add_conflict pr p p' (R_Explicit r)) l) dep let generate_rules () = let st = Common.start_generate (not !print_rules) !num in let pr = Solver.initialize_problem ~print_var:print_pack !num in (* File conflicts *) let h = Hashtbl.create 127 in Hashtbl.iter (fun (d, f) {contents = l} -> match l with [] | [_] -> () | (inf, _) :: _ -> if not (List.for_all (fun (inf', _) -> inf = inf') l) then begin let a = Array.of_list l in let len = Array.length a in for i = 0 to len - 1 do for j = i + 1 to len - 1 do let (info1, p1) = a.(i) in let (info2, p2) = a.(j) in let pair = (min p1.num p2.num, max p1.num p2.num) in if info1 <> info2 && not (Hashtbl.mem h pair) then begin Hashtbl.add h pair (); if !print_rules then begin Format.printf "conflict between %a and %a on file %s%s.@." pr_pack p1 pr_pack p2 d f end; add_conflict pr p1 p2 (R_File (d, f)) end done done end) files; List.iter (fun p -> Common.generate_next st; add_dependencies pr p p.require `Require; add_dependencies pr p p.conflict `Conflict) !packages; Common.stop_generate st; Solver.propagate pr; pr (****) let check st = let assign = Solver.assignment st in Array.iteri (fun i v -> if v = Solver.True then Format.printf "Package: %a@." print_pack i) assign (****) let show_success = ref true let show_failure = ref true let print_results = ref true let check_results = ref false let explain_results = ref false let success tested st i = if !show_success then begin if !print_results then begin Format.printf "%a: OK@." print_pack i; let assign = Solver.assignment st in for j = i + 1 to !num - 1 do if not tested.(j) && assign.(j) = Solver.True then begin tested.(j) <- true; Format.printf " %a: OK@." print_pack j end done end; (* *) if !explain_results || !check_results then check st (* *) end let rec print_package_list_rec ch l = match l with [] -> Format.fprintf ch "NOT AVAILABLE" | [x] -> pr_pack ch x | x :: r -> Format.fprintf ch "%a, %a" pr_pack x print_package_list_rec r let print_package_list ch l = Format.fprintf ch "{%a}" print_package_list_rec l let show_reasons l = if l <> [] then begin Format.printf "The following constraints cannot be satisfied:@."; List.iter (fun r -> match r with R_conflict (n1, n2, R_Explicit rf) -> Format.printf " %a conflicts with %a {%a}@." pr_pack n1 pr_pack_ref rf pr_pack n2 | R_conflict (n1, n2, R_File (d, f)) -> Format.printf " %a conflicts with %a on file %s%s@." pr_pack n1 pr_pack n2 d f | R_depends (n, r) -> Format.printf " %a depends on %a %a@." pr_pack n pr_pack_ref r print_package_list (resolve_pack_ref r)) l end let failure st i = if !show_failure then begin if !print_results then begin Format.printf "%a: FAILED@." print_pack i; end; if !explain_results || !check_results then begin (* Find reasons for the failure *) (* Solver.reset st; let res = Solver.solve_2 st i in assert (res = false); *) show_reasons (Solver.collect_reasons st i) end end let _ = let packages = ref [] in Arg.parse [ (* "-check", Arg.Unit (fun () -> check_results := true), " Double-check the results"; *) "-explain", Arg.Unit (fun () -> explain_results := true), " Explain the results"; (* "-rules", Arg.Unit (fun () -> print_rules := true), " Print generated rules"; *) "-failures", Arg.Unit (fun () -> show_success := false), " Only show failures"; "-successes", Arg.Unit (fun () -> show_failure := false), " Only show successes"; "-dump", Arg.Unit (fun () -> dump_fields := true), " Dump hdlist contents"; "-dump-all", Arg.Unit (fun () -> dump_fields := true; show_all := true), " Dump hdlist contents, showing all fields"] (fun p -> packages := p :: !packages) ("Usage: " ^ Sys.argv.(0) ^ " [OPTION]... [PACKAGE]...\n\ Check whether the given packages can be installed. An uncompressed\n\ hdlist.cz file is read from the standard input. By default, all\n\ packages are checked. The names (for instance, 'emacs') of some\n\ packages to be tested can be given on the command line. A specific\n\ version of a package can be selected by following the package name\n\ with an equals and the version of the package to test (for instance,\n\ 'emacs=21.3-20mdk').\n\ \n\ Options:"); let ch = stdin (*open_in "/tmp/hdlist"*) in (* if not !dump_fields then (* HACK: trade memory space for speed *) Gc.set {(Gc.get ()) with Gc.major_heap_increment = 1024 * 1024; Gc.space_overhead = 500}; *) parse_headers ch; if !dump_fields then exit 0; let st = generate_rules () in let tested = Array.make !num (!packages <> []) in List.iter (fun p -> let ref = try let i = String.index p '=' in let vers = String.sub p (i + 1) (String.length p - i - 1) in let p = String.sub p 0 i in (p, EQ, parse_version vers) with Not_found -> (p, ALL, None) in List.iter (fun p -> tested.(p.num) <- false) (resolve_pack_ref ref)) !packages; let t = Unix.gettimeofday () in let step = max 1 (!num / 1000) in for i = 0 to !num - 1 do if not tested.(i) then begin if !packages <> [] then begin (* Slower but generates smaller set of installed packages *) Solver.reset st; if Solver.solve st i then success tested st i else failure st i end else begin if i mod step = 0 && not (!show_success && (!print_results || !explain_results || !check_results)) then Util.set_msg (Format.sprintf "Checking packages... %3.f%% %6d packages" (float i *. 100. /. float !num) i); if Solver.solve st i then success tested st i else begin (*Format.printf "%a: RETRYING@." print_pack i;*) Solver.reset st; if Solver.solve st i then begin success tested st i end else begin Util.hide_msg (); failure st i; Util.show_msg (); Solver.reset st; end end end end done; Util.set_msg ""; Format.eprintf "Checking packages... %.1f seconds@." (Unix.gettimeofday () -. t); debrpmcheck-1.0/util.ml0000644000042300001440000000161110451773302013417 0ustar dicosmo let enable_msgs = (* isatty is not available...*) (Unix.fstat Unix.stderr).Unix.st_kind = Unix.S_CHR let cur_msg = ref "" let hide_msg () = if !cur_msg <> "" then begin prerr_string "\r"; prerr_string (String.make (String.length !cur_msg) ' '); prerr_string "\r"; flush stderr; end let show_msg () = if !cur_msg <> "" then begin prerr_string !cur_msg; flush stderr end let set_msg s = if enable_msgs && s <> !cur_msg then begin hide_msg (); cur_msg := s; show_msg () end (****) let warn_loc = ref None let set_warning_location s = warn_loc := Some s let reset_warning_location () = warn_loc := None let print_warning s = hide_msg (); begin match !warn_loc with None -> Format.eprintf "Warning: %s@." s | Some s' -> Format.eprintf "Warning (%s): %s@." s' s end; show_msg () let fail s = hide_msg (); Format.eprintf "Failure: %s@." s; exit 1 debrpmcheck-1.0/COPYING0000644000042300001440000004421710451773302013154 0ustar dicosmoCopyright (C) 2005 Jerome Vouillon These programs are free software; you can redistribute them and/or modify them under the terms of the GNU General Public License as published by the Free Software Foundation. License, or (at your option) any later version. These programs are distributed in the hope that they will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See (below) the GNU General Public License for more details. --------------------------------------------------------------------------- GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program 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. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19yy name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Library General Public License instead of this License. debrpmcheck-1.0/common.mli0000644000042300001440000000034410451773302014105 0ustar dicosmo type st val start_parsing : bool -> in_channel -> st val parsing_tick : st -> unit val stop_parsing : st -> unit type st' val start_generate : bool -> int -> st' val generate_next : st' -> unit val stop_generate : st' -> unit debrpmcheck-1.0/util.mli0000644000042300001440000000034710451773302013575 0ustar dicosmo val set_msg : string -> unit val hide_msg : unit -> unit val show_msg : unit -> unit val set_warning_location : string -> unit val reset_warning_location : unit -> unit val print_warning : string -> unit val fail : string -> 'a