Interface to ndbm

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

5 files changed, 247 insertions, 0 deletions

diff --git a/otherlibs/dbm/.depend b/otherlibs/dbm/.depend
new file mode 100644
index 000000000..6fa318eed
--- /dev/null
+++ b/otherlibs/dbm/.depend
@@ -0,0 +1,2 @@
+dbm.cmo: dbm.cmi 
+dbm.cmx: dbm.cmi 
diff --git a/otherlibs/dbm/Makefile b/otherlibs/dbm/Makefile
new file mode 100644
index 000000000..82e1524a7
--- /dev/null
+++ b/otherlibs/dbm/Makefile
@@ -0,0 +1,43 @@
+# Makefile for the ndbm library
+
+include ../../config/Makefile
+
+# Compilation optiosn
+CC=$(BYTECC)
+CAMLC=../../boot/cslrun ../../boot/cslc -I ../../boot
+CFLAGS=-I../../byterun -O $(BYTECCCOMPOPTS)
+COBJS=dbm.o
+all: libmldbm.a dbm.cmi dbm.cma
+
+
+libmldbm.a: $(COBJS)
+	rm -rf libmldbm.a
+	ar rc libmldbm.a $(COBJS)
+	$(RANLIB) libmldbm.a
+
+dbm.cma: dbm.cmo
+	$(CAMLC) -a -o dbm.cma dbm.cmo
+
+clean:
+	rm -f *.cm*
+
+realclean: clean
+	rm -rf *.a *.o
+
+install:
+	cp libmldbm.a $(LIBDIR)/libmldbm.a
+	cd $(LIBDIR); $(RANLIB) libmldbm.a
+	cp dbm.cma dbm.cmi $(LIBDIR)
+
+.SUFFIXES: .ml .mli .cmo .cmi .cmx
+
+.mli.cmi:
+	$(CAMLC) -c $(COMPFLAGS) $<
+
+.ml.cmo:
+	$(CAMLC) -c $(COMPFLAGS) $<
+
+depend:
+	../../tools/csldep *.mli *.ml >> .depend
+
+include .depend
diff --git a/otherlibs/dbm/dbm.c b/otherlibs/dbm/dbm.c
new file mode 100644
index 000000000..ac76f156b
--- /dev/null
+++ b/otherlibs/dbm/dbm.c
@@ -0,0 +1,139 @@
+#include <ndbm.h>
+#include <mlvalues.h>
+#include <alloc.h>
+#include <memory.h>
+#include <fail.h>
+
+/* This is copied from sys.c, it shouldn't */
+#include <fcntl.h>
+#ifndef O_BINARY
+#define O_BINARY 0
+#endif
+#ifndef O_TEXT
+#define O_TEXT 0
+#endif
+
+static int sys_open_flags[] = {
+  O_RDONLY, O_WRONLY, O_APPEND, O_CREAT, O_TRUNC, O_EXCL, O_BINARY, O_TEXT
+};
+
+static int dbm_flag_table[] = {
+  DBM_INSERT, DBM_REPLACE
+};
+
+/* Exception bucket for DBMError */
+static value dbm_exn;
+value caml_dbm_install_exn(bucket) /* ML */
+     value bucket;
+{
+  dbm_exn = Field(bucket,0);
+  register_global_root(&dbm_exn);
+  return Val_unit;
+}
+
+void raise_dbm(errmsg)
+     char *errmsg;
+{
+  raise_with_string(dbm_exn, errmsg);
+}
+
+/* Dbm.open : string -> Sys.open_flag list -> int -> t */
+value caml_dbm_open(vfile, vflags, vmode) /* ML */
+     value vfile;
+     value vflags;
+     value vmode;
+{
+  char *file = String_val(vfile);
+  int flags = convert_flag_list(vflags, sys_open_flags);
+  int mode = Int_val(vmode);
+  DBM *db = dbm_open(file,flags,mode);
+
+  if (db == NULL) 
+    raise_dbm("Can't open file");
+  else
+    return ((value)db);
+}
+
+/* Dbm.close: t -> unit */
+value caml_dbm_close(vdb)	/* ML */
+     value vdb;
+{
+  dbm_close((DBM *)vdb);
+  return Val_unit;
+}
+
+/* Dbm.fetch: t -> string -> string */
+value caml_dbm_fetch(vdb,vkey)	/* ML */
+     value vdb;
+     value vkey;
+{
+  datum key,answer;
+  key.dptr = String_val(vkey);
+  key.dsize = string_length(vkey);
+  answer = dbm_fetch((DBM *)vdb, key);
+  if (answer.dptr) {
+    value res = alloc_string(answer.dsize);
+    bcopy(answer.dptr,String_val(res),answer.dsize);
+    return res;
+  }
+  else raise_not_found();
+}
+
+value caml_dbm_store(vdb,vkey,vcontent,vflags) /* ML */
+     value vdb,vkey,vcontent,vflags;
+{
+  int flags = convert_flag_list(vflags, dbm_flag_table);
+  datum key, content;
+  
+  key.dptr = String_val(vkey);
+  key.dsize = string_length(vkey);
+  content.dptr = String_val(vcontent);
+  content.dsize = string_length(vcontent);
+
+  switch(dbm_store((DBM *)vdb, key, content, flags)) {
+  case 0:
+    return Val_unit;
+  case 1:			/* DBM_INSERT and already existing */
+    failwith("dbm_store");
+  default:
+    raise_dbm("dbm_store");
+  }
+}
+
+value caml_dbm_delete(vdb,vkey)	/* ML */
+     value vdb, vkey;
+{
+  datum key;
+  key.dptr = String_val(vkey);
+  key.dsize = string_length(vkey);
+
+  if (dbm_delete((DBM *)vdb, key) < 0)
+    raise_dbm("dbm_delete");
+  else return Val_unit;
+}
+
+value caml_dbm_firstkey(vdb)		/* ML */
+  value vdb;
+{
+  datum key = dbm_firstkey((DBM *)vdb);
+
+  if (key.dptr) {
+    value res = alloc_string(key.dsize);
+    bcopy(key.dptr,String_val(res),key.dsize);
+    return res;
+  }
+  else raise_not_found();
+}
+
+value caml_dbm_nextkey(vdb)		/* ML */
+  value vdb;
+{
+  datum key = dbm_nextkey((DBM *)vdb);
+
+  if (key.dptr) {
+    value res = alloc_string(key.dsize);
+    bcopy(key.dptr,String_val(res),key.dsize);
+    return res;
+  }
+  else raise_not_found();
+}
diff --git a/otherlibs/dbm/dbm.ml b/otherlibs/dbm/dbm.ml
new file mode 100644
index 000000000..7731cb2fd
--- /dev/null
+++ b/otherlibs/dbm/dbm.ml
@@ -0,0 +1,37 @@
+type t
+
+type dbm_flag =
+   DBM_INSERT
+ | DBM_REPLACE
+
+exception Dbm_error of string
+
+external install_exn : exn -> unit
+      	      = "caml_dbm_install_exn"
+external opendbm : string -> open_flag list -> int -> t 
+      	      = "caml_dbm_open"
+external close : t -> unit = "caml_dbm_close"
+external fetch : t -> string -> string = "caml_dbm_fetch"
+external store : t -> string -> string -> dbm_flag list -> unit 
+              = "caml_dbm_store"
+external delete : t -> string -> unit = "caml_dbm_delete"
+external firstkey : t -> string = "caml_dbm_firstkey"
+external nextkey : t -> string = "caml_dbm_nextkey"
+
+let _ = install_exn (Dbm_error "")
+
+(* Usual interfaces *)
+let add t x v = store t x v [DBM_INSERT]
+let find = fetch
+let remove = delete
+
+let iter f t =
+  let rec walk k = 
+    f k (fetch t k); 
+    match try Some(nextkey t) with Not_found -> None
+    with
+	 None -> ()
+       | Some k -> walk k
+  in
+  walk (firstkey t)
+
diff --git a/otherlibs/dbm/dbm.mli b/otherlibs/dbm/dbm.mli
new file mode 100644
index 000000000..1de3b32ea
--- /dev/null
+++ b/otherlibs/dbm/dbm.mli
@@ -0,0 +1,26 @@
+(* DBM (NDBM) interface *)
+
+type t
+
+type dbm_flag =
+   DBM_INSERT
+ | DBM_REPLACE
+
+exception Dbm_error of string
+
+external opendbm : string -> open_flag list -> int -> t 
+      	      = "caml_dbm_open"
+external close : t -> unit = "caml_dbm_close"
+external fetch : t -> string -> string = "caml_dbm_fetch"
+external store : t -> string -> string -> dbm_flag list -> unit 
+              = "caml_dbm_store"
+external delete : t -> string -> unit = "caml_dbm_delete"
+external firstkey : t -> string = "caml_dbm_firstkey"
+external nextkey : t -> string = "caml_dbm_nextkey"
+
+
+(* Usual interfaces *)
+val add: t -> string -> string -> unit
+val find : t -> string -> string
+val remove : t -> string -> unit
+val iter : (string -> string -> 'a) -> t -> unit