(in-package :db)

(defconstant +db-current+ 7)
(defconstant +db-first+ 9)
(defconstant +db-last+ 17)
(defconstant +db-next+ 18)
(defconstant +db-prev+ 25)
(defconstant +db-set+ 28)
(defconstant +db-set-range+ 30)

(defvar *db-directory* #p"/")
(defvar *db-key* nil)
(defvar *db-key-1* nil)
(defvar *db-key-2* nil)
(defvar *db-value* nil)

(lisp:clines "#include \"berkeley-db.c\"")
(lisp:defentry %db-init (lisp:object) (lisp:void "db_init"))
(lisp:defentry %db-open (lisp:string lisp:string) (lisp:int "db_open"))
(lisp:defentry db-close (lisp:int) (lisp:void "db_close"))
(lisp:defentry db-get (lisp:int lisp:object) (lisp:object "db_get"))
(lisp:defentry db-put (lisp:int lisp:object lisp:object) (lisp:void "db_put"))
(lisp:defentry db-delete (lisp:int lisp:object) (lisp:void "db_delete"))
(lisp:defentry db-sync (lisp:int) (lisp:void "db_sync"))
(lisp:defentry db-cursor (lisp:int) (lisp:int "db_cursor"))
(lisp:defentry db-cursor-close (lisp:int) (lisp:void "db_cursor_close"))
(lisp:defentry %db-cursor-move (lisp:int lisp:int lisp:object) (lisp:object "db_cursor_move"))

(lisp:defcfun "
#include <db.h>
#include <sys/types.h>
#include <unistd.h>

int btree_compare (DB *db, const DBT *a_dbt, const DBT *b_dbt)" 0
  "object a, b;"
  "int result;"
  "dbt_to_string (a_dbt, current_key_string_1);"
  "dbt_to_string (b_dbt, current_key_string_2);"
  ((si:string-to-object current_key_string_1) a)
  ((si:string-to-object current_key_string_2) b)
  ((compare a b) (lisp:int result))
  "return result;")

(lisp:defcfun "void db_init (object fn)" 0
  "current_key_string = alloc_simple_string (0);
   current_key_string_1 = alloc_simple_string (0);
   current_key_string_2 = alloc_simple_string (0);
   current_value_string = alloc_simple_string (0);"
  (funcall fn
	   current_key_string
	   current_key_string_1
	   current_key_string_2
	   current_value_string))

(defun db-init ()
  (%db-init (lambda (key key-1 key-2 value)
	      (setf *db-key* key
		    *db-key-1* key-1
		    *db-key-2* key-2
		    *db-value* value))))

(defun db-open (pathname key-type)
  (%db-open (namestring (make-pathname :type "db" :defaults (merge-pathnames pathname *db-directory*)))
	    (copy-seq (string key-type))))

(defun db-cursor-move (cursor flags &optional key)
  (%db-cursor-move cursor flags key))

(defmacro with-database ((db &rest args) &body body)
  `(let ((,db (db-open ,@args)))
     (unwind-protect
         (progn ,@body)
       (db-close ,db))))