;;;; Copyright (C) 2006 ZOMGROFLCOPTER
;;;;
;;;; This file is part of WALT.
;;;;
;;;; WALT is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU General Public License
;;;; as published by the Free Software Foundation; either version 2
;;;; of the License, or (at your option) any later version.
;;;;
;;;; WALT is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU General Public License
;;;; along with WALT; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.

(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)
(defconstant DB_NOTFOUND -30990)

(defvar *base-pathname* nil)
(defvar *db-key* nil)
(defvar *db-value* nil)
(defvar *db-aux* nil)
(defvar *transaction* 0)

(lisp:clines "
static int error_number = 0;
static object current_key_string;
static object current_key_string_1;
static object current_key_string_2;
static object current_value_string;
static DB_ENV *environment = NULL;")

(lisp:clines "
DBT *
string_to_dbt (object s, DBT *datum)
{
  if (s != Cnil)
    {
      datum->size = s->st.st_fillp;
      datum->data = s->st.st_self;
    }
  return datum;
}

void
dbt_to_string (DBT *datum, object s)
{
  s->st.st_dim = s->st.st_fillp = datum->size;
  s->st.st_self = datum->data;
  return s;
}")

(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:clines "
int
dbt_to_uint (DBT *datum)
{
  int i;
  int result = 0;

  for (i = 0; i < datum->size; i++)
    {
      result *= 10;
      result += (int) (((char *) datum->data)[i] - '0');
    }

  return result;
}

int
compare_uint (DB *db, DBT *a, DBT *b)
{
  return (dbt_to_uint (a) - dbt_to_uint (b));
}

int
db_error_number (void)
{
  return error_number;
}

object
db_error_string (void)
{
  return (make_simple_string (db_strerror (error_number)));
}

int
db_transaction (void)
{
  DB_TXN *txn;
  error_number = environment->txn_begin (environment, NULL, &txn, 0);
  if (error_number != 0)
    return 0;
  return ((int) txn);
}

int
db_commit (int txn)
{
  error_number = (((DB_TXN *) txn)->commit ((DB_TXN *) txn, 0));
  return error_number;
}

int
db_open (char *path, int key_type)
{
  DB *db;
  error_number = db_create (&db, environment, 0);
  if (error_number != 0)
    return 0;
  if (key_type > 0)
    {
      error_number = db->set_bt_compare (db, (key_type == 1) ? compare_uint : btree_compare);
      if (error_number != 0)
        return 0;
    }
  error_number = db->open (db, NULL, path, NULL, DB_BTREE, DB_CREATE, 0);
  if (error_number != 0)
    return 0;
  return ((int) db);
}

int
db_close (int db)
{
  error_number = ((DB *) db)->close ((DB *) db, 0);
  return error_number;
}

int
db_get (int db, object key_string, int txn)
{
  DBT key, value;

  memset (&key, 0, sizeof (DBT));
  memset (&value, 0, sizeof (DBT));

  error_number = ((DB *) db)->get ((DB *) db, (DB_TXN *) txn, string_to_dbt (key_string, &key), &value, 0);
  if (error_number != 0)
    return error_number;

  dbt_to_string (&key, current_key_string);
  dbt_to_string (&value, current_value_string);
  return 0;
}

int
db_put (int db, object key_string, object value_string, int txn)
{
  DBT key, value;

  memset (&key, 0, sizeof (DBT));
  memset (&value, 0, sizeof (DBT));

  error_number = (((DB *) db)->put ((DB *) db, (DB_TXN *) txn, string_to_dbt (key_string, &key),
                                    string_to_dbt (value_string, &value), 0));
  return error_number;
}

int
db_delete (int db, object key_string, int txn)
{
  DBT key;
  memset (&key, 0, sizeof (DBT));
  error_number = (((DB *) db)->del ((DB *) db, (DB_TXN *) txn, string_to_dbt (key_string, &key), 0));
  return error_number;
}

int
db_cursor (int db, int txn)
{
  DBC *cursor;
  error_number = ((DB *) db)->cursor ((DB *) db, (DB_TXN *) txn, &cursor, 0);
  if (error_number != 0)
    return 0;
  return ((int) cursor);
}

int
db_cursor_close (int cursor)
{
  error_number = ((DBC *) cursor)->c_close ((DBC *) cursor);
  return error_number;
}

int
db_cursor_move (int cursor, int flags, object key_string)
{
  DBT key, value;

  memset (&key, 0, sizeof (DBT));
  memset (&value, 0, sizeof (DBT));

  error_number = ((DBC *) cursor)->c_get ((DBC *) cursor, string_to_dbt (key_string, &key), &value, flags);
  if (error_number != 0)
    return error_number;

  dbt_to_string (&key, current_key_string);
  dbt_to_string (&value, current_value_string);
  return error_number;
}

void
db_finish (void)
{
  /* environment->close (environment, 0); */
}")

(lisp:defcfun "int db_init (char *path, object fn)" 0
#|
  "error_number = db_env_create (&environment, 0);
   if (error_number != 0)
     return error_number;
   error_number = environment->open (environment, path, DB_CREATE | DB_INIT_LOCK | DB_INIT_MPOOL | DB_INIT_TXN, 0);
   if (error_number != 0)
     return error_number;"
|#
  "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_value_string current_key_string_1 current_key_string_2)
  "return 0;")

(lisp:defentry %db-init (lisp:string lisp:object) (lisp:int "db_init"))
(lisp:defentry db-finish () (lisp:void "db_finish"))
(lisp:defentry db-error-number () (lisp:int "db_error_number"))
(lisp:defentry db-error-string () (lisp:object "db_error_string"))
(lisp:defentry %db-open (lisp:string lisp:int) (lisp:int "db_open"))
(lisp:defentry %db-close (lisp:int) (lisp:int "db_close"))
(lisp:defentry %db-get (lisp:int lisp:object lisp:int) (lisp:int "db_get"))
(lisp:defentry %db-put (lisp:int lisp:object lisp:object lisp:int) (lisp:int "db_put"))
(lisp:defentry %db-delete (lisp:int lisp:object lisp:int) (lisp:int "db_delete"))
(lisp:defentry %db-cursor (lisp:int lisp:int) (lisp:int "db_cursor"))
(lisp:defentry %db-cursor-close (lisp:int) (lisp:int "db_cursor_close"))
(lisp:defentry %db-cursor-move (lisp:int lisp:int lisp:object) (lisp:int "db_cursor_move"))

(defun db-error (symbol)
  (error "Database error ~d in ~a: ~a" (db-error-number) symbol (db-error-string)))

(defun db-init (pathname)
  (case (%db-init pathname
                  #'(lambda (key value &rest other-specials)
                      (setf *db-key* key
                            *db-value* value
                            *db-aux* (apply #'list other-specials))))
    (0 (setf *base-pathname* pathname))
    (t (db-error 'db-init))))

#|
(defun db-transaction ()
  (let ((transaction (%db-transaction)))
    (if (= transaction 0)
        (db-error 'db-transaction)
        transaction)))

(defun db-commit (transaction)
  (case (%db-commit transaction)
    (0 t)
    (t (db-error 'db-commit))))

(defmacro with-transaction ((&key &allow-other-keys) &body body)
  `(let ((*transaction* (db-transaction)))
     (unwind-protect
       (progn ,@body)
       (db-commit *transaction*))))
|#

(defun db-open (pathname &key (key-type t))
  (let ((db (%db-open (concatenate 'string *base-pathname* "/" pathname) (case key-type (string 0) (integer 1) (t 2)))))
    (if (= db 0)
        (db-error 'db-open)
        db)))

(defun db-close (db)
  (if (= (%db-close db) 0)
      t
      (db-error 'db-close)))

(defun db-get (db key)
  (let ((errno (%db-get db key *transaction*)))
    (cond ((= errno 0) t)
          ((= errno DB_NOTFOUND) nil)
          (t (db-error 'db-get)))))

(defun db-put (db key value)
  (if (= (%db-put db key value *transaction*) 0)
      t
      (db-error 'db-put)))

(defun db-delete (db key)
  (let ((errno (%db-delete db key *transaction*)))
    (cond ((= errno 0) t)
          ((= errno DB_NOTFOUND) nil)
          (t (db-error 'db-delete)))))

(defun db-cursor (db)
  (let ((cursor (%db-cursor db *transaction*)))
    (if (= cursor 0)
        (db-error 'db-cursor)
        cursor)))

(defun db-cursor-close (cursor)
  (if (= (%db-cursor-close cursor) 0)
      t
      (db-error 'db-cursor-close)))

(defun db-cursor-move (cursor flags &optional key)
  (let ((errno (%db-cursor-move cursor flags key)))
    (cond ((= errno 0) t)
          ((= errno DB_NOTFOUND) nil)
          (t (db-error 'db-cursor-move)))))

(defmacro with-simple-database ((db pathname &key (key-type 'string)) &body body)
  `(let ((,db (db-open ,pathname :key-type ',key-type)))
     (unwind-protect
       (progn ,@body)
       (db-close ,db))))