(* Dpkg *)
(* $Id: dpkg.ml,v 1.9 2004/10/26 09:44:54 berke Exp $ *)

(*** SS, SSM, IM *)
module SS = struct type t = string * string let compare = compare end ;;
module SSM = Map.Make(SS);;
module IM = Map.Make(struct type t = int let compare = compare end);;
(* ***)

(*** BIG_SET *)
module type BIG_SET =
  sig
    type t
    type u
    type v
    type elt = int
    val fold : (int -> 'b -> 'b) -> t -> 'b -> 'b
    val empty : t
    val union : t -> t -> t
    val diff : t -> t -> t
    val inter : t -> t -> t
    val add : int -> t -> t
    val cardinal : t -> int
    val is_empty : t -> bool
    val elements : t -> int list
    val create_compression_buffer : unit -> v
    val compress : v -> t -> u
    val decompress : v -> u -> t
  end
;;
(* ***)
(*** IS *)
module IS =
  struct
    type t = string
    type u = Rle.t
    type v = Buffer.t
    type elt = int
    let empty = ""
    let range m =
      let n = (m + 7) lsr 3 in
      let u = String.make n '\255' in
      u.[n - 1] <- Char.chr (255 lsr (7 land (8 - (m land 7))));
      u
    ;;
    let copy u = String.copy u;;
    let set i u =
      let m = String.length u in
      let i' = i lsr 3 in
      let v =
        if i' >= m then
          let v = String.make (i' + 1) '\000' in
          String.blit u 0 v 0 m;
          v
        else
          u
      in
      v.[i'] <- Char.chr (Char.code v.[i'] lor (1 lsl (i land 7)));
      v
    ;;
    let add i u =
      let m = String.length u in
      let i' = i lsr 3 in
      let v =
        if i' >= m then
          let v = String.make (i' + 1) '\000' in
          String.blit u 0 v 0 m;
          v
        else
          String.copy u
      in
      v.[i'] <- Char.chr (Char.code v.[i'] lor (1 lsl (i land 7)));
      v
    ;;
    let weight_table =
      let a = Array.make 256 0 in
      for i = 1 to 255 do
        a.(i) <- a.(i lsr 1) + (if i land 1 <> 0 then 1 else 0)
      done;
      a
    ;;
    let fold f u q0 =
      let rec loop1 i y j q =
        if j = 8 then
          q 
        else
          loop1
            (i + 1)
            (y lsr 1)
            (j + 1)
            (if 0 <> y land 1 then f i q else q)
      in
      let m = String.length u in
      let rec loop2 i q =
        if i = m then
          q
        else
          loop2 (i + 1) (loop1 (i lsl 3) (Char.code u.[i]) 0 q)
      in
      loop2 0 q0
    ;;
    let elements y = fold (fun i l -> i::l) y [];;
    let cardinal u =
      let m = String.length u in
      let rec loop c i =
        if i = m then
          c
        else
          loop (c + weight_table.(Char.code u.[i])) (i + 1)
      in
      loop 0 0
    ;;
    let is_empty u =
      let m = String.length u in
      let rec loop i =
        i = m or u.[i] = '\000' && loop (i + 1)
      in
      loop 0
    ;;
    let rec diff u v =
      let m = String.length u
      and n = String.length v
      in
      let w = String.create m in
      for i = 0 to (min m n) - 1 do
        w.[i] <- Char.chr ((Char.code u.[i]) land (lnot (Char.code v.[i])))
      done;
      for i = min m n to m - 1 do
        w.[i] <- u.[i]
      done;
      w
    ;;
    let rec inter u v =
      let m = String.length u
      and n = String.length v
      in
      if m > n then inter v u
      else
        let w = String.create m in
        for i = 0 to m - 1 do
          w.[i] <- Char.chr ((Char.code u.[i]) land (Char.code v.[i]))
        done;
        w
    ;;
    let rec union u v =
      let m = String.length u
      and n = String.length v
      in
      if m > n then union v u
      else
        let w = String.create n in
        for i = 0 to m - 1 do
          w.[i] <- Char.chr ((Char.code u.[i]) lor (Char.code v.[i]))
        done;
        for i = m to n - 1 do
          w.[i] <- v.[i]
        done;
        w
    ;;
    let create_compression_buffer () = Buffer.create 16;;
    let compress b u = Rle.compress b u;;
    let decompress b u = Rle.decompress b u;;
    (*let mem i u =
      let m = String.length u in
      let i' = i lsr 3 in
      i < m && 0 <> Char.code u.[i] land (1 lsl (i land 3))
    ;;*)
  end
