(* Excerpts from liblindows *)

module List2 = struct

  (** Uniquify an already sorted list. *)
  let uniq_sorted cmp lst =
    let rec loop tmp =
      match tmp with
	a :: b :: etc ->
	  if cmp a b = 0
	  then loop (b :: etc)
	  else a :: loop (b :: etc)
      | etc -> etc in
    loop lst

  (** Sort a list according to the comparison function and then uniqify. *)
  let uniq cmp lst = uniq_sorted cmp (List.sort cmp lst)

end

module Alist = struct

  (* Replace several values in an alist, preserving order:

     replace_assoc [2,5;4,5] [1,1;2,2;3,3] -> [(1, 1); (2, 5); (3, 3)].

     It is assumed that newpairs is a fairly short list, for longer
     lists a hashtable should be employed. *)

  let replace_assoc newpairs orig =
    let matched = ref [] in
    let rec loop orig result =
      match orig with
	[] -> List.rev result
      | (a, v) :: etc ->
	  let v' = try List.assoc a newpairs with Not_found -> v
	  in loop etc ((a, v') :: result)
    in loop orig []

end

module String3 = struct

  let iteri f s =
    let i = ref 0 in
    String.iter (fun c -> f !i c; i := !i + 1) s

  let mapi f s =
    let s' = (String.create (String.length s)) in
    iteri (fun i c -> s'.[i] <- f i s.[i]) s;
    s'

  let map f s = mapi (fun i c -> f c) s

  let init n f =
    let s = String.create n in
    for i = 0 to (n-1) do s.[i] <- f i done;
    s

  (** Return length of common suffix *)
  let suffix_length s1 s2 =
    let rec loop l n1 n2 =
      if n1 < 0 || n2 < 0
      then l
      else if s1.[n1] <> s2.[n2]
      then l
      else loop (l+1) (n1-1) (n2-1) in
    loop 0 (String.length s1 - 1) (String.length s2 - 1)

  (** [has_suffix suf str] - Does {i str} end with the suffix {i suf}? *)
  let has_suffix suf str =
    suffix_length suf str = String.length suf

  (** [drop_suffix suf s] - Drop suffix suf it it is at end of s,
    otherwise raise Not_found *)
  let drop_suffix suf str =
    if has_suffix suf str
    then String.sub str 0 ((String.length str) - (String.length suf))
    else raise Not_found

  (** [has_prefix s1 s2] - Return length of common prefix *)
  let prefix_length s1 s2 =
    let rec loop n =
      try
	if s1.[n] = s2.[n]
	then loop (n+1)
	else n
      with
	_ -> n in
    loop 0

  (** [has_prefix pre str] - Return true if str starts with pre *)
  let has_prefix pre str =
    prefix_length pre str = String.length pre

  (** drop "abcde" 3 -> "de" *)
  let drop s n = String.sub s n ((String.length s) - n)

  (** [drop_prefix pre str] - Drop the prefix pre from the string str, or
    raise Not_found if it doesn't have it. *)
  let drop_prefix pre str =
    if has_prefix pre str
    then drop str (String.length pre)
    else raise Not_found

end

module Linestream = struct

  (** Return a stream of the lines read from the channel returned by the
    opener.  Close channel when done with closer. *)
  let make opener closer source =
    let chan = opener source in
    Stream.from (fun _ ->
		   try Some (input_line chan)
		   with
		     End_of_file -> closer chan; None
		   | exn -> closer chan; raise exn)

end

module Stream2 = struct

  (** Return a list of the stream elements *)
  let to_list strm =    
    let result = ref [] in
    Stream.iter (fun x -> result := x :: !result) strm;
    List.rev !result

end

module Sh = struct

  (** Return a stream of the lines printed by a command *)
  let to_linestream cmd =
    Linestream.make Unix.open_process_in Unix.close_process_in cmd

  (** Return a list of the lines printed by a command *)
  let to_linelist cmd =
    Stream2.to_list (to_linestream cmd)

  (** Wrapper around Sys.command.  Print and execute a command, raise a
    Failure exception if its result code is nonzero. *)
  let run cmd =
    prerr_endline ("-> " ^ cmd);
    match Sys.command ("set -e; " ^ cmd) with
      0 -> ()
    | n -> raise (Failure (cmd ^ " -> " ^ (string_of_int n)))

end

(* Copies from libdsf *)

module Message = struct

  type spec = out_channel * (int ref * int ref)

  let specs = ref []

  (* Print a string if verbosity level is n or higher and update the column
     variable. *)

  let output n s =

    (* What column do we end at if we print string s? *)
    let newcol oldcol s =
      let l = (String.length s) in
      try l - (String.rindex s '\n') - 1
      with Not_found -> oldcol + l in

    List.iter
      (fun (chan, (level, col)) ->
	 if n <= !level then begin
	   output_string chan s;
	   col := newcol !col s;
	   flush chan
	 end)
      !specs

  let output_nl n s =
    List.iter
      (fun (chan, (level, col)) ->
	 if n <= !level then begin
	   if !col != 0 then output_char chan '\n';
	   output_string chan (s ^ "\n");
	   col := 0;
	   flush chan
	 end)
      !specs

  let vq str = output (-1) str
  let v0 str = output 0 str
  let v1 str = output 1 str
  let v2 str = output 2 str
  let v3 str = output 3 str
  let v4 str = output 4 str

  let vq_nl str = output_nl (-1) str
  let v0_nl str = output_nl 0 str
  let v1_nl str = output_nl 1 str
  let v2_nl str = output_nl 2 str
  let v3_nl str = output_nl 3 str
  let v4_nl str = output_nl 4 str

end

module File = struct

  let exists a = try ignore (Unix.stat a); true with _ -> false

end

module Util = struct

  let tassoc key alist =
    let (w, v) = List.assoc key alist in v

  exception File_not_found

  let md5sum path =
    try
      String.sub (List.hd (Sh.to_linelist ("md5sum " ^ path))) 0 32
    with
      Failure "hd" -> raise File_not_found

  (* A lexbuf that closes its open file channel when (if) it finishes.
     If it doesn't finish, well that's a problem.  If its a big problem
     you shouldn't use it...  Raises Sys_error "invalid file descriptor"
     if you keep using it after Eof. *)

  let lexing_from_file path =
    let ichan = open_in path in
    Lexing.from_function (fun s n ->
			    let count = input ichan s 0 n in
			    if count = 0 then close_in ichan;
			    count)

end  

exception Missing_Packages_File of string
exception Bad_package_data
exception Bad_Control_Data
exception Bad_version_number
exception Bad_package_name of string
exception Bad_dependencies of string
exception Parse_error of int
exception Invalid
exception Missing_Section
exception Missing_Priority

type version = Stable | Testing | Unstable

(** {6 Temporary Directory} *)


(************** DEB FILE NAMES *****************)

(* Split a debian version into epoch/version/revision triple. *)

(* Split a debian version number into an epoch, version, revision triple.
   If present, the epoch will end in ":" and the revision will start with
   "-", otherwise they will be empty strings. *)

let evr_split =
  (* [epoch:]version[-revision] *)
  let epoch = "\\([0-9]+:\\)"
  and ver = "\\(\\([^-:]*\\)\\|\\(\\([^:]*\\)\\(-[^-]*\\)\\)\\)" in
  let evr_re = Str.regexp ("[ 	]*" ^ epoch ^ "?" ^ ver ^ "[ 	]*\n") in

  fun v ->
    if Str.string_match evr_re (v^"\n") 0
    then begin
      ((try Str.matched_group 1 v with Not_found -> ""),
       (try Str.matched_group 3 v with Not_found -> Str.matched_group 5 v),
       (try Str.matched_group 6 v with Not_found -> ""))
    end
    else raise Bad_version_number

(* This is calls evr_split but then strips off the epoch and converts
   it to an integer, and strips the leading "-" from the revision.  I'm
   not sure which is more useful.  Probably this one, even if I did call
   it "old". *)

let old_evr_split s =

  let (e,v,r) = evr_split s in
  let e = if e = "" then 0 else int_of_string (String3.drop_suffix ":" e)
  and r = if r = "" then "" else String3.drop_prefix "-" r
  in (e,v,r)

(* Split a string into numeric and non-numeric parts.  Make sure the
   resulting list always begins with non-numeric (Str.Text) segments,
   even if it is empty. *)

let version_split =
  let nre = Str.regexp "[0-9]+" in
  fun v ->
    let l = Str.full_split nre v in
    match l with
      Str.Delim _ :: _ -> Str.Text "" :: l
    | _ -> l

(* Split a debian package file name into a quadruple: name, ver, rev, arch.
   Arch will include the .deb extension, though it is legal to omit the
   architecture itself. *)

let verrev_split =		(* FIXME - use verrev_split2 instead *)
  let dashre = Str.regexp "-" in
  fun verrev ->
    match List.rev (Str.split_delim dashre verrev) with
      [v] -> (verrev, "")
    | r :: v -> (String.concat "-" (List.rev v)), r
    | _ -> raise (Bad_package_name verrev)

(* Like verrev_split, but revision if present will always begin with
   a dash. *)

let verrev_split2 =
  let dashre = Str.regexp "-" in
  fun verrev ->
    match List.rev (Str.split_delim dashre verrev) with
      [v] -> (verrev, "")
    | r :: v -> (String.concat "-" (List.rev v)), ("-" ^ r)
    | _ -> raise (Bad_package_name verrev)

let debname_split =
  let usre = Str.regexp "_"
  and dashre = Str.regexp "-" in
  fun str ->
    try begin
      let ext =
	if String3.has_suffix ".deb" str then ".deb"
	else if String3.has_suffix ".udeb" str then ".udeb"
	else raise Not_found in
      let str = String3.drop_suffix ext str in
      let lst = Str.split_delim usre str in
      let pkgname = List.hd lst in
      if List.length lst = 2 then
	let (version, revision) = verrev_split (List.nth lst 1) in
	(pkgname, version, revision, ext)
      else
	let rev = List.rev lst in
	let arch = List.hd rev
	and verrev = String.concat "_" (List.tl (List.rev (List.tl rev))) in
	let (version, revision) = verrev_split verrev in
	(pkgname, version, revision, "_" ^ arch ^ ext)
    end
    with _ -> raise (Bad_package_name str)

let debname_split2 =
  let usre = Str.regexp "_"
  and dashre = Str.regexp "-" in
  fun str ->
    try begin
      let ext =
	if String3.has_suffix ".deb" str then ".deb"
	else if String3.has_suffix ".udeb" str then ".udeb"
	else raise Not_found in
      let str = String3.drop_suffix ext str in
      let lst = Str.split_delim usre str in
      let pkgname = List.hd lst in
      if List.length lst = 2 then
	let (version, revision) = verrev_split2 (List.nth lst 1) in
	(pkgname, version, revision, ext)
      else
	let rev = List.rev lst in
	let arch = List.hd rev
	and verrev = String.concat "_" (List.tl (List.rev (List.tl rev))) in
	let (version, revision) = verrev_split2 verrev in
	(pkgname, version, revision, "_" ^ arch ^ ext)
    end
    with _ -> raise (Bad_package_name str)

let debpath_split =
  let slashre = Str.regexp "/" in
  fun str ->
    match List.rev (Str.split_delim slashre str) with
      [filename] ->
	let (name, version, revision, arch) = debname_split filename in
	("", name, version, revision, arch)
    | filename :: path ->
	let (name, version, revision, arch) = debname_split filename in
	((String.concat "/" (List.rev path)), name, version, revision, arch)
    | _ -> raise (Bad_package_name str)

(* Directory will always end with "/" if present *)

let debpath_split2 =
  let slashre = Str.regexp "/" in
  fun str ->
    match List.rev (Str.split_delim slashre str) with
      [filename] ->
	let (name, version, revision, arch) = debname_split2 filename in
	("", name, version, revision, arch)
    | filename :: path ->
	let (name, version, revision, arch) = debname_split2 filename in
	((String.concat "/" (List.rev path)) ^ "/",
	 name, version, revision, arch)
    | _ -> raise (Bad_package_name str)

let debname_join (n,v,r,a) =
  n ^ "_" ^ v ^ (if r = "" then "" else ("-" ^ r)) ^ a
let debname_join2 (n,v,r,a) =
  n ^ "_" ^ v ^ r ^ a

let debpath_join (d,n,v,r,a) =
  d ^ "/" ^ n ^ "_" ^ v ^ (if r = "" then "" else ("-" ^ r)) ^ a
let debpath_join2 (d,n,v,r,a) =
  d ^ n ^ "_" ^ v ^ r ^ a

(* Take a revision string, find the numeric part following the given
   extension, increment it, and return the result.  If not found add
   the extension followed by "1". *)

let revision_incr ext r =
  let l =
    let rec loop l =
      match l with
	(* Find the end of the list of split up version number segments. 
	   If the split version ends with our extension text followed by
	   a number, we just want to increment the number, using a period
	   as a separator.  Otherwise we want to add our extension and
	   a "1". *)
	[Str.Text s1; Str.Delim n1] ->
	  if String3.has_suffix ext s1
	  then [Str.Text s1; Str.Delim (string_of_int ((int_of_string n1)+1))]
	  else Str.Text s1 :: loop [Str.Delim n1]
      | [Str.Text s1] -> [Str.Text (s1 ^ "." ^ ext); Str.Delim "1"]
      | [Str.Delim n1] -> [Str.Delim n1; Str.Text ("." ^ ext); Str.Delim "1"]
      | a :: b :: tl -> a :: loop (b :: tl)
      | [] -> [Str.Text ext; Str.Delim "1"] in
    loop (version_split r) in
  String.concat ""
    (List.map (function Str.Text s -> s | Str.Delim s -> s) l)

(* Call revision_incr on a full version number, a deb filename, a
   full pathname.  (Should this be verrev_incr?) *)

let version_incr ext v =
  let (e,v,r) = old_evr_split v in
  let rr = revision_incr ext r in
  (if e == 0 then "" else (string_of_int e) ^ ":") ^ v ^ "-" ^ rr

let debname_incr ext path =
  let (n, v, r, a) = debname_split path in
  let rr = revision_incr ext r in
  n ^ "_" ^ v ^ "-" ^ rr ^ a

let debpath_incr ext path =
  let (d, n, v, r, a) = debpath_split2 path in
  debpath_join2 (d, n, v, revision_incr ext r, a)

(* The inverse of revision_incr - decrements the numeric part.  Strips
   off the extension and the "1" (and the preceding dash or dot) if that
   is what it finds. *)

let revision_decr ext r =
  let lst =
    let rec loop l =
      match l with
	[Str.Text s1; Str.Delim n1] ->
	  if String3.has_suffix ext s1
	  then begin
	    if n1 = "1" then
	      (* Drop text and numeric portion of extension, and any
		 decimal point that may have been added. *)
	      [Str.Text
		 (try String3.drop_suffix ("." ^ ext) s1 with Not_found ->
		    try String3.drop_suffix ("-" ^ ext) s1 with Not_found ->
		      String3.drop_suffix ext s1)]
	    else
	      (* Decrement numeric extension. *)
	      [Str.Text s1; Str.Delim (string_of_int ((int_of_string n1)-1))]
	  end
	  else raise Not_found
      | a :: b :: tl -> a :: loop (b :: tl)
      | _ -> raise Not_found in
    loop (version_split r) in
  String.concat "" (List.map (function Str.Text s -> s | Str.Delim s -> s) lst)

let version_decr ext v =
  let (e,v,r) = old_evr_split v in
  let rr = revision_decr ext r in
  (if e == 0 then "" else (string_of_int e) ^ ":") ^
  v ^ (if rr = "" then "" else ("-" ^ rr))

let debname_decr ext path =
  let (n, v, r, a) = debname_split path in
  let rr = revision_decr ext r in
  n ^ "_" ^ v ^ "-" ^ (if rr = "" then "" else ("-" ^ rr)) ^ a

let debpath_decr ext path =
  let (d, n, v, r, a) = debpath_split path in
  let rr = revision_decr ext r in
  d ^ "/" ^ n ^ "_" ^ v ^ (if rr = "" then "" else ("-" ^ rr)) ^ a

(* The strip functions strip off the extension and the numeric
   revision that follows it.  This is equivalent to repeatedly calling
   decr until the extension and revision number vanish. *)

exception Revision_Strip_Failed of string

let revision_strip ext r =
  let lst =
    let rec loop l =
      match l with
	[Str.Text s1; Str.Delim n1] ->
	  if String3.has_suffix ext s1
	  then [Str.Text
		  (* If there was already a revision, we have added .cnr1,
		     otherwise we added -cnr1.  The "-" was already stripped
		     off when we split up the version number. *)
		  (try String3.drop_suffix ("." ^ ext) s1
		   with Not_found -> String3.drop_suffix ext s1)]
	  else raise (Revision_Strip_Failed r)
      | a :: b :: tl -> a :: loop (b :: tl)
      | _ -> raise (Revision_Strip_Failed r) in
    loop (version_split r) in
  String.concat "" (List.map (function Str.Text s -> s | Str.Delim s -> s) lst)

(* Silly to repeatedly define these - they should be parameterized *)

let version_strip ext v =
  let (e,v,r) = old_evr_split v in
  let rr = revision_strip ext r in
  (if e = 0 then "" else (string_of_int e) ^ ":") ^
  v ^ (if rr = "" then "" else ("-" ^ rr))

let debname_strip ext path =
  let (n, v, r, a) = debname_split path in
  let rr = revision_strip ext r in
  n ^ "_" ^ v ^ (if rr = "" then "" else ("-" ^ rr)) ^ a

let debpath_strip ext path =
  let (d, n, v, r, a) = debpath_split path in
  let rr = revision_strip ext r in
  d ^ "/" ^ n ^ "_" ^ v ^ (if rr = "" then "" else ("-" ^ rr)) ^ a

(************* VERSION NUMBERS **************)

(* From "The Debian Packaging Manual":

   The upstream-version and debian-revision parts are compared by dpkg
   using the same algorithm:

   The strings are compared from left to right.

   First the initial part of each string consisting entirely of
   non-digit characters is determined. These two parts (one of which
   may be empty) are compared lexically. If a difference is found it
   is returned. The lexical comparison is a comparison of ASCII values
   modified so that all the letters sort earlier than all the
   non-letters.

   Then the initial part of the remainder of each string which
   consists entirely of digit characters is determined. The numerical
   values of these two parts are compared, and any difference found is
   returned as the result of the comparison. For these purposes an
   empty string (which can only occur at the end of one or both
   version strings being compared) counts as zero.

   These two steps are repeated (chopping initial non-digit strings
   and initial digit strings off from the start) until a difference is
   found or both strings are exhausted. *)

(* There seems to have been a case where these two functions
   (version_compare and my_version_compare) produced different
   results.  But now, somehow, it doesn't! *)

(* This is busted - it can't tell the difference between eq and gt. *)

let version_compare v1 v2 = 
  if v1 = v2 then 0
  else if Sys.command ("dpkg --compare-versions '" ^
		       v1 ^ "' lt '" ^ v2 ^ "'") = 0 then -1 else 1

module Version = struct

  type version_number = {e : int; v: string; r: string}

  let evr_split =
    let re = Pcre.regexp "^(([0-9]+):)?(([^-:]*)|(([^:]*)-([^-]*)))$" in
    fun v ->
      try
	let a = Pcre.extract ~full_match:false ~rex:re v in
	{e = (match a.(1) with "" -> 0 | s -> int_of_string s);
	 v = a.(3) ^ a.(5);
	 r = (match a.(6) with "" -> "0" | s -> s)}
      with
	_ -> raise Bad_version_number

  let version_split =
    let re = Pcre.regexp "[0-9]+" in
    fun v ->
      let parts =
	List.filter 
	  (function
	       Pcre.NoGroup -> false
	     | Pcre.Group _ -> false
	     | Pcre.Text _ -> true
	     | Pcre.Delim _ -> true)
	  (Pcre.full_split ~rex:re v) in
      let pairs =
	let rec loop = function
	    Pcre.NoGroup :: etc ->
	      loop etc
	  | Pcre.Group _ :: etc ->
	      loop etc
	  | Pcre.Text a :: Pcre.Text b :: etc ->
	      loop (Pcre.Text (a ^ b) :: etc)
	  | Pcre.Text a :: Pcre.NoGroup :: etc ->
	      loop (Pcre.Text a :: etc)
	  | Pcre.Text a :: Pcre.Group _ :: etc ->
	      loop (Pcre.Text a :: etc)
	  | Pcre.Text text :: Pcre.Delim n1 :: Pcre.Delim n2 :: etc ->
	      loop (Pcre.Text text :: Pcre.Delim (n1 ^ n2) :: etc)
	  | Pcre.Text text :: Pcre.Delim num :: etc ->
	      (text, num) :: loop etc
	  | Pcre.Delim num :: etc ->
	      loop (Pcre.Text "" :: Pcre.Delim num :: etc)
	  | [Pcre.Text text] ->
	      [text, "0"]
	  | [] -> [] in
	loop parts in
      pairs

  (* "The lexical comparison is a comparison of ASCII values modified so
     that all the letters sort earlier than all the non-letters." *)

  let ascii_modify =

    let string_init n f =
      let s = String.create n in
      for i = 0 to (n-1) do s.[i] <- f i done;
      s in

    let small_a = min (Char.code 'a') (Char.code 'A')
    and small_z = min (Char.code 'z') (Char.code 'Z')
    and large_a = max (Char.code 'a') (Char.code 'A')
    and large_z = max (Char.code 'z') (Char.code 'Z') in
    let f n =
      if n < small_a then char_of_int (n + 52)
      else if n <= small_z then char_of_int (n - small_a)
      else if n < large_a then char_of_int (n + 26)
      else if n <= large_z then char_of_int (n - large_a + 26)
      else char_of_int (n)
    in
    let table = string_init 256 f in
    fun c -> table.[int_of_char c]

  let text_compare : string -> string -> int =

    let string_iteri f s =
      let i = ref 0 in
      String.iter (fun c -> f !i c; i := !i + 1) s in
    let string_mapi f s =
      let s' = String.create (String.length s) in
      string_iteri (fun i c -> s'.[i] <- f i s.[i]) s; s' in
    let string_map f s =
      string_mapi (fun i c -> f c) s in

    let modified_compare s1 s2 =
      let result = compare (string_map ascii_modify s1) (string_map ascii_modify s2) in
      (*prerr_endline ("modified_compare \"" ^ s1 ^ "\" \"" ^ s2 ^ "\" -> " ^ string_of_int result);*)
      result in

    let tilde = Pcre.regexp "~+" in

    fun s1 s2 ->
      let rec loop s1 s2 : int =
	match s1, s2 with
	  Pcre.Group _ :: etc1, etc2
	| Pcre.NoGroup :: etc1, etc2
	| etc1, Pcre.Group _ :: etc2
	| etc1, Pcre.NoGroup :: etc2 -> loop etc1 etc2
	| (Pcre.Text t1 :: etc1, Pcre.Text t2 :: etc2) -> begin
	    match modified_compare t1 t2 with
	      0 -> loop etc1 etc2
	    | n -> n		(* Check sense *)
	  end
	| (Pcre.Delim d1 :: etc1, Pcre.Delim d2 :: etc2) -> begin
	    match String.length d2 - String.length d1 with
	      0 -> loop etc1 etc2
	    | n -> n		(* Check sense *)
	  end
	| ([], []) -> 0
	| ([], lst) -> loop [Pcre.Text ""] lst
	| (lst, []) -> loop lst [Pcre.Text ""]
	| (Pcre.Text _ :: _, Pcre.Delim _ :: _) -> 1	(* Check sense *)
	| (Pcre.Delim _ :: _, Pcre.Text _ :: _) -> (-1) in
      loop (Pcre.full_split ~rex:tilde s1) (Pcre.full_split ~rex:tilde s2)

  let upstream_version_compare v1 v2 =
    (*prerr_endline ("upstream_version_compare \"" ^ v1 ^ "\" \"" ^ v2 ^ "\"");*)
    let p1 = version_split v1 
    and p2 = version_split v2 in

    let rec loop p1 p2 =
      match p1, p2 with
	[], [] -> 0
      | lst, [] ->
	  loop lst ["", ""]
      | [], lst ->
	  loop ["", ""] lst
      | ((t1, n1) :: p1), ((t2, n2) :: p2) ->
	  match text_compare t1 t2 with 
	    0 -> begin
	      let n1 = Big_int.big_int_of_string n1
	      and n2 = Big_int.big_int_of_string n2 in
	      match Big_int.compare_big_int n1 n2 with
		0 -> loop p1 p2
	      | n -> n
	    end
	  | n -> n in
    loop (version_split v1) (version_split v2)

  let compare v1 v2 =
    let {e=e1; v=v1; r=r1} = evr_split v1
    and {e=e2; v=v2; r=r2} = evr_split v2 in
    (*prerr_endline ("e1=" ^ string_of_int e1 ^ " e2=" ^ string_of_int e2);*)
    match e1 - e2 with
      0 -> begin
	(*prerr_endline ("v1=\"" ^ v1 ^ "\" v2=\"" ^ v2 ^ "\"");*)
	match upstream_version_compare v1 v2 with
	  0 -> upstream_version_compare r1 r2
	| n -> n
      end
    | n -> n

  let test f =
    let versions = Sh.to_linelist "sed -n 's/^Version: //p' < /var/lib/dpkg/status" in
    List.sort f versions

end

let my_version_compare = Version.compare

let version_max v1 v2 = if (version_compare v1 v2) > 0 then v1 else v2

(************** CONTROL FILES ***************)

type control = (string * (string * string)) list

(*http://www.debian.org/doc/debian-policy/ch-relationships.html

  7.1 Syntax of relationship fields

  These fields all have a uniform syntax. They are a list of package
  names separated by commas.

  In the Depends, Recommends, Suggests, Pre-Depends, Build-Depends and
  Build-Depends-Indep control file fields of the package, which
  declare dependencies on other packages, the package names listed may
  also include lists of alternative package names, separated by
  vertical bar (pipe) symbols |. In such a case, if any one of the
  alternative packages is installed, that part of the dependency is
  considered to be satisfied.

   All of the fields except for Provides may restrict their
   applicability to particular versions of each named package. This is
   done in parentheses after each individual package name; the
   parentheses should contain a relation from the list below followed
   by a version number, in the format described in Version numbering,
   Chapter 4.

   The relations allowed are <<, <=, =, >= and >> for strictly
   earlier, earlier or equal, exactly equal, later or equal and
   strictly later, respectively. The deprecated forms < and > were
   used to mean earlier/later or equal, rather than strictly
   earlier/later, so they should not appear in new packages (though
   dpkg still supports them).

   Whitespace may appear at any point in the version specification
   subject to the rules in Syntax of control files, Section 3.1, and
   must appear where it's necessary to disambiguate; it is not
   otherwise significant. For consistency and in case of future
   changes to dpkg it is recommended that a single space be used after
   a version relationship and before a version number; it is also
   conventional to put a single space after each comma, on either side
   of each vertical bar, and before each open parenthesis.

   For example, a list of dependencies might appear as:

     Package: mutt
     Version: 1.3.17-1
     Depends: libc6 (>= 2.2.1), exim | mail-transport-agent

   All fields that specify build-time relationships (Build-Depends,
   Build-Depends-Indep, Build-Conflicts and Build-Conflicts-Indep) may
   be restricted to a certain set of architectures. This is indicated
   in brackets after each individual package name and the optional
   version specification. The brackets enclose a list of Debian
   architecture names separated by whitespace. Exclamation marks may
   be prepended to each of the names. (It is not permitted for some
   names to be prepended with exclamation marks and others not.) If
   the current Debian host architecture is not in this list and there
   are no exclamation marks in the list, or it is in the list with a
   prepended exclamation mark, the package name and the associated
   version specification are ignored completely for the purposes of
   defining the relationships.

   For example:

     Source: glibc
     Build-Depends-Indep: texinfo
     Build-Depends: kernel-headers-2.2.10 [!hurd-i386],
   	hurd-dev [hurd-i386], gnumach-dev [hurd-i386]

   Note that the binary package relationship fields such as Depends
   appear in one of the binary package sections of the control file,
   whereas the build-time relationships such as Build-Depends appear in
   the source package section of the control file (which is the first
   section). *)

let depfields = 
  ["Depends";		(* http://www.debian.org/doc/debian-policy/ch-relationships.html#s7.2 *)
   "Recommends";
   "Suggests";
   "Enhances";
   "Pre-Depends";
   "Conflicts";		(* http://www.debian.org/doc/debian-policy/ch-relationships.html#s-conflicts *)
   "Provides";		(* http://www.debian.org/doc/debian-policy/ch-relationships.html#s-virtual *)
   "Replaces";		(*http://www.debian.org/doc/debian-policy/ch-relationships.html#s-replaces *)
  ]

(* Return a list of triples: (appname, sense, version).  Sense and version
   may be the empty string. *)

type cmp = LT | LE | EQ | GE | GT

type rel =
    Name of string
  | NameCmpVer of string * cmp * string
  | Alt of rel list
  | Conc of rel list
  | NoRel

let string_of_cmp cmp =
  match cmp with
    LT -> "<<"
  | LE -> "<="
  | EQ -> "="
  | GE -> ">="
  | GT -> ">>"

let rec iter_rel f rel =
  match rel with
    Name s | NameCmpVer (s, _, _)-> f s
  | Alt l | Conc l -> List.iter (iter_rel f) l
  | _ -> ()

let cmp_of_string str =
  match str with
    "<<" | "<" -> LT
  | "<=" -> LE
  | "=" -> EQ
  | ">=" -> GE
  | ">>" | ">" -> GT
  | _ -> raise Invalid

let rec string_of_rel rel = 
  match rel with
    NoRel -> ""
  | Name name -> name
  | NameCmpVer (name, cmp, ver) ->
      name ^ " (" ^ (string_of_cmp cmp) ^ " " ^ ver ^ ")"
  | Alt lst -> String.concat " | " (List.map string_of_rel lst)
  | Conc lst -> String.concat ", " (List.map string_of_rel lst)

let string_of_cmp_debug cmp =
  match cmp with
    LT -> "Debian.LT"
  | LE -> "Debian.LE"
  | EQ -> "Debian.EQ"
  | GE -> "Debian.GE"
  | GT -> "Debian.GT"

let rec string_of_rel_debug rel =
  match rel with
    NoRel -> "Debian.NoRel"
  | Name name -> "Debian.Name \"" ^ name ^ "\""
  | NameCmpVer (name, cmp, ver) -> "Debian.NameCmpVer (\"" ^ name ^ "\", " ^ (string_of_cmp_debug cmp) ^ ", \"" ^ ver ^ "\")"
  | Alt lst -> "Debian.Alt [" ^ (String.concat "; " (List.map string_of_rel_debug lst)) ^ "]"
  | Conc lst -> "Debian.Conc [" ^ (String.concat "; " (List.map string_of_rel_debug lst)) ^ "]"

(* Collapse multiple concs *)

let rec regroup rel =
  match rel with
    Conc [] -> raise Invalid
  | Conc [Conc a] -> Conc (List.map regroup a)
  | Conc [Conc a; Conc b] -> Conc ((List.map regroup a) @
				   (List.map regroup b))
  | Conc (Conc a :: etc) ->
      regroup (Conc [Conc a; (regroup (Conc etc))])
  | Conc a -> Conc (List.map regroup a)
  | Alt [] -> raise Invalid
  | Alt [Alt a] -> Alt (List.map regroup a)
  | Alt [Alt a; Alt b] -> Alt ((List.map regroup a) @
				   (List.map regroup b))
  | Alt (Alt a :: etc) ->
      regroup (Alt [Alt a; (regroup (Alt etc))])
  | Alt a -> Alt (List.map regroup a)
  | _ -> rel

(* Given an Alt of a list of Concs of Alts, return an equivalent
   Conc of Alts by applying de Morgan's law. *)

let rec distribute alt =
  match alt with
    Alt [] -> Conc []
  | Alt [Conc a] -> Conc a
  | Alt [Conc alst; Conc blst] ->
      (* Here's the interseting step:
	 a&b&c | d&e ->
	 ((a&b&c) | d) & ((a&b&c) | e) ->
	 (a|d) & (b|d) & (c|d) & (a|e) & (b|e) & (c|e) *)	 
      regroup (Conc
		 (List.flatten
		    (List.map
		       (fun b -> List.map (fun a -> Alt [a; b]) alst)
		       blst)))
  | Alt (Conc alst :: etc) ->
      let blst = distribute (Alt etc) in
      distribute (Alt [Conc alst; blst])
  | _ -> raise Invalid

(* Canonicalize a rel so it can be compared, and so it can be
   expressed as a debian dependency list.  This means it must be in
   the format Conc [Alt; Alt; Alt; ...].  This function will *always*
   return an expression that is a Conc of Alts. *)

(* Example:
let a = Debian.Alt [Debian.Conc
		      [Debian.NameCmpVer ("kernel", Debian.GE, "2.2.21");
		       Debian.NameCmpVer ("kernel", Debian.LE, "2.2.22")];
		    Debian.Conc
		      [Debian.NameCmpVer ("kernel", Debian.GE, "2.4.18");
	               Debian.NameCmpVer ("kernel", Debian.LE, "2.4.19")]];;
let b = Debian.canon a;;
val b : Debian.rel =
  Debian.Conc
   [Debian.Alt
     [Debian.NameCmpVer ("kernel", Debian.GE, "2.2.21");
      Debian.NameCmpVer ("kernel", Debian.GE, "2.4.18")];
    Debian.Alt
     [Debian.NameCmpVer ("kernel", Debian.LE, "2.2.22");
      Debian.NameCmpVer ("kernel", Debian.GE, "2.4.18")];
    Debian.Alt
     [Debian.NameCmpVer ("kernel", Debian.GE, "2.2.21");
      Debian.NameCmpVer ("kernel", Debian.LE, "2.4.19")];
    Debian.Alt
     [Debian.NameCmpVer ("kernel", Debian.LE, "2.2.22");
      Debian.NameCmpVer ("kernel", Debian.LE, "2.4.19")]]

       2.2.21     2.2.22                   2.4.18        2.4.19
 --------+----------+------------------------+--------------+------------
         |------------------------------------------------------------>
      <-------------|                        |------------------------>
         |--------------------------------------------------|
      <-----------------------------------------------------|
*)

let canon rel =

  (* Remove singleton concs and alts. *)
  let rec collapse rel =
    match rel with
      Alt [a] -> a
    | Conc [a] -> collapse a
    | Conc a -> Conc (List.map collapse a)
    | _ -> rel in

  let rec f =
    fun rel ->
      match rel with
	Conc lst ->
	  let lst' = List.map f lst in
	  regroup (Conc lst')
      | Alt lst ->
	  let (lst' : rel list) = List.map f lst in
	  distribute (Alt lst')
      | _ -> Conc [Alt [rel]]
  in collapse (f rel)

(* Change = rel to >= *)

let rec maprel f rel =
  match rel with
    NoRel -> f rel
  | Name name -> f rel
  | NameCmpVer (name, cmp, ver) -> f rel
  | Alt lst -> f (Alt (List.map (maprel f) lst))
  | Conc lst -> f (Conc (List.map (maprel f) lst))

(* Replace every (= x.y-z) dependency with (>= x.y-z). *)

let eq_to_ge rel =
  let rec f rel =
    match rel with
      NoRel-> rel
    | Name name -> rel
    | NameCmpVer (name, cmp, ver) when cmp = EQ ->
	NameCmpVer (name, GE, ver)
    | NameCmpVer (name, cmp, ver) when cmp = LE ->
	let (e,v,r) = evr_split ver in
	let r' = (match r with "" -> "-" | _ -> r ^ ".") ^ "cnr999" in
	NameCmpVer (name, LE, e^v^r')
    | NameCmpVer (name, cmp, ver) -> rel
    | Alt lst -> Alt (List.map f lst)
    | Conc lst -> Conc (List.map f lst) in
  canon (f rel)

(* Replace every (= x.y-z) dependency with (<= x.y-z.cnr999). *)

let eq_to_le rel =
  let rec f rel =
    match rel with
      NoRel -> rel
    | Name name -> rel
    | NameCmpVer (name, cmp, ver) when cmp = EQ ->
	let (e,v,r) = evr_split ver in
	let r' = (match r with "" -> "-" | _ -> r ^ ".") ^ "cnr999" in
	NameCmpVer (name, LE, e^v^r')
    | NameCmpVer (name, cmp, ver) when cmp = LE ->
	let (e,v,r) = evr_split ver in
	let r' = (match r with "" -> "-" | _ -> r ^ ".") ^ "cnr999" in
	NameCmpVer (name, LE, e^v^r')
    | NameCmpVer (name, cmp, ver) -> rel
    | Alt lst -> Alt (List.map f lst)
    | Conc lst -> Conc (List.map f lst) in
  canon (f rel)

(* Replace every (= x.y-z) dependency with (>= x.y-z), (<= x.y-z.cnr999).
   Also, replace every (<= x.y-z) dependency with (<= x.y-z.cnr999). *)

let eq_to_range relation =

  let rec f rel =
    match rel with
	NoRel -> rel
      | Name name -> rel
      | NameCmpVer (name, cmp, ver) when cmp = EQ ->
	  let (e,v,r) = evr_split ver in
	  let r' = (match r with "" -> "-" | _ -> r ^ ".") ^ "cnr999" in
	    Conc [NameCmpVer (name, GE, ver); NameCmpVer (name, LE, e^v^r')]
      | NameCmpVer (name, cmp, ver) when cmp = LE ->
	  let (e,v,r) = evr_split ver in
	  let r' = (match r with "" -> "-" | _ -> r ^ ".") ^ "cnr999" in
	    NameCmpVer (name, LE, e^v^r')
      | NameCmpVer (name, cmp, ver) -> rel
      | Alt lst -> Alt (List.map f lst)
      | Conc lst -> Conc (List.map f lst) 
  in
    canon (f relation)

let parse_relation ?(arch="") str =

  let relationship_re =
    let optional re = "\\(" ^ re ^ "\\)?"
    and optwhite = "[ \t\n]*"
    and name = "\\([^ \t\n(,|]+\\)"
    and relation = "\\(<<\\|<=\\|=\\|>=\\|>>\\)"
    and version = "\\([^ \t\n)]+\\)"
    and arches = "\\([^]]+\\)" in
    let segments = [name; "\\(("; relation; version; ")\\)?"; "\\(\\["; arches ;"\\]\\)?"] in
      Str.regexp (optwhite ^ (String.concat optwhite segments))

  (*and gname = 1 and gver = 4 and grev = 6*)
  and gname = 1 and gver = 3 and grev = 4 and garches = 6

  and separator_re = 
    let optwhite = "[ \t]*"
    and sep = "\\(,\\||\\)" in
    Str.regexp (optwhite ^ sep ^ optwhite) in

  let rec merge item sep tail =
    if sep = "|" then begin
      match tail with
	Alt rels -> Alt (item :: rels)
      | Conc (hd :: etc) -> Conc ((merge item sep hd) :: etc)
      | name -> Alt [item; name]
    end
    else begin	(* "," *)
      match tail with
      | Conc lst -> Conc (item :: lst)
      | Alt rels -> Conc [item; tail]
      | name -> Conc [item; name]
    end
  in
    if str = ""
    then NoRel
    else
      let rec loop pos =
	try
	  if not (Str.string_match relationship_re str pos) then
	    raise Not_found;
	  let name = Str.matched_group gname str in
	  let arches = try Str.matched_group garches str with Not_found -> "" in
	  let item =
	    if ((arch <> "") &&  
		(arches <> "") &&
		(match Pcre.pmatch ~pat:"!" arches, Pcre.pmatch ~pat:arch arches with
		     true, true -> true
		   | false, false -> true
		   | true, false -> false
		   | false, true -> false))
	    then NoRel
	    else
	      try
		NameCmpVer (name,
			    cmp_of_string (Str.matched_group gver str),
			    Str.matched_group grev str)
	      with
		  Not_found -> Name name in
	  let seppos = Str.match_end () in
	  if not (Str.string_match separator_re str seppos)
	  then item
	  else begin
	    let sep = Str.matched_group 1 str in
	    let nextpos = Str.match_end () in
	    if nextpos = String.length str then item	(* allow trailing , *)
	    else begin
	      let tail = loop nextpos in
	      merge item sep tail
	    end
	  end
	with
	  Not_found ->
	    Message.vq_nl ("Parse error in dependency list: " ^ str);
	    raise (Bad_dependencies str)
      in
      loop 0

let tokenfn1 itemfn = itemfn

let tokenfn2 itemfn token_to_string =
  (fun lexbuf ->
     let token = itemfn lexbuf in
     Message.v0_nl ("token: " ^ (token_to_string token));
     token)

let parse_control lexbuf =
  let tokenfn = tokenfn1 Deblexer.item in
  Deblexer.pos := 1;
  try Debparser.package tokenfn lexbuf
  with
    (Parsing.Parse_error | Sys_error "Bad file descriptor") as exn ->
      if !Deblexer.pos < 10	(* Ugh.  This will eventually fail. *)
      then raise End_of_file
      else raise exn

(* Parse a package's control entry, return the resulting a/v pairs *)

let parse_control_text f text =
  let lexbuf = Lexing.from_string text in
  let avlist = parse_control lexbuf in
  List.iter (fun (a, wv) -> f a wv) avlist

exception Process_Killed of int
exception Process_Stopped of int
exception Process_Error of int

let try_parse_control path =
  let chan = Unix.open_process_in ("dpkg-deb --field " ^ path ^ " 2> /dev/null") in
  let result = 
    try parse_control (Lexing.from_channel chan)
    with
      Parse_error pos -> []
    | End_of_file -> [] in
  match Unix.close_process_in chan with
    Unix.WEXITED 0 -> result
  | Unix.WEXITED n -> raise (Process_Error n)
  | Unix.WSIGNALED n -> raise (Process_Killed n)
  | Unix.WSTOPPED n -> raise (Process_Stopped n)

(* Modify some entries in a parsed control file.  Add any not
   present at the end. *)

let update_control values control =
  Alist.replace_assoc values control

let augment_control values control =
  let newvalues =
    List.filter (fun (a, _) ->
		   try ignore (List.assoc a control); false
		   with Not_found -> true) values in
  control @ newvalues 

let format_control control =
  (String.concat "\n"
     (List.map
	(fun (a, (w, v)) -> (a ^ ":" ^ w ^ v))
	control)) ^ "\n"

let filter_control fields control =
  List.filter
    (fun (a, (w, v)) -> List.mem a fields )
    control

let filter_from_control fields control =
  List.filter
    (fun (a, (w, v)) -> not (List.mem a fields))
    control

(* Create a packages entry for a packages from the entries in its
   control file and its path. *)

let make_package_index_entry control poolroot filename =

  let path = poolroot ^ filename in
  
  (* Create the packages entry.  This appears to be the control file
     with all the entries capitalized and new entries for Size, MD5Sum,
     and Filename (starting with dists/) added. *)

  (* Build the new Packages entry - this adds information about the
     deb to the package's control file.  The fields need to follow the
     order given in fields, with any others omitted.  (I would like to
     find a reference that would justify this.) *)

  let fields = ["Package"; "Essential"; "Priority"; "Section";
		"Installed-Size"; "Maintainer"; "Architecture";
		"Source"; "Version";
		"Replaces"; "Provides"; "Depends"; "Suggests";
		"Recommends"; "Pre-Depends"; "Conflicts";
		"Filename"; "Size"; "MD5sum"; "Description"] in

  let (w1,short) =
    try List.assoc "Description" control
    with Not_found -> ("MISSING DESCRIPTION", "")
  and (w2,long) =
    try List.assoc "Long-Description" control
    with Not_found -> ("", "") in

  let values = ["Description", (" ", short);
		"Long-Description", ("", long);
		"Filename", (" ", filename);
		"Size", (" ",
			 (let stats = Unix.stat path in
			  (string_of_int (stats.Unix.st_size))));
		"MD5sum", (" ", (Util.md5sum path))] in

  let control = augment_control values control in
  let control = update_control values control in
  let control = filter_control fields control in
  control

let make_packages_entry control poolroot filename =
  let control = make_package_index_entry control poolroot filename in
  format_control control

(* Packages in the contrib section sometimes appear as non-US/contrib
   and sometimes as contrib/non-US.  Change either of these to non-US. *)

let rec fix_category str =
  let tryto_drop_suffix str suff =
    try String3.drop_suffix suff str with Not_found -> str
  and tryto_drop_prefix str pre =
    try String3.drop_prefix pre str with Not_found -> str
  and suffixes = ["/contrib"; "/main"; "/non-free"]
  and prefixes = ["contrib/"; "main/"; "non-free/"] in
  let str = List.fold_left tryto_drop_suffix str suffixes in
  let str = List.fold_left tryto_drop_prefix str prefixes in
  String.lowercase str

(************** CHANGELOG FILE ***************)

let sigre = Str.regexp "[ \t-]*\\([^ \t-].*\\)  \\([^\n]*\\)"

type changelog_entry = {
  name: string;
  version: string;
  distribs: string list;
  urgency: string;
  text: string;
  uploader: string;
  date: string}

let parse_changelog lexbuf =
  (* Each item in the changelog_versions list contains attributes
     "Package" "Version" "Distribution" "Urgency" "Logtext"
     "Maintainer" "Logdate".  The list head is the most recent. *)
  let tokenfn = tokenfn1 Loglexer.item (*Loglexer.token_to_string*) in
  try
    let entries = Logparser.entries tokenfn lexbuf in
    let (name, version, distribs, urgency, text, sigline) = List.hd entries in
    if Str.string_match sigre sigline 0 then
      {name=name; version=version; distribs=distribs;
       urgency=urgency; text=text;
       uploader=Str.matched_group 1 sigline;
       date=Str.matched_group 2 sigline}
    else
      raise Parsing.Parse_error
  with Parsing.Parse_error ->
    raise (Parse_error !Loglexer.pos)

(*************** DEB BUILDING *****************)

(* The rules function is used to create an executable that can be
   used as a "debian/rules" file - it accepts one argument, either
   "clean", "build", or "binary".

  To build a portable executable (-g for debugging):
     ocamlc -g unix.cma rules.ml -o rules
   To build a standalone executable:
     ocamlopt unix.cmxa rules.ml -o rules
   
   A portable executable is preferable if the package is cross
   platform because it can be included in the source deb and doesn't
   have to be built before runing dpkg-buildpackage.  However, this
   means the ocaml runtime must be installed on a machine to build the
   package. *)

type rulespec =
    Clean of (changelog_entry -> unit)
  | Build of (changelog_entry -> unit)
  | Install of string * (string -> changelog_entry -> unit)

let rules specs =

  (* Read the substvars file (if any.) *)

  let bindings =
    let path = "debian/substvars" in
    let tbl = Hashtbl.create 10 in
    try
      let ichan = open_in path in
      let istr = Stream.of_channel ichan in
      let buf = Buffer.create 50 in
      let state = ref 1 in
      let id = ref ""
      and value = ref "" in
      Stream.iter
	(fun c ->
	   match (c, !state) with
	     ('=', 1) ->
	       id := Buffer.contents buf;
	       Buffer.reset buf;
	       state := 2
	   | ('\n', 1) ->
	       Buffer.reset buf		(* Syntax error *)
	   | (_, 1) ->
	       Buffer.add_char buf c
	   | ('\n', 2) ->
(*
	       prerr_endline
	       ("substvars: " ^ !id ^ "=" ^ (Buffer.contents buf));
*)
	       Hashtbl.add tbl !id (Buffer.contents buf);
	       Buffer.reset buf;
	       state := 1
	   | (_, 2) ->
	       Buffer.add_char buf c
	   | (_, _) -> assert false) istr;
      tbl
    with
      Sys_error _ ->
	Message.v1 ("No " ^ path ^ " file found.");
	tbl in

  (* Scan a character stream for the variable expansion syntax ${ident}
     and substitute the value of ident in the bindings table.  If there
     is no binding for ident output the original text.  The resulting
     text is passed to f. *)

  let filter bindings istr f =
    let state = ref 1
    and buf = Buffer.create 50 in
    (* State transition example: 1111112333333111111 *)
    (*                           xxxx ${ident} xxxxx *)
    Stream.iter
      (fun c ->
	 match (c, !state) with
	   ('$', 1) ->
	     f (Buffer.contents buf);
	     Buffer.reset buf;
	     Buffer.add_char buf c;
	     state := 2
	 | (_, 1) ->
	     Buffer.add_char buf c; 
	 | ('{', 2) ->
	     Buffer.add_char buf c;
	     state := 3
	 | (_, 2) ->
	     f (Buffer.contents buf);
	     Buffer.reset buf;
	     Buffer.add_char buf c;
	     state := 1
	 | ('}', 3) ->
	     let str = Buffer.contents buf in
	     let id = String.sub str 2 ((String.length str) - 2) in
	     f (try Hashtbl.find bindings id
		with Not_found -> str ^ "}");
	     Buffer.reset buf;
	     state := 1
	 | (_, 3) ->
	     Buffer.add_char buf c
	 | (_, _) -> assert false) istr;
    f (Buffer.contents buf) in

  (* Three helper functions taken from Util.  No very good reason not
     to use the originals, this is left over from when this was a
     standalone file. *)

  let input_lines ichan =
    let result = ref [] in
    try while true do result := (input_line ichan) :: !result done; []
    with End_of_file -> List.rev !result in

  let exec cmd =
    let ichan = Unix.open_process_in cmd in
    let lines = input_lines ichan in
    ignore (Unix.close_process_in ichan);
    lines

  and command cmd =
    let result = Sys.command cmd in
    if result != 0
    then raise (Failure (cmd ^ " -> " ^ (string_of_int result))) in

  let control =
    let lexbuf =
      let buf = Buffer.create 100
      and ichan = open_in "debian/control" in
      let istrm = Stream.of_channel ichan in
      filter bindings istrm (Buffer.add_string buf);
      close_in ichan;
      Lexing.from_string (Buffer.contents buf) in
    let result = ref [] in
    let rec loop _ =
      try result := (parse_control lexbuf) :: !result; loop ()
      with End_of_file -> List.rev !result
    in loop ()

  and {name=name; version=version; distribs=distribs; urgency=urgency;
       text=text; uploader=uploader; date=date} as changelog_entry =
    let lexbuf = Util.lexing_from_file "debian/changelog" in
    parse_changelog lexbuf in

(*
  prerr_endline "CONTROL:";
  List.iter prerr_endline (List.map format_control control);
*)

  let source = List.hd control
  and packages = List.tl control in
  let source_name = Util.tassoc "Source" source
  and package_names = List.map (Util.tassoc "Package") packages in

(*
  Printf.eprintf "name: %s\n" name;
  Printf.eprintf "version: %s\n" version;
  Printf.eprintf "distribs: %s\n" (String.concat "," distribs);
  Printf.eprintf "urgency: %s\n" urgency;
  Printf.eprintf "uploader: %s\n" uploader;
  Printf.eprintf "source: %s\n" source_name;
  Printf.eprintf "%d packages: %s\n" (List.length packages)
    (String.concat " " package_names);
*)

  let hostarch = List.hd (exec "dpkg --print-architecture") in
  let uversion =
    try
      String.sub version 0 (String.index version '-')
    with
      Not_found ->
	version in

  (* "The maintainer name and email address used in the changelog
     should be the details of the person uploading this version. They
     are not necessarily those of the usual package maintainer. The
     information here will be copied to the Changed-By field in the
     .changes file, and then later used to send an acknowledgement
     when the upload has been installed." *)

  let maintainer = Util.tassoc "Maintainer" source in
  let srcctl = "debian/control"
  and binctl = "debian/tmp/DEBIAN/control" in

  match Sys.argv.(1) with
    "clean" ->
      command "rm -rf debian/files debian/tmp debian/*.cm[ixo] debian/rules.o";
      List.iter (function Clean f -> f changelog_entry | _ -> ()) specs

  | "build" ->
      List.iter (function Build f -> f changelog_entry | _ -> ()) specs

  | "binary" ->
      (* Perform the package installation, which is controlled by
	 the "Install" clauses in the rules.ml source file -- see below
	 where it says "perform the install rule."  First we remove the
	 debian/files file, which will contain a list of the packages
	 created by this rule. *)
      command "rm -f debian/files";

      (* Now loop over the packages to be installed. *)
      List.iter
	(fun package ->
	   let name = Util.tassoc "Package" package in
	   prerr_endline ("Package: " ^ name);

	   (* Remove and re-create the temporary install directory. *)
	   command "rm -rf debian/tmp; mkdir -p debian/tmp/DEBIAN";

	   (* Create the DEBIAN/control file by copying the section for
	      this package from the source package's debian/control file,
	      excluding architecture. *)
           let ctl =
     	     List.find (fun ctl -> try (Util.tassoc "Package" ctl) = name
     			with Not_found -> false) control in
	   (* Filter out the Architecture field.  The architecture of the
	      binary deb is a function of the build host architecture and
	      of what is specified in the original control file. *)
           let ctl =
	     List.filter (fun (a, (w, v)) -> a <> "Architecture") ctl in
	   let ochan = open_out binctl in
	   output_string ochan (format_control ctl);
	   (* Determine the package architecture binarch.  This may be
	      specified in the control file, or it may be a result of the
	      architecture of the build machine. *)
	   let arch =
	     try Util.tassoc "Architecture" package with Not_found -> "any" in
	   let binarch = match arch with "any" -> hostarch | _ -> arch in
           output_string ochan ("Version: " ^ version ^ "\n");
           output_string ochan ("Maintainer: " ^ maintainer ^ "\n");
           output_string ochan ("Source: " ^ source_name ^ "\n");
           output_string ochan ("Architecture: " ^ binarch ^ "\n");
	   close_out ochan;

	   (* Install the pre/post install/remove scripts, and shlibs
	      and conffiles which are treated similarly.  If there are
	      several they need to be prefixed with the package name
	      and a "." in the source directory.  If there is only one
	      binary package the package, or this binary package has the
	      same name as the source package, the prefix is optional. *)
	   let prefix = name ^ "." in
	   List.iter
	     (fun script ->
		let src =
		  let src1 = "debian/" ^ script 
		  and src2 = "debian/" ^ prefix ^ script in
		  if File.exists src1 &&
		    (source_name = name || List.length packages = 1)
		  then src1 else src2
		and dst = "debian/tmp/DEBIAN/" ^ script in
		if File.exists src then begin
		  Message.v0_nl ("Debian.rules: linking DEBIAN/" ^ script ^
				 " to " ^ src);
		  Unix.link src dst
		end
		else
		  Message.v1_nl
		    ("Debian.rules: rules: no " ^ src ^ " script."))
	     ["preinst"; "postinst"; "prerm"; "postrm"; "shlibs"; "conffiles"];
	   
	   (* Perform the install rule *)
	   List.iter
	     (fun spec ->
		match spec with
		  Install (rulename, f) when rulename = name ->
		    f "debian/tmp" changelog_entry
		| _ -> ())
	     specs;

	   let section =
	     try Util.tassoc "Section" package
	     with Not_found ->
	       prerr_endline "No 'Section' entry in control file.";
	       raise Missing_Section
	   and priority =
	     try Util.tassoc "Priority" package
	     with Not_found ->
	       prerr_endline "No 'Priority' entry in control file.";
	       raise Missing_Priority in
	   command "echo dpkg --build debian/tmp ..";
	   command "dpkg --build debian/tmp ..";
	   let no_epoch = try List.nth (Str.split (Str.regexp ":") version) 1 with Failure "nth" -> version in
	   command ("dpkg-distaddfile " ^
		    name ^ "_" ^ no_epoch ^ "_" ^ binarch ^ ".deb " ^
		    section ^ " " ^ priority))
	packages

  | _ ->
      raise (Invalid_argument Sys.argv.(1))

(**************** REPOSITORY ****************)

type section = string * string list
type source = string * string * section list

type n_sourcetype = BINARY | SOURCE
type n_source = {typ : n_sourcetype;
		 root : string;
		 dist : string;
		 sects: string list}

let map_of_iter iter f arg =
  let result = ref [] in
  iter (fun x -> result := (f x) :: !result) arg;
  List.rev !result

let iter_dists_of_sources f (sources : source list) =
  List.iter (fun (pool, dist, sections) -> f (pool, dist, sections)) sources

let iter_sections_of_sources f sources =
  iter_dists_of_sources
    (fun (pool, dist, sections) -> 
       (List.iter (fun (section, archlist) ->
		     f (pool, dist, section, archlist)) sections))
    sources

let iter_source_indexes_of_sources f sources =
  iter_sections_of_sources
    (fun (pool, dist, section, _) ->
       let path =
	 (pool ^ "/dists/" ^ dist ^ "/" ^ section ^ "/source/Sources") in
       f (pool, dist, section, path))
    sources

let iter_architectures_of_sources f sources =
  iter_sections_of_sources
    (fun (pool, dist, section, archlist) -> 
       (List.iter (fun arch -> f (pool, dist, section, arch)) archlist))
    sources

let iter_binary_indexes_of_sources f sources =
  iter_architectures_of_sources
    (fun (pool, dist, section, arch) ->
       let path = (pool ^ "/dists/" ^ dist ^ "/" ^
		   section ^ "/binary-" ^ arch ^ "/Packages") in
       f (pool, dist, section, arch, path))
    sources

let map_dists_of_sources f sources =
  map_of_iter iter_dists_of_sources f sources

let map_sections_of_sources f sources =
  map_of_iter iter_sections_of_sources f sources

let map_source_indexes_of_sources f sources =
  map_of_iter iter_source_indexes_of_sources f sources

let map_architectures_of_sources f sources =
  map_of_iter iter_architectures_of_sources f sources

let map_binary_indexes_of_sources f sources =
  map_of_iter iter_binary_indexes_of_sources f sources

(* apply f to the text of each entry in a package index. *)

let iter_packages_of_index f lexbuf =
  Deblexer.pos := 1;
  let lastpos = ref 1 in
  try while true do
    f (Debparser.package Deblexer.item lexbuf);
    lastpos := !Deblexer.pos
  done
  with
    (Parsing.Parse_error |
       (* If  *)
       (Sys_error "Bad file descriptor")) as exn ->
    if !Deblexer.pos != !lastpos then begin
      Message.vq_nl (Printf.sprintf "Parse error at character %d, lastpos=%d"
		       !Deblexer.pos !lastpos);
      raise exn
    end

let map_packages_of_index f lexbuf =
  map_of_iter iter_packages_of_index f lexbuf

(* Read the package lists from the debian repository, pass each entry
   to f along with the pool, dist and directory. *)

let iter_packages_of_sources f sources =
  Message.v1_nl "Reading package indices...";
  iter_binary_indexes_of_sources
    (fun (pool, dist, section, arch, path) ->
       try
	 Message.v1 ("  " ^ path ^ " ... ");
	 let ichan = open_in path in
	 iter_packages_of_index
	   (fun control ->
	      let filename = Util.tassoc "Filename" control in
	      f (pool, dist, section, arch,
		 (pool ^ "/" ^ filename), control))
	   (Lexing.from_channel ichan);
	 close_in ichan;
	 Message.v1 "done.\n"
       with
	 Sys_error msg ->
	   Message.vq_nl msg)
    sources

let iter_packages_of_sources_old f root sources =
  let sources =
    List.map (fun (pool, dist, sects) ->
		(root ^ "/" ^ pool, dist, sects)) sources in
  iter_packages_of_sources f sources

let iter_source_packages_of_sources f sources =
  Message.v1_nl "Reading source package indices...";
  iter_source_indexes_of_sources
    (fun (pool, dist, section, path) ->
       Message.v1 ("  " ^ path ^ " ... ");
       let ichan = open_in path in
       iter_packages_of_index
	 (fun control ->
	    let dir = Util.tassoc "Directory" control in
	    f (pool, dist, section, dir, control))
	 (Lexing.from_channel ichan);
       close_in ichan;
       Message.v1 "done.\n")
    sources

let iter_source_packages_of_sources_old f root sources =
  let sources =
    List.map (fun (pool, dist, sects) ->
		(root ^ "/" ^ pool, dist, sects)) sources in
  iter_packages_of_sources f sources

let iter_source_packages_of_sources_old f root sources =
  Message.v1_nl "Reading source package indices...";
  iter_source_indexes_of_sources
    (fun (pool, dist, section, path) ->
       Message.v1 ("  " ^ path ^ " ... ");
       let ichan = open_in (root ^ "/" ^ path) in
       iter_packages_of_index
	 (fun control ->
	    let dir = Util.tassoc "Directory" control in
	    f (pool, dist, section, (root ^ "/" ^ dir), control))
	 (Lexing.from_channel ichan);
       close_in ichan;
       Message.v1 "done.\n")
    sources

let iter_sources distf sectf archf sources =
  List.iter
    (fun (pool, dist, sections) ->
       distf pool dist;
       List.iter
	 (fun (sect, archlist) ->
	    sectf pool dist sect (pool ^ "/dists/" ^ dist ^ "/" ^ sect ^
				  "/source/Sources");
	    List.iter 
	      (fun arch ->
		 archf pool dist sect arch (pool ^ "/dists/" ^ dist ^ "/" ^
					    sect ^ "/binary-" ^
					    arch ^ "/Packages"))
	      archlist)
	 sections)
    sources

(* Search for valid dist names in a root directory, which should
   contain a "dists" sub-directory. *)

let find_dists =
  let slash = Str.regexp (Str.quote "/") in
  fun root ->
    let cmd = ("cd " ^ root ^ " && " ^
	       "find dists -name Packages -print | " ^
	       "grep 'binary-'") in
    let files = Sh.to_linelist cmd in
    (* Strip off binary-XXXX/Packages *)
    let files = List.map Filename.dirname (List.map Filename.dirname files) in
    (* Split at each "/" *)
    let files = List.map (Str.split slash) files in
    (* Remove the leading "dists" *)
    List2.uniq compare (List.map (fun lst -> List.nth lst 1) files)

(* Construct a sources object for the given pool and dist by searching
   for Packages files. *)

let find_sources_old root dist archlist =
  let pool = Filename.basename root in
  let dir = root ^ "/dists/" ^ dist in
  if not (File.exists dir) then begin
    Message.vq_nl ("No such file: " ^ dir);
    raise Not_found;
  end;
  let indices =
    List.flatten
      (List.map
	 (fun arch ->
	    Sh.to_linelist
	    ("cd " ^ dir ^
	     "&& find . -name Packages -print | " ^
	     "grep '/binary-" ^ arch ^ "' | " ^
	     "sed -e 's:\\./::' -e 's:/binary-" ^ arch ^ "/Packages$::'"))
	 archlist)
  in
  [pool, dist, (List.map
		  (fun dir -> dir,
		   (List.map (fun arch -> arch) archlist))
		  indices)]  

let find_sources_new root dist archlist =
  let dir = root ^ "/dists/" ^ dist in
  if not (File.exists dir) then begin
    Message.vq_nl ("No such file: " ^ dir);
    raise Not_found;
  end;
  let indices =
    List.flatten
      (List.map
	 (fun arch ->
	    Sh.to_linelist
	    ("cd " ^ dir ^
	     "&& find . -name Packages -print | " ^
	     "grep '/binary-" ^ arch ^ "' | " ^
	     "sed -e 's:\\./::' -e 's:/binary-" ^ arch ^ "/Packages$::'"))
	 archlist)
  in
  [root, dist, (List.map
		  (fun dir -> dir,
		   (List.map (fun arch -> arch) archlist))
		  indices)]  

(************** OPERATIONS ON DEBS ********************)

(* Unpack a package deb into the temp root, return the path list. *)

exception Unpack_failure of string
  
external mkdtemp : string -> string = "mkdtemp_native"

let tmpdirref = ref None

let tmpdir () =
  match !tmpdirref with
    None ->
      let path = mkdtemp "/tmp/debian.XXXXXX" in
      tmpdirref := Some path;
      path
  | Some path -> path

let tmproot () = tmpdir () ^ "/root"

let rmtmp () =
  match !tmpdirref with
    None -> ()
  | Some path ->
      Sh.run ("rm -rf " ^ path);
      tmpdirref := None

let unpack path =
  (* If this fails then our database is corrupt. *)
  Message.v0 "unpacking";
  Message.v1 (" " ^ (Filename.basename path));
  Message.v0 " ... ";
  try
    Sh.run ("rm -rf " ^ tmproot ());
    Sh.run ("dpkg -x " ^ path ^ " " ^  tmproot ());
    Sh.run ("dpkg -e " ^ path ^ " " ^ tmproot () ^ "/DEBIAN");
    (* One package, ilisp, had directories without exec permission.
       This is basically meaningless, and we can't look at the directories
       when they are in that condition.  This fixes them. *)
    Sh.run ("find " ^ tmproot () ^ " -type d -exec chmod ugo+x {} \\;");
    (* Extract information about the package from the unpacked tree,
       return a list containing the pathnames. *)
    Sh.to_linelist
      ("cd " ^ tmproot () ^ "; find . -type f | sed 's/^.//'")
  with
    (* Sys_error is raised by Sys.command, Failure by Sh.run if
       Sys.command returns a non-zero value.  If we are unable to do
       any of the above we are toast. *)
    Sys_error msg | Failure msg ->
      raise (Unpack_failure msg)