;;; macro
(define-syntax lookup-shared-value
  (syntax-rules ()
    ((lookup-shared-value %s)
     (shared-binding-ref
      (lookup-imported-binding %s)))))

;;; weak lists
(define (cons-weak obj list)
  (cons (make-weak-pointer obj) list))

(define (filter-collected list)
  (filter (lambda (weak-pointer)
            (not (weak-pointer-ref weak-pointer)))
          list))

;;; fluids
(define $current-env (make-fluid #f))
(define $current-db (make-fluid #f))
(define $current-transaction-id (make-fluid #f))
(define $current-flags (make-fluid #f))

(define (current-env)
  (fluid $current-env))

(define (current-db)
  (fluid $current-db))

(define (current-transaction-id)
  (fluid $current-transaction-id))

(define (current-flags)
  (fluid $current-flags))

(define (with-database-env db-env thunk)
  (let-fluid $current-env db-env thunk))

(define (with-database db thunk)
  (let-fluid $current-db db thunk))

(define (with-database-flags flags thunk)
  (let-fluid $current-flags flags thunk))

(define (as-transaction db-env flags proc)
  (let-fluid        
     $current-transaction-id
     (begin-transaction db-env flags)
     (lambda ()
       (proc (lambda ()
	       (abort-transaction (current-transaction-id))))
       (commit-transaction (current-transaction-id)))))

(define (with-transaction transaction proc)
  (let-fluid
   $current-transaction-id
   transaction
   proc))

;; constants

(define (berkeley-db-version)
  (lookup-shared-value "scheme_DB_VERSION"))

(define (berkeley-db-version-string)
  (lookup-shared-value "scheme_DB_VERSION_VERBOSE"))

(define-finite-type flag :flag
  (id)
  flag-object?
  flag-elements
  flag-name
  flag-index
  (id flag-id)
  ((default 0)
   (rpc-client		(lookup-shared-value "scheme_DB_RPCCLIENT"))
   (join-env		(lookup-shared-value "scheme_DB_JOINENV"))
   (init-lock		(lookup-shared-value "scheme_DB_INIT_LOCK"))
   (init-log		(lookup-shared-value "scheme_DB_INIT_LOG"))
   (init-mpool		(lookup-shared-value "scheme_DB_INIT_MPOOL"))
   (init-replication	(lookup-shared-value "scheme_DB_INIT_REP"))
   (init-transactions	(lookup-shared-value "scheme_DB_INIT_TXN"))
   (run-recover		(lookup-shared-value "scheme_DB_RECOVER"))
   (recover-fatal	(lookup-shared-value "scheme_DB_RECOVER_FATAL"))
   (use-environ		(lookup-shared-value "scheme_DB_USE_ENVIRON"))
   (use-environ-root	(lookup-shared-value "scheme_DB_USE_ENVIRON_ROOT"))
   (create		(lookup-shared-value "scheme_DB_CREATE"))
   (lockdown		(lookup-shared-value "scheme_DB_LOCKDOWN"))
   (private		(lookup-shared-value "scheme_DB_PRIVATE"))
   (system-mem		(lookup-shared-value "scheme_DB_SYSTEM_MEM"))
   (thread		(lookup-shared-value "scheme_DB_THREAD"))
   (force		(lookup-shared-value "scheme_DB_FORCE"))
   (xa-create		(lookup-shared-value "scheme_DB_XA_CREATE"))
   (auto-commit		(lookup-shared-value "scheme_DB_AUTO_COMMIT"))
   (dirty-read		(lookup-shared-value "scheme_DB_DIRTY_READ"))
   (excl		(lookup-shared-value "scheme_DB_EXCL"))
   (nommap		(lookup-shared-value "scheme_DB_NOMMAP"))
   (rdonly		(lookup-shared-value "scheme_DB_RDONLY"))
   (thread		(lookup-shared-value "scheme_DB_SYSTEM_MEM"))
   (truncate		(lookup-shared-value "scheme_DB_TRUNCATE"))
   (nosync		(lookup-shared-value "scheme_DB_NOSYNC"))
   (consume		(lookup-shared-value "scheme_DB_CONSUME"))
   (consume-wait	(lookup-shared-value "scheme_DB_CONSUME_WAIT"))
   (get-both		(lookup-shared-value "scheme_DB_GET_BOTH"))
   (multiple		(lookup-shared-value "scheme_DB_MULTIPLE"))
   (rmw			(lookup-shared-value "scheme_DB_RMW"))
   (set-recno		(lookup-shared-value "scheme_DB_SET_RECNO"))
   (append		(lookup-shared-value "scheme_DB_APPEND"))
   (nodupdata		(lookup-shared-value "scheme_DB_NODUPDATA"))
   (nooverwrite		(lookup-shared-value "scheme_DB_NOOVERWRITE"))
   (current		(lookup-shared-value "scheme_DB_CURRENT"))
   (first		(lookup-shared-value "scheme_DB_FIRST"))
   (get-both		(lookup-shared-value "scheme_DB_GET_BOTH"))
   (writecursor		(lookup-shared-value "scheme_DB_WRITECURSOR"))
   (get-both-range	(lookup-shared-value "scheme_DB_GET_BOTH_RANGE"))
   (get-recno		(lookup-shared-value "scheme_DB_GET_RECNO"))
   (join-item		(lookup-shared-value "scheme_DB_JOIN_ITEM"))
   (last		(lookup-shared-value "scheme_DB_LAST"))
   (next		(lookup-shared-value "scheme_DB_NEXT"))
   (next-dup		(lookup-shared-value "scheme_DB_NEXT_DUP"))
   (next-nodup		(lookup-shared-value "scheme_DB_NEXT_NODUP"))
   (prev		(lookup-shared-value "scheme_DB_PREV"))
   (prev-nodup		(lookup-shared-value "scheme_DB_PREV_NODUP"))
   (set			(lookup-shared-value "scheme_DB_SET"))
   (set-range		(lookup-shared-value "scheme_DB_SET_RANGE"))
   (multiple-key	(lookup-shared-value "scheme_DB_MULTIPLE_KEY"))
   (txn-nosync		(lookup-shared-value "scheme_DB_TXN_NOSYNC"))
   (txn-nowait		(lookup-shared-value "scheme_DB_TXN_NOWAIT"))
   (txn-sync		(lookup-shared-value "scheme_DB_TXN_SYNC"))
   (lock-nowait		(lookup-shared-value "scheme_DB_LOCK_NOWAIT"))
   (encrypt-aes		(lookup-shared-value "scheme_DB_ENCRYPT_AES"))
   (cdb-alldb		(lookup-shared-value "scheme_DB_CDB_ALLDB"))
   (direct-db		(lookup-shared-value "scheme_DB_DIRECT_DB"))
   (direct-log		(lookup-shared-value "scheme_DB_DIRECT_LOG"))
   (log-autoremove	(lookup-shared-value "scheme_DB_LOG_AUTOREMOVE"))
   (no-locking		(lookup-shared-value "scheme_DB_NOLOCKING"))
   (no-panic		(lookup-shared-value "scheme_DB_NOPANIC"))
   (overwrite		(lookup-shared-value "scheme_DB_OVERWRITE"))
   (panic-environment	(lookup-shared-value "scheme_DB_PANIC_ENVIRONMENT"))
   (region-init		(lookup-shared-value "scheme_DB_REGION_INIT"))
   (time-not-granted	(lookup-shared-value "scheme_DB_TIME_NOTGRANTED"))
   (transaction-not-durable 
			(lookup-shared-value "scheme_DB_TXN_NOT_DURABLE"))
   (transaction-write-no-sync 
			(lookup-shared-value "scheme_DB_TXN_NOSYNC"))
   (force		(lookup-shared-value "scheme_DB_FORCE"))
   (checksum		(lookup-shared-value "scheme_DB_CHKSUM"))
   (encrypt		(lookup-shared-value "scheme_DB_ENCRYPT"))
   (duplicate-keys	(lookup-shared-value "scheme_DB_DUP"))
   (duplicate-keys-sort	(lookup-shared-value "scheme_DB_DUPSORT"))
   (record-numbers	(lookup-shared-value "scheme_DB_RECNUM"))
   (no-reverse-splits	(lookup-shared-value "scheme_DB_REVSPLITOFF"))
   (renumber		(lookup-shared-value "scheme_DB_RENUMBER"))
   (snapshot		(lookup-shared-value "scheme_DB_SNAPSHOT"))
   (prev-no-duplicates	(lookup-shared-value "scheme_DB_PREV_NODUP"))
   (after		(lookup-shared-value "scheme_DB_AFTER"))
   (before		(lookup-shared-value "scheme_DB_BEFORE"))
   (key-first		(lookup-shared-value "scheme_DB_KEYFIRST"))
   (key-last		(lookup-shared-value "scheme_DB_KEYLAST"))
   (init-cdb		(lookup-shared-value "scheme_DB_INIT_CDB"))
   (dbt-user-memory	(lookup-shared-value "scheme_DB_DBT_USERMEM"))))

(define-finite-type lock-mode :lock-mode
  (id)
  lock-mode-object?
  lock-mode-elements
  lock-mode-name
  lock-mode-index
  (id lock-mode-value)
  ((read-shared		(lookup-shared-value "scheme_DB_LOCK_READ"))
   (write-exclusive	(lookup-shared-value "scheme_DB_LOCK_WRITE"))
   (intention-to-write	(lookup-shared-value "scheme_DB_LOCK_IWRITE"))
   (intention-to-read	(lookup-shared-value "scheme_DB_LOCK_IREAD"))
   (intention-to-read-and-write
			(lookup-shared-value "scheme_DB_LOCK_IWR"))))

(define-finite-type return-code :return-code
  (id)
  return-code-object?
  return-code-elements
  return-code-name
  return-code-index
  (id return-code-value)
  ((do-not-index	(lookup-shared-value "scheme_DB_DONOTINDEX"))
   (file-open		(lookup-shared-value "scheme_DB_FILEOPEN"))
   (key-empty		(lookup-shared-value "scheme_DB_KEYEMPTY"))
   (key-exists		(lookup-shared-value "scheme_DB_KEYEXIST"))
   (lock-deadlock	(lookup-shared-value "scheme_DB_LOCK_DEADLOCK"))
   (lock-not-granted	(lookup-shared-value "scheme_DB_LOCK_NOTGRANTED"))
   (no-server		(lookup-shared-value "scheme_DB_NOSERVER"))
   (no-server-home	(lookup-shared-value "scheme_DB_NOSERVER_HOME"))
   (no-server-id	(lookup-shared-value "scheme_DB_NOSERVER_ID"))
   (not-found		(lookup-shared-value "scheme_DB_NOTFOUND"))
   (old-version		(lookup-shared-value "scheme_DB_OLD_VERSION"))
   (page-not-found	(lookup-shared-value "scheme_DB_PAGE_NOTFOUND"))
   (rep-dup-masters	(lookup-shared-value "scheme_DB_REP_DUPMASTER"))
   (rep-handle-dead	(lookup-shared-value "scheme_DB_REP_HANDLE_DEAD"))
   (rep-hold-election	(lookup-shared-value "scheme_DB_REP_HOLDELECTION"))
   (rep-is-permanent	(lookup-shared-value "scheme_DB_REP_ISPERM"))
   (rep-is-new-master	(lookup-shared-value "scheme_DB_REP_NEWMASTER"))
   (rep-is-new-site	(lookup-shared-value "scheme_DB_REP_NEWSITE"))
   (rep-is-not-perm	(lookup-shared-value "scheme_DB_REP_NOTPERM"))
   (rep-is-outdated	(lookup-shared-value "scheme_DB_REP_OUTDATED"))
   (rep-unavailable	(lookup-shared-value "scheme_DB_REP_UNAVAIL"))
   (run-recovery	(lookup-shared-value "scheme_DB_RUNRECOVERY"))
   (secondary-bad	(lookup-shared-value "scheme_DB_SECONDARY_BAD"))
   (verify-bad		(lookup-shared-value "scheme_DB_VERIFY_BAD"))))

(define (flags->value flags)
  (fold
   (lambda (f flag)
     (bitwise-ior (flag-id f) flag))
   (flag-id (flag default))
   (if (list? flags) flags (list flags))))

(define-finite-type database-type :database-type
  (id)
  database-type-object?
  database-type-elements
  database-type-name
  database-type-index
  (id database-type-id)
  ((binary-tree		(lookup-shared-value "scheme_DB_BTREE"))
   (hash		(lookup-shared-value "scheme_DB_HASH"))
   (queue		(lookup-shared-value "scheme_DB_QUEUE"))
   (recno		(lookup-shared-value "scheme_DB_RECNO"))
   (unknown		(lookup-shared-value "scheme_DB_UNKNOWN"))))

;;; define error conditions
;;; with subconditions
(define-condition-type &bdb-error &condition
  bdb-error?
  (code bdb-error-code))

;;; without subconditions

;; DB_LOCK_DEADLOCK
(define-condition-type &bdb-lock-deadlock &bdb-error
  bdb-lock-deadlock?)

;;DB_LOCK_NOTGRANTED
(define-condition-type &bdb-lock-not-granted &bdb-error
  bdb-lock-not-granted?)

;; DB_OLD_VERSION
(define-condition-type &bdb-old-db-version &bdb-error
  bdb-old-db-version?)

;; DB_REP_HANDLE_DEAD
(define-condition-type &bdb-db-handle-dead &bdb-error   
 bdb-db-handle-dead?)

;; DB_SECONDARY_BAD
(define-condition-type &bdb-secondary-index-bad &bdb-error
  bdb-secondary-index-bad?)

(define-condition-type &bdb-invalid-flag &bdb-error
  bdb-invalid-flag?)

(define raise-bdb-condition
  (let ((alist
	 (list 
	  (cons (return-code-value
		 (return-code lock-deadlock))
		&bdb-lock-deadlock)
	  (cons (return-code-value
		 (return-code lock-not-granted))
		&bdb-lock-not-granted)
	  (cons (return-code-value
		 (return-code old-version))
		&bdb-old-db-version)
	  (cons (return-code-value
		 (return-code rep-handle-dead))
		&bdb-db-handle-dead)
	  (cons (return-code-value
		 (return-code secondary-bad))
		&bdb-secondary-index-bad))))
    (lambda (return-object)
      (cond 
       ((assoc return-object alist)
        => (lambda (p)
             (let ((the-condition (cadr p)))
	       (raise (condition (the-condition))))))
       (else 
        (raise 
         (condition (&bdb-error 
                     (code return-object)))))))))

;;; define bdb records
;;; DB handle : DB
(define-record-type database :database
  (really-make-database c-pointer closed? weak-list)
  database?
  (c-pointer database-c-pointer)
  (closed? database-closed? set-database-closed?!)
  (weak-list database-weak-list set-database-weak-list!))

(define (database-weak-list-add! db thing)
  (set-database-weak-list!
   db (cons-weak thing (database-weak-list db))))

(define (database-weak-list-filter! db)
  (set-database-weak-list!
   db (filter-collected (database-weak-list db))))

(import-lambda-definition bdb-close-int 
  (db-handle flags) 
  "scsh_bdb_close")

(define (database-finalizer-free db)
  (if (not (database-closed? db))
      (bdb-env-close-int db (flags->value (flag default)))))

(define (database-finalizer db)
  (database-weak-list-filter! db)
  (if (null? (database-weak-list db))
      (add-finalizer! db database-finalizer-free)
      (add-finalizer! db database-finalizer)))

(define-exported-binding "bdb-db" :database)

(define-record-type database-lock :database-lock
  (make-database-lock c-pointer)
  database-lock?
  (c-pointer database-lock-c-pointer))

(define-exported-binding "bdb-lock" :database-lock)

;;; DB environement handle : DB_ENV
(define-record-type database-env :database-env
  (make-database-env c-pointer weak-list)
  database-env?
  (c-pointer database-env-c-pointer)
  (weak-list database-env-weak-list set-database-env-weak-list!))

(define-exported-binding "bdb-env" :database-env)

(define (database-env-weak-list-add! db-env thing)
  (set-database-env-weak-list!
   db-env (cons-weak thing (database-env-weak-list db-env))))

(define (database-env-weak-list-filter! db-env)
  (set-database-env-weak-list!
   db-env (filter-collected (database-env-weak-list db-env))))

(define (database-env-finalizer-free db-env)
  (database-env-close db-env))

(define (database-env-finalizer db-env)
  (database-env-weak-list-filter! db-env)
  (if (null? (database-env-weak-list db-env))
      (add-finalizer! db-env database-env-finalizer-free)
      (add-finalizer! db-env database-env-finalizer)))

;;; DB memory poolfile : DB_MPOOLFILE
(define-record-type mpoolfile :mpoolfile
  (make-mpoolfile c-pointer)
  mpoolfile?
  (c-pointer mpoolfile-c-pointer))

(define-exported-binding "bdb-mpoolfile" :mpoolfile)

;;; DB transaction : DB_TXN
(define-record-type transaction :transaction
  (make-transaction c-pointer env)
  transaction?
  (c-pointer transaction-c-pointer)
  (env transaction-env set-transaction-env!))

(define-exported-binding "bdb-txn" :transaction)

;;; DB Cursor : DBC
(define-record-type cursor :cursor
  (really-make-cursor c-pointer)
  cursor?
  (c-pointer cursor-c-pointer))

(define-exported-binding "bdb-dbc" :cursor)

(import-lambda-definition bdb-cursor-close-int 
  (cursor)
  "scsh_bdb_close_cursor")

(define cursor-finalizer bdb-cursor-close-int)

(import-lambda-definition bdb-env-create-int 
  (flags)
  "scsh_bdb_env_create")

(define make-database-env 
  (lambda args
    (let-optionals args 
	((flags (or (current-flags) '())))
      (let ((handle (bdb-env-create-int (flags->value flags))))
	(if (integer? handle)
	    (raise-bdb-condition handle)
	    (begin
	      (add-finalizer! handle database-env-close)
	      handle))))))

(import-lambda-definition bdb-db-remove-int
  (env-handle txn-id file database flags)
  "scsh_bdb_db_remove")
    
(define (remove-database database-env file-name database-name . args)
  (let-optionals args
      ((txn-id (or (current-transaction-id) #f))
       (flags (or (current-flags) '())))
    (cond
     ((bdb-db-remove-int database-env txn-id file-name database-name
			 (flags->value flags))
      => raise-bdb-condition))))

(define (remove-database/fork . args)
  (wait (fork
	 (lambda ()
	   (apply remove-database args))))
  (values))

(import-lambda-definition bdb-db-rename-int
  (env-handle txn-id file database new-name flags)
  "scsh_bdb_dbrename")

;; untested
(define (rename-database database-env file-name database-name new-name . args)
  (let-optionals args
      ((txn-id (or (current-transaction-id) #f))
       (flags (or (current-flags) '())))
    (cond
     ((bdb-db-rename-int database-env txn-id file-name database-name
			 new-name (flags->value flags))
      => raise-bdb-condition))))

(define (rename-database/fork args)
  (wait (fork
	 (lambda ()
	   (apply rename-database args))))
  (values))

(import-lambda-definition bdb-env-open-int 
  (env-handle db-home flags mode)
  "scsh_bdb_env_open")

;; untested
(define (database-env-open db-env home-dir . args)
  (let-optionals args
      ((flags (or (current-flags) '()))
       (mode 0))
    (cond
     ((bdb-env-open-int db-env home-dir (flags->value flags) mode)
      => raise-bdb-condition))))

(import-lambda-definition bdb-env-set-data-dir-int
  (env-handle dir)
  "scsh_bdb_env_set_data_dir")

(define (set-database-env-data-dir! db-env dir)
  (cond 
   ((bdb-env-set-data-dir-int db-env dir)
    => raise-bdb-condition)))

(import-lambda-definition bdb-env-get-data-dirs
  (env-handle)
  "scsh_bdb_env_get_data_dirs")

(define (database-env-data-dirs db-env)
  (let ((result (bdb-env-get-data-dirs db-env)))
    (if (integer? result)
	(raise-bdb-condition result)
	result)))

(import-lambda-definition bdb-env-set-encrypt-int
  (env-handle password flags)
  "scsh_bdb_env_set_encrypt")

(define (set-database-env-encrypt! database-env password . args)
  (let-optionals args
      ((flags (or (current-flags) '())))
    (cond
     ((bdb-env-set-encrypt-int database-env password
			       (flags->value flags))
      => raise-bdb-condition))))

(import-lambda-definition bdb-env-get-encrypt-flags-int
  (env-handle)
  "scsh_bdb_env_get_encrypt_flags")

(define (database-env-encrypt-flags database-env)
  (call-with-values
   (lambda ()
     (apply values (bdb-env-get-encrypt-flags-int database-env)))
   (lambda (error-code flags)
     (if (zero? error-code)
	 flags
	 (raise-bdb-condition error-code)))))

(import-lambda-definition bdb-env-set-timeout-int
  (env-handle timeout lock?)
  "scsh_bdb_env_set_timeout")

(define (set-database-env-lock-timeout! db-env timeout)
  (cond 
   ((bdb-env-set-timeout-int db-env timeout #t)
    => raise-bdb-condition)))

(define (set-database-env-transaction-timeout! db-env timeout)
  (cond
   ((bdb-env-set-timeout-int db-env timeout #f)
    => raise-bdb-condition)))

(import-lambda-definition bdb-env-get-timeout-int
  (env-handle lockp)
  "scsh_bdb_env_get_timeout")

(define (database-env-lock-timeout db-env)
  (call-with-values
   (lambda ()
     (apply values (bdb-env-get-timeout-int db-env #t)))
   (lambda (error-code timeout)
     (if (zero? error-code)
	 timeout
	 (raise-bdb-condition error-code)))))

(define (database-env-transaction-timeout db-env)
  (call-with-values
   (lambda ()
     (apply values (bdb-env-get-timeout-int db-env #f)))
   (lambda (error-code timeout)
     (if (zero? error-code)
	 timeout
	 (raise-bdb-condition error-code)))))

(import-lambda-definition bdb-env-set-tmp-dir-int
  (env-handle dir)
  "scsh_bdb_env_set_tmp_dir")

(define (set-database-env-tmp-dir! db-env dir)
  (cond
   ((bdb-env-set-tmp-dir-int db-env dir)
    => raise-bdb-condition)))

(import-lambda-definition bdb-env-get-tmp-dir-int
  (env-handle)
  "scsh_bdb_env_get_tmp_dir")

(define (database-env-tmp-dir db-env)
  (call-with-values
   (lambda ()
     (apply values (bdb-env-get-tmp-dir-int db-env)))
   (lambda (error-code tmp-dir)
     (if (zero? error-code)
	 tmp-dir
	 (raise-bdb-condition error-code)))))

(import-lambda-definition bdb-env-set-tx-max
  (env-handle max)
  "scsh_bdb_env_set_tx_max")

(define (set-database-env-max-transactions! db-env max)
  (cond ((bdb-env-set-tx-max db-env max)
	 => raise-bdb-condition)))

(import-lambda-definition bdb-env-get-tx-max
  (env-handle)
  "scsh_bdb_env_get_tx_max")

(define (database-env-max-transactions db-env)
  (call-with-values
   (lambda ()
     (apply values (bdb-env-get-tx-max db-env)))
   (lambda (error-code max)
     (if (zero? error-code)
	 max
	 (raise-bdb-condition error-code)))))

(import-lambda-definition bdb-env-set-tx-timestamp
  (env-handle timestamp)
  "scsh_bdb_env_set_tx_timestamp")

(define (set-database-env-transaction-timestamp! db-env timestamp)
  (cond ((bdb-env-set-tx-timestamp db-env timestamp)
	 => raise-bdb-condition)))

(import-lambda-definition bdb-env-get-tx-timestamp
  (env-handle)
  "scsh_bdb_env_get_tx_timestamp")

(define (database-env-transaction-timestamp db-env)
  (call-with-values
   (lambda ()
     (apply values (bdb-env-get-tx-timestamp db-env)))
   (lambda (error-code timestamp)
     (if (zero? error-code)
	 timestamp
	 (raise-bdb-condition error-code)))))

(import-lambda-definition bdb-env-set-flags
  (env-handle flags clear?)
  "scsh_bdb_env_set_flags")

(define (modify-database-env-flags! db-env flags clear?)
  (cond 
   ((bdb-env-set-flags db-env (flags->value flags) clear?)
    => raise-bdb-condition)))

(define (set-database-env-flags! db-env flags)
  (modify-database-env-flags! db-env flags #f))

(define (clear-database-env-flags! db-env flags)
  (modify-database-env-flags! db-env flags #t))

(import-lambda-definition bdb-env-get-flags
  (env-handle)
  "scsh_bdb_env_get_flags")

(define (database-env-flags db-env)
  (call-with-values
   (lambda ()
     (apply values (bdb-env-get-flags db-env)))
   (lambda (error-code flags)
     (if (zero? error-code)
	 flags
	 (raise-bdb-condition error-code)))))

(import-lambda-definition bdb-env-set-verbose
  (env-handle which on-or-off?)
  "scsh_bdb_env_set_verbose")

(define (set-database-env-verbose! db-env which on-or-off?)
  (cond
   ((bdb-env-set-verbose db-env which on-or-off?)
    => raise-bdb-condition)))

(import-lambda-definition bdb-env-get-verbose
  (env-handle which)
  "scsh_bdb_env_get_verbose")

(define (database-env-verbose db-env which)
  (let ((res (bdb-env-get-verbose db-env which)))
    (if (number? res)
	(raise-bdb-condition res)
	res)))

(import-lambda-definition bdb-env-close-int 
  (env-handle)
  "scsh_bdb_env_close")

(define (database-env-close db-env)
  (if (null? (database-env-weak-list db-env))
      (cond 
       ((bdb-env-close-int db-env)
	=> raise-bdb-condition)
       (else
	(add-finalizer! db-env (lambda (x) x))))))

(import-lambda-definition bdb-env-lock-id
  (env-handle)
  "scsh_bdb_env_lock_id")

(define (database-env-fresh-locker-id db-env)
  (call-with-values
   (lambda ()
     (apply values (bdb-env-lock-id db-env)))
   (lambda (error-code locker-id)
     (if (zero? error-code)
	 locker-id
	 (raise-bdb-condition error-code)))))

(import-lambda-definition bdb-env-locker-id-free
  (env-handler locker-id)
  "scsh_bdb_env_lock_id_free")

(define (database-env-free-locker-id db-env locker-id)
  (cond 
   ((bdb-env-locker-id-free db-env locker-id)
    => raise-bdb-condition)))

(import-lambda-definition bdb-env-lock-get
  (env-handle locker-id flags object mode)
  "scsh_bdb_env_lock_get")

(define (database-env-get-lock db-env locker-id object lock-mode . args)
  (let-optionals args
      ((flags (or (current-flags) '())))
    (call-with-values
     (lambda ()
       (receive (rport wport) 
	   (pipe)
	 (wait 
	  (fork
	   (lambda ()
	     (write (bdb-env-lock-get db-env locker-id (flags->value flags)
				      object (lock-mode-value lock-mode))
		    wport))))
	 (apply values (read rport))))
     (lambda (error-code lock-pointer)
       (cond
	((= error-code (return-code-value (return-code lock-deadlock)))
	 (return-code lock-deadlock))
	((= error-code (return-code-value (return-code lock-not-granted)))
	 (return-code lock-not-granted))
	((zero? error-code)
	 (make-database-lock lock-pointer))
	(else
	 (raise-bdb-condition error-code)))))))

(import-lambda-definition bdb-env-lock-put
  (env-handle lock)
  "scsh_bdb_env_lock_put")

(define (database-env-put-lock db-env lock)
  (cond ((bdb-env-lock-put db-env lock)
	 => raise-bdb-condition)))

(import-lambda-definition bdb-txn-checkpoint
  (env-handle kbyte min flags)
  "scsh_bdb_env_txn_checkpoint")

(define (set-database-env-transaction-checkpoint! db-env kbyte min . args)
  (let-optionals args
      ((flags (or (current-flags) '())))
    (cond 
     ((bdb-txn-checkpoint db-env kbyte min (flags->value flags))
      => raise-bdb-condition))))

(import-lambda-definition bdb-env-remove-int 
  (db-home flags)
  "scsh_bdb_env_remove")

;;; FIXME
; (define (bdb-env-remove env_handle db_home . args)
;   (let-optionals args
;       ((flags (bdb-flags DB_DEFAULT)))
;     (let* ((ret-object (bdb-env-remove-int env_handle db_home (bdb-flags-id flags))))
;       (if (integer? ret-object)
; 	  (raise-bdb-condition ret-object)
; 	  (begin
; 	    (values ret-object))))))

(import-lambda-definition bdb-create-int 
  (env-handle flags) 
  "scsh_bdb_create")

(define (make-database . args)
  (let-optionals args
      ((env (or (current-env) #f))
       (flags (or (current-flags) '())))
    (let ((handle 
	   (bdb-create-int env (flags->value flags))))
      (if (integer? handle)
	  (raise-bdb-condition handle)
	  (begin
	    (set-database-closed?! handle #f)
	    (add-finalizer! handle close-database)
	    handle)))))

(import-lambda-definition bdb-open-int 
  (db-handle db-file database txnid type flags mode)
  "scsh_bdb_open")

(define (open-database db-handle db-file . args)
  (let-optionals args
      ((type (database-type binary-tree))
       (flags (or (current-flags) '()))
       (mode 0)
       (database-name #f)
       (txn-id (or (current-transaction-id) #f)))
    (cond
     ((bdb-open-int db-handle db-file database-name txn-id
		    (database-type-id type)
		    (flags->value flags) mode)
      => raise-bdb-condition))))

(define (open-database/fork . args)
  (wait (fork
	 (lambda ()
	   (apply open-database args))))
  (values))

(define (close-database db-handle . args)
  (let-optionals args
      ((flags (or (current-flags) '())))
    (if (and (not (database-closed? db-handle))
	     (null? (database-weak-list db-handle)))
	(cond 
	 ((bdb-close-int db-handle (flags->value flags))
	  => raise-bdb-condition)
	 (else
	  (set-database-closed?! db-handle #t))))))

(import-lambda-definition bdb-put-int 
  (db-handle key data txn-id flags)
  "scsh_bdb_put")

(define (database-put db-handle key data . args)
  (let-optionals args
      ((txn-id (or (current-transaction-id) #f))
       (flags (or (current-flags) '())))
    (cond 
     ((bdb-put-int db-handle key data txn-id (flags->value flags))
      => raise-bdb-condition))))

(define (database-put/fork . args)
  (wait (fork
	 (lambda ()
	   (apply database-put args))))
  (values))

(import-lambda-definition bdb-get-int 
  (db-handle key txn-id flags)
  "scsh_bdb_get")

(define (database-get db-handle key . args)
  (let-optionals args
      ((txn-id (or (current-transaction-id) #f))
       (flags (or (current-flags) '())))
    (let ((result (bdb-get-int db-handle key txn-id (flags->value flags))))
      (if (integer? result)
	  (if (or (= result (return-code-value (return-code not-found)))
		  (= result (return-code-value (return-code key-empty))))
	      #f
	      (raise-bdb-condition result))
	  result))))

(define (database-get/fork . args)
  (receive (rport wport)
      (pipe)
    (wait (fork (lambda ()
		  (cond
		   ((apply database-get args)
		    => (lambda (byte-vector)
			 (write (byte-vector->list byte-vector) wport)))
		   (else (write #f wport))))))
    (let ((result (read rport)))
      (if (list? result)
	  (list->byte-vector result)
	  result))))

(import-lambda-definition bdb-del-int 
  (db-handle key txn-id flags)
  "scsh_bdb_del")

(define (database-delete-item db-handle key . args)
  (let-optionals args
      ((txn-id (or (current-transaction-id) #f))
       (flags (or (current-flags) '())))
    (cond 
     ((bdb-del-int db-handle key txn-id (flags->value flags))
      => raise-bdb-condition))))

(define (database-delete-item/fork . args)
  (wait (fork 
	 (lambda ()
	   (apply database-delete-item args))))
  (values))

(import-lambda-definition bdb-truncate-int 
  (db-home txn-id flags)
  "scsh_bdb_truncate")

(define (database-truncate db-handle . args)
  (let-optionals args
      ((txn-id (or (current-transaction-id) #f))
       (flags (or (current-flags) '())))
    (call-with-values
     (lambda ()
       (apply values 
	      (bdb-truncate-int db-handle txn-id (flags->value flags))))
     (lambda (error-code count)
       (if (zero? error-code)
	   count
	   raise-bdb-condition)))))

(define (database-truncate/fork . args)
  (wait (fork
	 (lambda ()
	   (apply database-truncate args))))
  (values))

(import-lambda-definition bdb-sync-int 
  (db-handle)
  "scsh_bdb_sync")

(define (database-sync database)
  (cond ((bdb-sync-int database)
	 => raise-bdb-condition)))

(import-lambda-definition bdb-set-encrypt
  (database password flags)
  "scsh_bdb_set_encrypt")

(define (set-database-encrypt! database password . args)
  (let-optionals args
      ((flags (or (current-flags) '())))
    (cond 
     ((bdb-set-encrypt database password (flags->value flags))
      => raise-bdb-condition))))

;; retest
(import-lambda-definition bdb-get-encrypt-flags
  (database)
  "scsh_bdb_get_encrypt_flags")

(define (database-encrypt-flags database)
  (call-with-values
   (lambda ()
     (apply values (bdb-get-encrypt-flags database)))
   (lambda (error-code flags)
     (if (zero? error-code)
	 flags
	 (raise-bdb-condition error-code)))))

(import-lambda-definition bdb-set-flags
  (database flags)
  "scsh_bdb_set_flags")

(define (set-database-flags! database flags)
  (cond 
   ((bdb-set-flags database (flags->value flags))
    => raise-bdb-condition)))

(import-lambda-definition bdb-get-flags
  (database)
  "scsh_bdb_get_flags")

(define (database-flags database)
  (call-with-values
   (lambda ()
     (apply values (bdb-get-flags database)))
   (lambda (error-code flags)
     (if (zero? error-code)
	 flags
	 (raise-bdb-condition error-code)))))

(import-lambda-definition bdb-set-debug-file
  (database filename-or-false)
  "scsh_bdb_set_debug_file")

(define (turn-database-debugging-on database file-name)
  (bdb-set-debug-file database file-name))

(define (turn-database-debugging-off database)
  (bdb-set-debug-file database #f))

(import-lambda-definition bdb-set-lorder
  (database big-endian?)
  "scsh_bdb_set_lorder")

(define (set-database-byte-order! database use-big-endian?)
  (cond ((bdb-set-lorder database use-big-endian?)
	 => raise-bdb-condition)))

(import-lambda-definition bdb-get-lorder
  (database)
  "scsh_bdb_get_lorder")

(define (database-big-endian? database)
  (call-with-values
   (lambda ()
     (apply values (bdb-get-lorder database)))
   (lambda (error-code big-endian?)
     (if (zero? error-code)
	 big-endian?
	 (raise-bdb-condition error-code)))))

(define (database-little-endian? database)
  (not (database-big-endian? database)))

(import-lambda-definition bdb-set-pagesize
  (database pagesize)
  "scsh_bdb_set_pagesize")

(define (set-database-page-size! database page-size)
  (cond 
   ((bdb-set-pagesize database page-size)
    => raise-bdb-condition)))

(import-lambda-definition bdb-get-pagesize
  (database)
  "scsh_bdb_get_pagesize")

(define (database-page-size database)
  (call-with-values
   (lambda ()
     (apply values (bdb-get-pagesize database)))
   (lambda (error-code page-size)
     (if (zero? error-code)
	 page-size
	 (raise-bdb-condition error-code)))))

(import-lambda-definition bdb-create-cursor-int 
  (db-handle txn-id flags)
  "scsh_bdb_create_cursor")

(define (make-cursor db-handle . args)
  (let-optionals args
      ((txn-id (or (current-transaction-id) #f))
       (flags (or (current-flags) '())))
    (let ((result 
	   (bdb-create-cursor-int db-handle txn-id (flags->value flags))))
      (if (integer? result)
	  (raise-bdb-condition result)
	  (begin
	    (if txn-id
		(database-env-weak-list-add! txn-id result))
	    (add-finalizer! result cursor-finalizer)
	    result)))))

(import-lambda-definition bdb-cursor-cget-int 
  (cursor key flags)
  "scsh_bdb_cursor_cget")

(define (cursor-get cursor key . args)
  (let-optionals args
      ((flags (or (current-flags) '())))
    (let ((result 
	   (bdb-cursor-cget-int cursor key (flags->value flags))))
      (if (integer? result)
	  (if (or (= result (return-code-value (return-code not-found)))
		  (= result (return-code-value (return-code key-empty))))
	      #f
	      (raise-bdb-condition result))
	  result))))

(define (cursor-get/fork . args)
  (receive (rport wport)
      (pipe)
    (wait (fork (lambda ()
		  (write (byte-vector->list (apply cursor-get args)) 
			 wport))))
    (list->byte-vector (read rport))))

(import-lambda-definition bdb-cursor-count
  (cursor)
  "scsh_bdb_cursor_count")

(define (cursor-count cursor)
  (call-with-values
   (lambda ()
     (apply values (bdb-cursor-count cursor)))
   (lambda (error-code count)
     (if (zero? error-code)
	 count
	 (raise-bdb-condition error-code)))))

(import-lambda-definition bdb-cursor-del
  (cursor)
  "scsh_bdb_cursor_del")

(define (cursor-delete-item cursor)
  (cond ((bdb-cursor-del cursor)
	 => raise-bdb-condition)))

(define (cursor-delete-item/fork cursor)
  (wait (fork 
	 (lambda ()
	   (cursor-delete-item cursor))))
  (values))

(import-lambda-definition bdb-cursor-put
  (cursor key data flags)
  "scsh_bdb_cursor_put")

(define (cursor-put cursor key data . args)
  (let-optionals args
      ((flags (flags->value (or (current-flags) '()))))
    (cond
     ((bdb-cursor-put cursor key data flags)
      => raise-bdb-condition))))

(define (cursor-put/fork args)
  (wait (fork 
	 (lambda ()
	   (apply cursor-put args))))
  (values))

(import-lambda-definition bdb-txn-begin-int 
  (env-handle parent flags)
  "scsh_bdb_txn_begin")

(define (begin-transaction db-env . args)
  (let-optionals args
      ((parent #f)
       (flags (or (current-flags) '())))
    (let ((result (bdb-txn-begin-int db-env parent (flags->value flags))))
      (if (integer? result)
	  (raise-bdb-condition result)
	  (begin
	    (set-transaction-env! result db-env)
	    (database-env-weak-list-add! db-env result)
	    result)))))

(import-lambda-definition bdb-txn-abort-int 
  (txn-id)
  "scsh_bdb_txn_abort")

(define (abort-transaction txn-id)
  (let ((result (bdb-txn-abort-int txn-id)))
    (if (integer? result)
	(raise-bdb-condition result)
	(values))))

(import-lambda-definition bdb-txn-commit-int 
  (txn-id flags)
  "scsh_bdb_txn_commit")

(define (commit-transaction txn-id . args)
  (let-optionals args
      ((flags (or (current-flags) '())))
    (let ((result (bdb-txn-commit-int txn-id (flags->value flags))))
      (if (integer? result)
	  (raise-bdb-condition result)
	  (values)))))

(define (string->byte-vector string)
  (let* ((length (string-length string))
	 (bv (make-byte-vector length 0)))
    (let lp ((index (- length 1)))
      (if (< index 0)
	  bv
	  (begin
	    (byte-vector-set! 
	     bv index (char->ascii (string-ref string index)))
	    (lp (- index 1)))))))

(define (byte-vector->string byte-vector)
  (let* ((length (byte-vector-length byte-vector))
	 (string (make-string length (ascii->char 0))))
    (let lp ((index (- length 1)))
      (if (< index 0)
	  string
	  (begin
	    (string-set! 
	     string index 
	     (ascii->char (byte-vector-ref byte-vector index)))
	    (lp (- index 1)))))))

(define (value->byte-vector thing)
  (let ((port (make-string-output-port)))
    (write thing port)
    (string->byte-vector 
     (string-output-port-output port))))

(define (byte-vector->value byte-vector)
  (let ((port (make-string-input-port
	       (byte-vector->string byte-vector))))
    (read port)))

(define (byte-vector->list bv)
  (let ((length (byte-vector-length bv)))
    (let lp ((index (- length 1)) (res '()))
      (if (< index 0)
	  res
	  (lp (- index 1) (cons (byte-vector-ref bv index) res))))))

(define (list->byte-vector lst)
  (let ((bv (make-byte-vector (length lst) 0)))
    (let lp ((index 0) (lst lst))
      (if (null? lst)
	  bv
	  (begin
	    (byte-vector-set! bv index (car lst))
	    (lp (+ index 1) (cdr lst)))))))