;;
(* ***)

module SM = Map.Make(String);;
module SSet = Set.Make(String);;
(* ***)

(*** decompose_line *)
let decompose_line l =
  let i = String.index l ':' in
  (String.sub l 0 i, 
    Util.remove_leading_spaces (String.sub l (i + 1) (String.length l - i - 1)))
;;
(* ***)
(*** first_non_space *)
let first_non_space = Util.first_matching_char (fun c -> not (Util.is_space c));;
(* ***)
(*** paragraph_folder *)
class paragraph_folder :
  object
    method output : out_channel -> unit
    method get : string
    method add_line : string -> unit
    method add_string : string -> unit
    method reset : unit
  end
  =
  object(self)
    val b = Buffer.create 16
    val mutable mode = `Header
    method get = Buffer.contents b
    method output oc = Buffer.output_buffer oc b
    method reset =
      mode <- `Header;
      Buffer.clear b
    method add_string u =
      let l = Util.split_at '\n' u in
      List.iter self#add_line l
    method add_line l =
      let m = String.length l in
      if m = 0 then
        ()
      else
        match l.[0] with
        | (' '|'\t') ->
            if l = " ." then
              begin
                match mode with
                | `Parskip|`Star|`Star_header|`Body -> mode <- `Parskip
                | `Header -> mode <- `Body
              end
            else
              begin
                try
                  let i = first_non_space l in
                  if l.[i] = '*' or l.[i] = '-' then
                    begin
                      match mode with
                      | `Star|`Star_header|`Parskip ->
                          Buffer.add_string b "\n";
                          Buffer.add_substring b l i (m - i);
                          mode <- `Star
                      | `Body|`Header ->
                          Buffer.add_string b "\n\n";
                          Buffer.add_substring b l i (m - i);
                          mode <- `Star_header
                    end
                  else
                    if i > 1 then
                      begin
                        match mode with
                        | `Star|`Star_header ->
                           Buffer.add_char b ' ';
                           Buffer.add_substring b l i (m - i);
                           mode <- `Star
                        | `Header|`Parskip|`Body ->
                           Buffer.add_string b "\n\n";
                           Buffer.add_substring b l i (m - i);
                           mode <- `Body
                      end
                    else
                      begin
                        match mode with
                        | `Star|`Star_header ->
                            Buffer.add_char b ' ';
                            Buffer.add_substring b l i (m - i);
                            mode <- `Star
                        | `Body ->
                            Buffer.add_char b ' ';
                            Buffer.add_substring b l i (m - i);
                            mode <- `Body
                        | `Header|`Parskip ->
                            Buffer.add_string b "\n\n";
                            Buffer.add_substring b l i (m - i);
                            mode <- `Body
                    end
              with
              | Not_found -> mode <- `Parskip
            end
        | _ -> Buffer.add_string b l
  end
