DB interface

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@1873 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

6 files changed, 495 insertions, 0 deletions

diff --git a/otherlibs/db/.depend b/otherlibs/db/.depend
new file mode 100644
index 0000000000..5d94dce520
--- /dev/null
+++ b/otherlibs/db/.depend
@@ -0,0 +1,2 @@
+db.cmo: db.cmi 
+db.cmx: db.cmi 
diff --git a/otherlibs/db/Makefile b/otherlibs/db/Makefile
new file mode 100644
index 0000000000..bff7a58139
--- /dev/null
+++ b/otherlibs/db/Makefile
@@ -0,0 +1,56 @@
+# Makefile for the ndbm library
+
+include ../../config/Makefile
+
+# Compilation optiosn
+CC=$(BYTECC) -g
+CAMLC=../../boot/ocamlrun ../../boot/ocamlc -I ../../stdlib
+CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib
+CFLAGS=-I../../byterun -O $(BYTECCCOMPOPTS)
+COBJS=dbstubs.o
+
+all: libmldb.a db.cmi db.cma
+
+allopt: libmldb.a db.cmi db.cmxa
+
+libmldb.a: $(COBJS)
+	rm -rf libmldb.a
+	ar rc libmldb.a $(COBJS)
+	$(RANLIB) libmldb.a
+
+db.cma: db.cmo
+	$(CAMLC) -a -o db.cma db.cmo
+
+db.cmxa: db.cmx
+	$(CAMLOPT) -a -o db.cmxa db.cmx
+
+partialclean:
+	rm -f *.cm*
+
+clean: partialclean
+	rm -f *.a *.o
+
+install:
+	cp libmldb.a $(LIBDIR)/libmldb.a
+	cd $(LIBDIR); $(RANLIB) libmldb.a
+	cp db.cma db.cmi db.mli $(LIBDIR)
+
+installopt:
+	cp db.cmx db.cmxa db.a $(LIBDIR)
+	cd $(LIBDIR); $(RANLIB) db.a
+
+.SUFFIXES: .ml .mli .cmo .cmi .cmx
+
+.mli.cmi:
+	$(CAMLC) -c $(COMPFLAGS) $<
+
+.ml.cmo:
+	$(CAMLC) -c $(COMPFLAGS) $<
+
+.ml.cmx:
+	$(CAMLOPT) -c $(COMPFLAGS) $<
+
+depend:
+	../../tools/ocamldep *.mli *.ml > .depend
+
+include .depend
diff --git a/otherlibs/db/db.ml b/otherlibs/db/db.ml
new file mode 100644
index 0000000000..a0b1f39f98
--- /dev/null
+++ b/otherlibs/db/db.ml
@@ -0,0 +1,112 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*          Francois Rouaix, projet Cristal, INRIA Rocquencourt        *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  Automatique.  Distributed only by permission.                      *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id *)
+
+(* Module [Db]: interface to the DB databases *)
+
+(* this collides with Unix *)
+type open_flag =
+    O_CREAT
+  | O_EXCL
+  | O_RDONLY
+  | O_RDWR
+  | O_TRUNC
+
+type routine_flag =
+    R_CURSOR
+  | R_FIRST
+  | R_LAST
+  | R_NEXT
+  | R_NOOVERWRITE
+  | R_PREV
+  | R_SETCURSOR
+
+type file_perm = int
+
+exception DB_error of string
+  (* Raised by the following functions when an error is encountered. *)
+
+external caml_db_init : unit -> unit
+    = "caml_db_init"
+
+let _ = Callback.register_exception "dberror" (DB_error "")
+let _ = caml_db_init()
+
+type key = string
+type data = string
+type t
+
+(* Raw access *)
+external dbopen : string -> open_flag list -> file_perm -> bool -> t
+    = "caml_db_open"
+    (* [dbopen file flags mode dupentries] *)
+
+(* The common subset of available primitives *)
+external close : t -> unit
+    = "caml_db_close"
+
+external del : t -> key -> routine_flag list -> unit
+    = "caml_db_del"
+    (* raise Not_found if the key was not in the file *)
+
+external get : t -> key -> routine_flag list -> data
+    = "caml_db_get"
+    (* raise Not_found if the key was not in the file *)
+
+external put : t -> key -> data -> routine_flag list -> unit
+    = "caml_db_put"
+
+external seq : t -> key -> routine_flag list -> (key * data)
+    = "caml_db_seq"
+
+external sync : t -> unit
+    = "caml_db_sync"
+
+
+(* Wrap-up as for other table-like types *)
+let add db x v = put db x v [R_NOOVERWRITE]
+let find db x = get db x []
+let find_all db x = 
+  try
+    match seq db x [R_CURSOR] with
+      k, v when k = x ->
+	let l = ref [v] in
+	begin
+	  try 
+	    while true do
+	      let k, v = seq db x [R_NEXT] in
+	      if k = x then l := v :: !l
+	      else raise Exit
+	    done;
+	    !l
+	  with
+	    Exit | Not_found -> !l
+	end
+    | _ -> (* its greater than x *) []
+  with
+    Not_found -> []
+
+let remove db x = del db x []
+
+let iter f db = 
+  let rec walk k =
+    let k, v = seq db k [R_NEXT] in
+    f k v;
+    walk k
+  in
+  try
+    let k, v = seq db "" [R_FIRST] in
+    f k v;
+    walk k
+  with
+    Not_found -> ()
+	
diff --git a/otherlibs/db/db.mli b/otherlibs/db/db.mli
new file mode 100644
index 0000000000..125eae13f8
--- /dev/null
+++ b/otherlibs/db/db.mli
@@ -0,0 +1,74 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*          Francois Rouaix, projet Cristal, INRIA Rocquencourt        *)
+(*                                                                     *)
+(*  Copyright 1996 Institut National de Recherche en Informatique et   *)
+(*  Automatique.  Distributed only by permission.                      *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id *)
+
+(* Module [Db]: interface to the DB databases of type btree. Cf dbopen(3) *)
+
+(* this collides with Unix *)
+type open_flag =
+    O_CREAT
+  | O_EXCL
+  | O_RDONLY
+  | O_RDWR
+  | O_TRUNC
+
+type routine_flag =
+    R_CURSOR
+  | R_FIRST
+  | R_LAST
+  | R_NEXT
+  | R_NOOVERWRITE
+  | R_PREV
+  | R_SETCURSOR
+
+type file_perm = int
+
+exception DB_error of string
+  (* Raised by the following functions when an error is encountered. *)
+
+type key = string
+type data = string
+
+type t
+
+(* Raw access *)
+external dbopen : string -> open_flag list -> file_perm -> bool -> t
+    = "caml_db_open"
+    (* [dbopen file flags mode] *)
+
+(* The common subset of available primitives *)
+external close : t -> unit
+    = "caml_db_close"
+
+external del : t -> key -> routine_flag list -> unit
+    = "caml_db_del"
+    (* raise Not_found if the key was not in the file *)
+
+external get : t -> key -> routine_flag list -> data
+    = "caml_db_get"
+    (* raise Not_found if the key was not in the file *)
+
+external put : t -> key -> data -> routine_flag list -> unit
+    = "caml_db_put"
+
+external seq : t -> key -> routine_flag list -> (key * data)
+    = "caml_db_seq"
+
+external sync : t -> unit
+    = "caml_db_sync"
+
+
+val add : t -> key -> data -> unit
+val find : t -> key -> data
+val find_all : t -> key -> data list
+val remove : t -> key -> unit
+val iter : (string -> string -> unit) -> t -> unit
diff --git a/otherlibs/db/dbstubs.c b/otherlibs/db/dbstubs.c
new file mode 100644
index 0000000000..5e2b67c674
--- /dev/null
+++ b/otherlibs/db/dbstubs.c
@@ -0,0 +1,228 @@
+/***********************************************************************/
+/*                                                                     */
+/*                           Objective Caml                            */
+/*                                                                     */
+/*            Francois Rouaix, projet Cristal, INRIA Rocquencourt      */
+/*                                                                     */
+/*  Copyright 1996 Institut National de Recherche en Informatique et   */
+/*  Automatique.  Distributed only by permission.                      */
+/*                                                                     */
+/***********************************************************************/
+
+/* $Id */
+
+#include <mlvalues.h>
+#include <alloc.h>
+#include <memory.h>
+#include <fail.h>
+#include <str.h>
+#include <callback.h>
+
+
+#include <sys/types.h>
+#include <limits.h>
+#include <db.h>
+/* O_CREAT and others are not defined in db.h */
+#include <fcntl.h>
+
+#include <string.h>
+#include "dbstubs.h"
+
+/* This MUST be in the same order as in dbm.mli 
+ * We take a minimum (check O_NONBLOCK ?)
+ */
+static int db_open_flags[] = {
+  O_CREAT, O_EXCL, O_RDONLY, O_RDWR, O_TRUNC
+};
+
+/* R_IAFTER, R_IBEFORE, , R_RECNOSYNC : not relevant for btrees */
+static int db_other_flags[] = {
+  R_CURSOR, R_FIRST, R_LAST, R_NEXT,
+  R_NOOVERWRITE, R_PREV, R_SETCURSOR
+};
+
+/* Exception bucket for Db.error */
+static value *caml_db_exn = NULL;
+
+void raise_db(errmsg)
+     char *errmsg;
+{
+  raise_with_string(*caml_db_exn, errmsg);
+}
+
+/* Finalisation function : occurs once at most !*/
+int caml_db_close_internal(value cdb)
+{
+  /* close the db if needed */
+  if (!Camldb_closed(cdb)) {
+    Camldb_closed(cdb) = 1;
+    return Camldb_db(cdb)->close(Camldb_db(cdb));
+  }
+  else
+    return 0;
+}
+
+static void caml_db_free(value cdb)
+{
+  /* close the db if needed */
+  caml_db_close_internal(cdb);
+  /* free the structure */
+  stat_free((void *)Camldb_info(cdb));
+}
+
+/*
+ * The primitives
+ */
+value caml_db_close(value cdb)	/* ML */
+{
+  if (caml_db_close_internal(cdb) == 0)
+    return Val_unit;
+  else
+    raise_db("close");
+}
+
+value caml_db_del(value cdb, value key, value vflags) /* ML */
+{
+  /* Note: we could check that db is still open */
+  DBT dbt;
+  int flags;
+  
+  Assert(Is_string(key));
+  dbt.data = String_val(key);
+  dbt.size = string_length(key);
+  flags = convert_flag_list(vflags, db_other_flags);
+
+  if ( 0 == Camldb_db(cdb)->del(Camldb_db(cdb), &dbt, flags))
+    return Val_unit;
+  else
+    raise_db("del");
+}
+
+/* fd: is said to be obsolete */
+value caml_db_get(value cdb, value vkey, value vflags) /* ML */
+{
+  DBT key;
+  DBT data;
+  int flags;
+
+  key.data = String_val(vkey);
+  key.size = string_length(vkey);
+  flags = convert_flag_list(vflags, db_other_flags);
+
+  switch (Camldb_db(cdb)->get(Camldb_db(cdb), &key, &data, flags)) {
+  case 0: /* success */
+    {
+      value res = alloc_string(data.size);
+      bcopy(data.data, String_val(res), data.size);
+      return res;
+    }
+  case 1: /* not found */
+    raise_not_found();
+  default:
+    raise_db("get");
+  }
+}
+
+value caml_db_put(value cdb, value vkey, value vdata, value vflags) /* ML */
+{
+  DBT key;
+  DBT data;
+  int flags;
+
+  key.data = String_val(vkey);
+  key.size = string_length(vkey);
+  data.data = String_val(vdata);
+  data.size = string_length(vdata);
+  flags = convert_flag_list(vflags, db_other_flags);
+
+  switch (Camldb_db(cdb)->put(Camldb_db(cdb), &key, &data, flags)) {
+  case 0: /* success */
+    return Val_unit;
+  case 1: /* R_NOOVERWRITE + exists */
+    raise_db("Entry already exists");
+  default:
+    raise_db("put");
+  }
+}
+
+
+value caml_db_seq(value cdb, value vkey, value vflags)	/* ML */
+{
+  DBT key;
+  DBT data;
+  int flags;
+
+  key.data = String_val(vkey);
+  key.size = string_length(vkey);
+
+  flags = convert_flag_list(vflags, db_other_flags);
+  switch (Camldb_db(cdb)->seq(Camldb_db(cdb), &key, &data, flags)) {
+  case 0: /* success */
+    {
+      value reskey = Val_unit, resdata = Val_unit, res = Val_unit;
+      Begin_roots3(reskey, resdata, res);
+      reskey = alloc_string(key.size);
+      resdata = alloc_string(data.size);
+      res = alloc_tuple(2);
+      bcopy(key.data, String_val(reskey), key.size);
+      bcopy(data.data, String_val(resdata), data.size);
+      Field(res, 0) = reskey;
+      Field(res, 1) = resdata;
+      End_roots();
+      return res;
+    }
+  case 1: 
+    raise_not_found();
+  default:
+    raise_db("seq");
+  }
+}
+
+
+value caml_db_sync(value cdb)	/* ML */
+{
+  if (0 == Camldb_db(cdb)->sync(Camldb_db(cdb), 0))
+    return Val_unit;
+  else
+    raise_db("sync");
+}
+
+value caml_db_open(value vfile, value vflags, value vmode, value vdup) /* ML */
+{
+  char *file = String_val(vfile);
+  int flags = convert_flag_list(vflags, db_open_flags);
+  int mode = Int_val(vmode);
+  BTREEINFO *info;
+  DB *db;
+
+  /* Infos for btree structure : 0 is default everywhere */  
+  info = stat_alloc(sizeof(BTREEINFO));
+  bzero(info, sizeof(BTREEINFO));
+  if (Bool_val(vdup)) info->flags |= R_DUP;
+
+  db = dbopen(file,flags,mode,DB_BTREE,info);
+  if (db == NULL) {
+    stat_free(info);
+    raise_db("Can't open file");
+  }
+  else {
+    /* Allocate our structure */
+    value res = alloc_final(Camldb_wosize, caml_db_free, 1, Max_dballoc);
+    Camldb_db(res) = db;
+    Camldb_closed(res) = 0;
+    Camldb_info(res) = info;
+    return res;
+  }
+}
+
+/* Requires the following Caml code:
+exception DBError of string
+let _ = Callback.register_exception "dberror" (DBError "")
+as well as a call to the init function.
+*/
+value caml_db_init(value v)		/* ML */
+{
+  if (caml_db_exn == NULL)
+    caml_db_exn = caml_named_value("dberror");
+  return Val_unit;
+}
diff --git a/otherlibs/db/dbstubs.h b/otherlibs/db/dbstubs.h
new file mode 100644
index 0000000000..f1bb3a5591
--- /dev/null
+++ b/otherlibs/db/dbstubs.h
@@ -0,0 +1,23 @@
+/* A DB is a finalized value containing
+ *  a pointer to the DB,
+ *  a pointer to the openstruct
+ *    (this could be removed if we were sure that the library doesn't keep
+ *     a pointer to it !)
+ */
+struct camldb {
+  final_fun f;
+  DB *db;
+  BTREEINFO *info;
+  int closed;
+};
+
+#define Max_dballoc 1000000
+
+#define Camldb_wosize \
+  ((sizeof(struct camldb) + sizeof(value) - 1) / sizeof(value))
+
+#define Camldb_db(v) (((struct camldb *)(Bp_val(v)))->db)
+#define Camldb_info(v) (((struct camldb *)(Bp_val(v)))->info)
+#define Camldb_closed(v) (((struct camldb *)(Bp_val(v)))->closed)
+
+#define Is_string(v)   (Is_block(v) && (Tag_val(v) == String_tag))