;;
(* ***)
(*** dbg *)
type ('methods,'extra,'field) dbg = {
  m : int; (* number of packages *)
  db : 'field array array; (* packages *)
  fields : string array; (* field id -> field name *)
  display_names : string array; (* fidl id -> display field name *)
  package_field : int;
  version_field : int;
  index : int SSM.t; (* key -> int *)
  universe : IS.t; (* all packages *)
  extra : 'extra;
  methods : 'methods
}
(* ***)
(*** load_context *)
type ('extra, 'field) load_context = {
  field_index : (string,int) Hashtbl.t;
  non_canonical_names : (string,string) Hashtbl.t;
  mutable field_count : int;
  read_buffer : Buffer.t;
  mutable package_count : int;
  mutable packages : (int * 'field) list list;
  mutable ctx_extra : 'extra (* shared_strings : (string,string) Hashtbl.t *)
};;
(* ***)
(*** line_reader *)
class line_reader ic =
  let m = 8192 in
  object(self)
    val u = String.make m '\000'
    val mutable i = 0 (* bytes 0..i-1 have already been processed *)
    val mutable j = 0 (* length of buffer *)
    val mutable offset = 0 (* offset of byte zero of buffer *)
    val b = Buffer.create m
    method get_offset = offset
    (* ok *)
    method reset =
      offset <- 0;
      i <- 0;
      j <- 0
    (* *)
    method refill =
      assert (i >= j); (* refuse to refill if all bytes have not been consumed *)
      let j' = j in (* save old buffer length *)
      j <- input ic u 0 m; (* input some bytes *)
      i <- 0; (* reset pointer *)
      offset <- offset + j' (* update offset *)

    method input_line_with_offset =
      let o = offset + i in (* offset of beginning of line *)

      Buffer.clear b;

      let rec find i = (* find first '\n', return j otherwise *)
        if i = j then
          j
        else
          if u.[i] = '\n' then
            i
          else
            find (i + 1)
      in

      (* read a complete line *)
      let rec loop () =
        if i >= j then self#refill;
        let k =
          if j = 0 then
            if Buffer.length b > 0 then
              j
            else
              raise End_of_file
          else
            find i
        in
        Buffer.add_substring b u i (k - i);
        i <- k + 1;
        if k < j then
          (* we have a new line *)
          begin
            let v = Buffer.contents b in
            let r = Some(v, o, o + String.length v) in
            r
          end
        else
          (* not yet finished *)
          loop ()
      in
      try
        loop ()
      with
      | End_of_file -> None
  end
  (* ***)
(*** DBT *)
module type DBT =
  sig
    type extra
    type field

    class database_loader :
      object ('a)
        method create_load_context : (extra, field) load_context
        method display_name_of_field : ('a, extra, field) dbg -> int -> string
        method display_string_of_field :
          ('a, extra, field) dbg -> int -> string
        method empty_field : field
        method field_of_string : ('a, extra, field) dbg -> string -> int
        method find_package :
          ('a, extra, field) dbg -> string -> string -> int
        method get_count : ('a, extra, field) dbg -> int
        method get_display_names : ('a, extra, field) dbg -> string array
        method get_field : ('a, extra, field) dbg -> int -> int -> string
        method get_field_from_package :
          ('a, extra, field) dbg -> field array -> int -> string
        method get_fields : ('a, extra, field) dbg -> string array
        method get_package : ('a, extra, field) dbg -> int -> string array
        method get_universe : ('a, extra, field) dbg -> IS.t
        method is_field_empty : field -> bool
        method key :
          (extra, field) load_context -> field -> field -> string * string
        method key_of : ('a, extra, field) dbg -> int -> string * string
        method name_of : ('a, extra, field) dbg -> int -> string
        method package_field : ('a, extra, field) dbg -> int
        method string_of_field : ('a, extra, field) dbg -> int -> string
        method version_field : ('a, extra, field) dbg -> int
        method version_of : ('a, extra, field) dbg -> int -> string
        method load :
          ?fast:bool ->
          ?progress:(string -> int -> unit) ->
          string list -> ('a, extra, field) dbg
        method load_single_file :
          fast:bool ->
          ?progress:(string -> int -> unit) ->
          (extra, field) load_context -> string -> unit
        (*method make_field :
          context:(extra, field) load_context ->
          fast:bool ->
          file_id:int ->
          start_offset:int ->
          end_offset:int ->
          field_name:string ->
          field_contents:string -> first_line:string -> field*)
        (*method read_tags :
          ?fast:bool ->
          int ->
          (extra, field) load_context ->
          reader:line_reader -> (int * field) list*)
      end
  end
;;
(* ***)
(*** Misc *)
class pf = paragraph_folder;;
module Misc(DBT : DBT) =
  struct
    open DBT
    type db = (database_loader, extra, field) dbg
    class paragraph_folder = pf
    module IS = IS
    let field_of_string (db : db) = db.methods#field_of_string db;;
    let string_of_field (db : db) = db.methods#string_of_field db;;
    let display_name_of_field (db : db) = db.methods#display_name_of_field db;;
    let display_string_of_field (db : db) = db.methods#display_string_of_field db;;
    let name_of (db : db) = db.methods#name_of db;;
    let version_of (db : db) = db.methods#version_of db;;
    let key_of (db : db) = db.methods#key_of db;;
    let find_package (db : db) = db.methods#find_package db;;
    let get_package (db : db) = db.methods#get_package db;;
    let get_field (db : db) = db.methods#get_field db;;
    let get_field_from_package (db : db) = db.methods#get_field_from_package db;;
    let get_universe (db : db) = db.methods#get_universe db;;
    let get_fields (db : db) = db.methods#get_fields db;;
    let get_count (db : db) = db.methods#get_count db;;
    let get_display_names (db : db) = db.methods#get_display_names db;;
    let package_field (db : db) = db.methods#package_field db;;
    let version_field (db : db) = db.methods#version_field db;;
  end
;;
(* ***)

(*** DB *)
module type DB =
  sig
    module IS : BIG_SET
    type db and field
    val field_of_string : db -> string -> int
    val string_of_field : db -> int -> string
    val display_name_of_field : db -> int -> string
    val display_string_of_field : db -> int -> string
    val name_of : db -> int -> string
    val version_of : db -> int -> string
    val key_of : db -> int -> string * string
    val find_package : db -> string -> string -> int
    val get_package : db -> int -> string array
    val get_field : db -> int -> int -> string
    exception Malformed_line of string
    val find_database_files : (string * string) list -> string list
    val load : ?fast:bool -> ?progress:(string -> int -> unit) -> string list -> db
    val get_universe : db -> IS.t
    val get_fields : db -> string array
    val get_count : db -> int
    val get_display_names : db -> string array
    val package_field : db -> int
    val version_field : db -> int
    val backend : string
    class paragraph_folder :
      object
        method output : out_channel -> unit
        method get : string
        method add_line : string -> unit
        method add_string : string -> unit
        method reset : unit
      end
  end
;;
(* ***)
(*** create_load_context *)
let create_load_context extra =
  { field_index = Hashtbl.create 16;
    non_canonical_names = Hashtbl.create 16;
    field_count = 0;
    read_buffer = Buffer.create 16;
    package_count = 0;
    packages = [];
    ctx_extra = extra };;
(* ***)
(*** binary_search *)
let binary_search a x =
  let m = Array.length a in
  let rec loop i0 m =
    if m = 0 then
      raise Not_found
    else
      begin
        if m < 8 then
          if a.(i0) = x then
            i0
          else
            loop (i0 + 1) (m - 1)
        else
          let i = i0 + m / 2 in
          let y = a.(i) in
          if x = y then
            i
          else
            if x < y then
              loop i0 (m / 2)
            else
              loop (i + 1) (m - m / 2)
      end
  in
  loop 0 m
;;
(* ***)

exception Malformed_line of string;;

(*** collect_field_values *)
let collect_field_values db j =
  let a = db.db in
  let rec loop i r =
    if i = Array.length a then
      r
    else
      loop (i + 1) (if a.(i).(j) <> "" then SSet.add a.(i).(j) r else r) (* XXX *)
  in
  let s = loop 0 SSet.empty in
  SSet.elements s
;;
(* ***)
(*** find_database_files *)
let find_database_files dbfn =
  List.fold_left (fun l (path,patt) ->
    let fns = Slurp.slurp path in
    let re = Str.regexp patt in
    let rec loop curpath (l : string list) = function
      | Slurp.File(fn,_) ->
         if try ignore (Str.search_forward re fn 0); true with Not_found -> false then
           (Filename.concat curpath fn)::l
         else
           l
      | Slurp.Directory(d,fl) ->
          List.fold_left (fun l t -> loop (Filename.concat curpath d) l t) l fl
      | Slurp.Error(_,_) -> l
    in
    loop "" l fns) [] dbfn
;;
(* ***)
(*** database *)
class virtual ['extra,'field,'file_id] database =
  object(self : 'a)
    method field_of_string (db : ('a,'extra,'field) dbg) w = binary_search db.fields w
    method string_of_field (db : ('a,'extra,'field) dbg) f = db.fields.(f)
    method display_name_of_field (db : ('a,'extra,'field) dbg) (f : int) : string = db.display_names.(f)
    method display_string_of_field (db : ('a,'extra,'field) dbg) f = db.display_names.(f)
    method virtual name_of : ('a,'extra,'field) dbg -> int -> string
    method virtual version_of : ('a,'extra,'field) dbg -> int -> string
    method key_of db i = (self#name_of db i, self#version_of db i)
    (*method virtual key_of : ('a,'extra,'field) dbg -> int -> string * string*)
    method find_package (db : ('a,'extra,'field) dbg) pn pv = SSM.find (pn, pv) db.index
    method virtual get_package : ('a,'extra,'field) dbg -> int -> string array
    method virtual get_field : ('a,'extra,'field) dbg -> int -> int -> string
    method virtual get_field_from_package : ('a,'extra,'field) dbg -> 'field array -> int -> string
    method get_universe (db : ('a,'extra,'field) dbg) = db.universe
    method get_fields (db : ('a,'extra,'field) dbg) = db.fields
    method get_count (db : ('a,'extra,'field) dbg) = db.m
    method get_display_names (db : ('a,'extra,'field) dbg) = db.display_names
    method package_field (db : ('a,'extra,'field) dbg) = db.package_field
    method version_field (db : ('a,'extra,'field) dbg) = db.version_field

    method private virtual make_field :
      context:('extra,'field) load_context ->
      fast:bool ->
      file_id:'file_id ->
      start_offset:int ->
      end_offset:int ->
      field_name:string ->
      field_contents:string ->
      first_line:string ->
      'field

    (*
    (*** input_line_with_offset *)
    method input_line_with_offset b offset ic =
      Buffer.clear b;
      let o1 = !offset in
      let rec loop () =
        match try Some(input_char ic) with End_of_file -> None with
        | Some('\n'|'\000')|None ->
            let o2 = !offset in
            incr offset;
            Some(Buffer.contents b,o1,o2-1)
        | Some(c) ->
            incr offset;
            Buffer.add_char b c;
            loop ()
      in
      loop ()
    (* ***) *)

    (*** read_tags *)
    method private read_tags ?(fast=false) file_id ctx ~(reader : line_reader) =
      let b = ctx.read_buffer in
      Buffer.clear b;
      let add_row ~(rows : (int * 'field) list)  ~end_offset = function
      | None -> rows
      | Some(field_name, start_offset, first_line) ->
        (* Find the corresponding field id *)
        let x' = String.lowercase field_name in
        let i =
          try
            let x'' = Hashtbl.find ctx.non_canonical_names x' in
            if field_name < x'' then Hashtbl.replace ctx.non_canonical_names x' field_name;
            Hashtbl.find ctx.field_index x'
          with
          | Not_found ->
              let i = ctx.field_count in
              Hashtbl.add ctx.field_index x' i;
              Hashtbl.add ctx.non_canonical_names x' field_name;
              ctx.field_count <- i + 1;
              i
        in
        let y = Buffer.contents b in
        Buffer.clear b;
        let y =
          self#make_field
            ~context:ctx
            ~fast
            ~file_id
            ~start_offset
            ~end_offset
            ~field_name:x'
            ~field_contents:y
            ~first_line
        in
        ((i,y)::rows)
      in
      (* Header -- Body -- Parskip -- Star *)
      let rec loop ~rows ~pending =
       match reader#input_line_with_offset with
       | None -> add_row ~rows ~end_offset:(reader#get_offset) pending (* ... *)
       | Some(l,o1,o2) ->
           let m = String.length l in
           if m = 0 then
             add_row ~rows ~end_offset:o2 pending (* ... *)
           else
             match l.[0] with
             | (' '|'\t') ->
                 Buffer.add_char b '\n';
                 Buffer.add_string b l;
                 loop ~rows ~pending
             | _ ->
                 let rows = add_row ~rows ~end_offset:o1 pending in
                 let (x,y) =
                   try
                     decompose_line l
                   with
                   | Not_found -> raise (Malformed_line(l))
                 in
                 Buffer.add_string b y;
                 loop ~rows ~pending:(Some(x,o1 + m - String.length y,y))
       in
       loop ~rows:[] ~pending:None
    (* ***)
    (*** load_single_file *)
    method virtual load_single_file :
      fast:bool ->
      ?progress:(string -> int -> unit) ->
      ('extra, 'field) load_context ->
      string ->
      unit

    (* ***)

    method virtual empty_field : 'field
    method virtual is_field_empty : 'field -> bool
    method virtual create_load_context : ('extra,'field) load_context

    method load ?(fast=false) ?(progress = fun _ _ -> ()) fnl =
      let ctx = self#create_load_context in
      List.iter (fun fn -> self#load_single_file ~fast ~progress ctx fn) fnl;
      (* let's sort fields *)
      let fields = Array.make ctx.field_count (0,"") in
      Hashtbl.iter (fun w i -> fields.(i) <- (i,w)) ctx.field_index;
      Array.sort (fun (_,w1) (_,w2) -> compare w1 w2) fields;
      let translate = Array.make ctx.field_count 0 in
      for i = 0 to ctx.field_count - 1 do
        let (j,_) = fields.(i) in
        translate.(j) <- i
      done;
      let fields = Array.map (fun (_,w) -> w) fields in
      let package_field = translate.(Hashtbl.find ctx.field_index "package")
      and version_field = translate.(Hashtbl.find ctx.field_index "version")
      in
      let array_of_row row =
        let a = Array.make ctx.field_count self#empty_field in
        (*List.iter (fun (i,w) -> if a.(translate.(i)) = "" then a.(translate.(i)) <- w) row;*)
        List.iter (fun (i,w) ->
          if self#is_field_empty a.(translate.(i)) then a.(translate.(i)) <- w) row;
        a
      in
      let key a = self#key ctx a.(package_field) a.(version_field) in
      let b = Array.of_list ctx.packages in
      let db = Array.make (Array.length b) [||] in
      let rec build i index j =
        if j = Array.length b then
          i,index,db
        else
          let row = b.(j) in
          let a = array_of_row row in
          let ((p,v) as k) = key a in
          if SSM.mem k index then
            begin
              let i' = SSM.find k index in
              let a' = db.(i') in
              for l = 0 to Array.length a - 1 do
                if self#is_field_empty a'.(l) && not (self#is_field_empty a.(l)) then
                  begin
                    a'.(l) <- a.(l)
                  end
                else
                  ()
              done;
              build i index (j + 1)
            end
          else 
            begin
              db.(i) <- a;
              build (i + 1) (SSM.add k i index) (j + 1)
            end
      in
      let m,index,db = build 0 SSM.empty 0 in
      let db = Array.sub db 0 m in
      let universe = IS.range m in
      { m = m;
        db = db;
        fields = fields;
        display_names = Array.map (fun f -> Hashtbl.find ctx.non_canonical_names f) fields;
        package_field = package_field;
        version_field = version_field;
        index = index;
        universe = universe;
        extra = ctx.ctx_extra;
        methods = self }
  end
;;
(* ***)

module V = Virtual_strings;;

(*** DBFS *)
module DBFS : DB =
  struct
    (*** database_loader *)
    class database_loader =
      let empty_field = V.make_real_string "" in
      let reify db x = V.get_string db.extra x in
      object(self : 'a)
        inherit [V.pool, V.t, int] database as super
        method get_package db i = Array.map (reify db) db.db.(i)
        method get_field db i j = reify db db.db.(i).(j)
        method get_field_from_package db p j = reify db p.(j)
        method name_of db i = reify db db.db.(i).(db.package_field)
        method version_of db i = reify db db.db.(i).(db.version_field)
        method empty_field = V.empty_string
        method is_field_empty x = V.is_empty x
        method key ctx package version =
           (V.get_real_string ctx.ctx_extra package,
            V.get_real_string ctx.ctx_extra version)
        method private make_field ~context ~fast ~file_id ~start_offset ~end_offset
          ~field_name ~field_contents ~first_line =
          (*Printf.eprintf "make_field file %d start %d end %d name %S contents %S\n"
            file_id start_offset end_offset field_name field_contents; *)
          if field_name = "package" or field_name = "version" then
            V.make_real_string first_line
          else
            V.make_virtual_string
              context.ctx_extra
              file_id
              start_offset
              (end_offset - start_offset - 1) (* XXX *)

        method create_load_context = create_load_context (V.create ())

        method load_single_file ~fast ?(progress = fun _ _ -> ()) ctx fn =
          let fd = Unix.openfile fn [Unix.O_RDONLY] 0 in
          let ic = Unix.in_channel_of_descr fd in
          let reader = new line_reader ic in
          let fi = V.add_file ctx.ctx_extra fn fd in
          let rec loop i =
            if i land 1023 = 0 then
              begin
                progress fn ctx.package_count;
              end;
            let l = self#read_tags fi ctx ~reader in
            if l = [] then
              (* close_in ic *)
              ()
            else
              begin
                ctx.packages <- l::ctx.packages;
                ctx.package_count <- 1 + ctx.package_count;
                loop (i + 1)
              end
          in
          loop 0
      end

      let find_database_files = find_database_files
      exception Malformed_line of string (* XXX *)

      let loader = new database_loader
      let load = loader#load
    (* ***)

    type dbi = (database_loader, V.pool, V.t) dbg
    type field = V.t
    class dl = database_loader
    module M = Misc(struct
        type field = V.t
        and extra = V.pool
        class database_loader = dl
      end)
    include M
    open M

    let backend = "DBFS";;

    (*let field_of_string (db : db) = db.methods#field_of_string db;;
    let string_of_field (db : db) = db.methods#string_of_field db;;
    let display_name_of_field (db : db) = db.methods#display_name_of_field db;;
    let display_string_of_field (db : db) = db.methods#display_string_of_field db;;
    let name_of (db : db) = db.methods#name_of db;;
    let version_of (db : db) = db.methods#version_of db;;
    let key_of (db : db) = db.methods#key_of db;;
    let find_package (db : db) = db.methods#find_package db;;
    let get_package (db : db) = db.methods#get_package db;;
    let get_field (db : db) = db.methods#get_field db;;
    let get_field_from_package (db : db) = db.methods#get_field_from_package db;;
    let get_universe (db : db) = db.methods#get_universe db;;
    let get_fields (db : db) = db.methods#get_fields db;;
    let get_count (db : db) = db.methods#get_count db;;
    let get_display_names (db : db) = db.methods#get_display_names db;;
    let package_field (db : db) = db.methods#package_field db;;
    let version_field (db : db) = db.methods#version_field db;;*)
  end
;;
(* ***)

(*** DBRAM *)
module DBRAM : DB =
  struct
    (*** database_loader *)
    class database_loader =
      let empty_field = V.make_real_string "" in
      let reify db x = V.get_string db.extra x in
      object(self : 'a)
        inherit [(string,string) Hashtbl.t, string, string] database as super
        method get_package db i = db.db.(i)
        method get_field db i j = db.db.(i).(j)
        method get_field_from_package db p j = p.(j)
        method name_of db i = db.db.(i).(db.package_field)
        method version_of db i = db.db.(i).(db.version_field)
        method empty_field = ""
        method is_field_empty x = "" = x
        method key ctx package version = (package, version)
        method private make_field ~context ~fast ~file_id ~start_offset ~end_offset
          ~field_name ~field_contents ~first_line =
          let x =
            if field_name = "package" or field_name = "version" then
              first_line
            else
              field_contents
          in
          if fast then
            x
          else
            try
              Hashtbl.find context.ctx_extra x
            with
            | Not_found ->
                Hashtbl.add context.ctx_extra x x;
                x

        method create_load_context = create_load_context (Hashtbl.create 1024)

        method load_single_file ~fast ?(progress = fun _ _ -> ()) ctx fn =
          let ic = open_in fn in
          let reader = new line_reader ic in
          let rec loop i =
            if i land 1023 = 0 then
              begin
                progress fn ctx.package_count;
              end;
            let l = self#read_tags fn ctx ~reader in
            if l = [] then
              close_in ic
            else
              begin
                ctx.packages <- l::ctx.packages;
                ctx.package_count <- 1 + ctx.package_count;
                loop (i + 1)
              end
          in
          loop 0
      end

      let find_database_files = find_database_files
      exception Malformed_line of string (* XXX *)

      let loader = new database_loader
      let load = loader#load
    (* ***)
    type dbi = (database_loader, (string, string) Hashtbl.t, string) dbg
    type field = V.t
    class dl = database_loader
    module M = Misc(struct
        type field = string
        and extra = (string, string) Hashtbl.t
        class database_loader = dl
      end)
    include M
    open M
    let backend = "DBRAM";;
  end
;;
(* ***)
