;; -*- mode: Scheme; -*-
;;
;; This file is part of BerkeleyDB for CHICKEN
;; Copyright (c) 2011 by Thomas Chust.  All rights reserved.
;;
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the Software), to deal in the Software without restriction,
;; including without limitation the rights to use, copy, modify,
;; merge, publish, distribute, sublicense, and/or sell copies of the
;; Software, and to permit persons to whom the Software is furnished
;; to do so, subject to the following conditions:
;; 
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;; 
;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.

(require-library
 numbers
 srfi-1 srfi-4 srfi-18 srfi-69 lolevel data-structures extras)

(module berkeley-db-serialization
  (serialize
   deserialize)
  (import
   scheme chicken numbers
   srfi-1 srfi-4 srfi-69 lolevel extras)

;; Serialization and deserialization of common data types

(define tag:serialized
  "\x00ser")

(define serialize
  (letrec ((write-integer
	    (lambda (n port)
	      (let loop ((n n))
		(let ((q (quotient n -128)) (r (remainder n -128)))
		  (when (negative? r)
		    (set!-values (q r) (values (+ q 1) (+ r 128))))
		  (let ((end? (zero? q)))
		    (write-byte (if end? (bitwise-ior 128 r) r) port)
		    (unless end? (loop q)))))))
	   (write-real
	    (lambda (n port)
	      (write-u8vector
	       (blob->u8vector/shared
		(f64vector->blob/shared
		 (f64vector n)))
	       port)))
	   (register!
	    (lambda (v table)
	      (hash-table-set! table v (hash-table-size table))))
	   (serialize
	    (lambda (v table port)
	      (cond
	       ((eq? v (void))
		(write-char #\v port))
	       ((null? v)
		(write-char #\; port))
	       ((boolean? v)
		(write-char (if v #\t #\f) port))
	       ((char? v)
		(write-char #\\ port)
		(write-char v port))
	       ((number? v)
		(cond
		 ((exact? v)
		  (cond
		   ((integer? v)
		    (write-char #\i port)
		    (write-integer v port))
		   ((real? v)
		    (write-char #\r port)
		    (write-integer (numerator v) port)
		    (write-integer (denominator v) port))
		   (else
		    (write-char #\c port)
		    (let ((r (real-part v))
			  (i (imag-part v)))
		      (write-integer (numerator r) port)
		      (write-integer (denominator r) port)
		      (write-integer (numerator i) port)
		      (write-integer (denominator i) port)))))
		 ((real? v)
		  (write-char #\R port)
		  (write-real v port))
		 (else
		  (write-char #\C port)
		  (write-real (real-part v) port)
		  (write-real (imag-part v) port))))
	       ((hash-table-ref/default table v #f)
		=> (lambda (id)
		     (write-char #\^ port)
		     (write-integer id port)))
	       ((symbol? v)
		(register! v table)
		(write-char #\s port)
		(write-integer (string-length (symbol->string v)) port)
		(display v port))
	       ((string? v)
		(register! v table)
		(write-char #\S port)
		(write-integer (string-length v) port)
		(display v port))
	       ((u8vector? v)
		(register! v table)
		(write-char #\b port)
		(write-integer (u8vector-length v) port)
		(write-u8vector v port))
	       ((blob? v)
		(register! v table)
		(write-char #\B port)
		(write-integer (blob-size v) port)
		(write-u8vector (blob->u8vector/shared v) port))
	       ((f64vector? v)
		(register! v table)
		(write-char #\e port)
		(write-integer (f64vector-length v) port)
		(write-u8vector
		 (blob->u8vector/shared (f64vector->blob/shared v)) port))
	       ((pair? v)
		(register! v table)
		(write-char #\. port)
		(serialize (car v) table port)
		(serialize (cdr v) table port))
	       ((vector? v)
		(register! v table)
		(let ((n (vector-length v)))
		  (write-char #\: port)
		  (write-integer n port)
		  (do ((i 0 (fx+ i 1))) ((fx>= i n))
		    (serialize (vector-ref v i) table port))))
	       ((hash-table? v)
		(register! v table)
		(let ((n (hash-table-size v)))
		  (write-char #\% port)
		  (write-integer n port)
		  (hash-table-walk
		   v
		   (lambda (key val)
		     (serialize key table port)
		     (serialize val table port)))))
	       ((record-instance? v)
		(register! v table)
		(write-char #\$ port)
		(let ((type (record-instance-type v)))
		  (write-integer (string-length (symbol->string type)) port)
		  (display type port))
		(let ((n (record-instance-length v)))
		  (write-integer n port)
		  (do ((i 0 (fx+ i 1))) ((fx>= i n))
		    (serialize (record-instance-slot v i) table port))))
	       (else
		(error 'serialize "value not serializable" v))))))
    (lambda (v #!optional (port (current-output-port)))
      (display tag:serialized port)
      (serialize v (make-hash-table eq? eq?-hash) port))))

(define deserialize
  (letrec ((read-integer
	    (lambda (port)
	      (let loop ((n 0) (b 1))
		(let ((r (read-byte port)))
		  (if (zero? (bitwise-and r 128))
		      (loop (+ n (* r b)) (* b -128))
		      (+ n (* (bitwise-and r 127) b)))))))
	   (read-real
	    (lambda (port)
	      (f64vector-ref
	       (blob->f64vector/shared
		(u8vector->blob/shared
		 (read-u8vector 8 port)))
	       0)))
	   (register!
	    (lambda (v table)
	      (hash-table-set! table (hash-table-size table) v)))
	   (deserialize
	    (lambda (table port)
	      (let ((tag (read-char port)))
		(case tag
		  ((#\v)
		   (void))
		  ((#\;)
		   '())
		  ((#\t)
		   #t)
		  ((#\f)
		   #f)
		  ((#\\)
		   (read-char port))
		  ((#\i)
		   (read-integer port))
		  ((#\r)
		   (let* ((n (read-integer port))
			  (d (read-integer port)))
		     (/ n d)))
		  ((#\R)
		   (read-real port))
		  ((#\c)
		   (let* ((rn (read-integer port))
			  (rd (read-integer port))
			  (in (read-integer port))
			  (id (read-integer port)))
		     (make-rectangular (/ rn rd) (/ in id))))
		  ((#\C)
		   (let ((r (read-real port))
			 (i (read-real port)))
		     (make-rectangular r i)))
		  ((#\^)
		   (let ((id (read-integer port)))
		     (hash-table-ref
		      table id
		      (lambda ()
			(error 'deserialize "illegal backreference" id)))))
		  ((#\s)
		   (let ((v (string->symbol
			     (read-string (read-integer port) port))))
		     (register! v table)
		     v))
		  ((#\S)
		   (let ((v (read-string (read-integer port) port)))
		     (register! v table)
		     v))
		  ((#\b)
		   (let ((v (read-u8vector (read-integer port) port)))
		     (register! v table)
		     v))
		  ((#\B)
		   (let ((v (u8vector->blob/shared
			     (read-u8vector (read-integer port) port))))
		     (register! v table)
		     v))
		  ((#\e)
		   (let ((v (blob->f64vector/shared
			     (u8vector->blob/shared
			      (read-u8vector (* (read-integer port) 8) port)))))
		     (register! v table)
		     v))
		  ((#\.)
		   (let ((v (cons (void) (void))))
		     (register! v table)
		     (set! (car v) (deserialize table port))
		     (set! (cdr v) (deserialize table port))
		     v))
		  ((#\:)
		   (let* ((n (read-integer port))
			  (v (make-vector n)))
		     (register! v table)
		     (do ((i 0 (fx+ i 1))) ((fx>= i n) v)
		       (vector-set! v i (deserialize table port)))))
		  ((#\%)
		   (let* ((n (read-integer port))
			  (v (make-hash-table #:size n)))
		     (register! v table)
		     (do ((i 0 (fx+ i 1))) ((fx>= i n) v)
		       (let* ((key (deserialize table port))
			      (val (deserialize table port)))
			 (hash-table-set! v key val)))))
		  ((#\$)
		   (let* ((type (string->symbol
				 (read-string (read-integer port) port)))
			  (n (read-integer port))
			  (v (apply make-record-instance type (make-list n))))
		     (register! v table)
		     (do ((i 0 (fx+ i 1))) ((fx>= i n) v)
		       (set! (record-instance-slot v i)
			 (deserialize table port)))))
		  ((#!eof)
		   tag)
		  (else
		   (error 'deserialize "value not deserializable" tag)))))))
    (lambda (#!optional (port (current-output-port)))
      (let ((tag (read-string (string-length tag:serialized) port)))
	(if (equal? tag tag:serialized)
	    (deserialize (make-hash-table = number-hash) port)
	    (string-append tag (read-string #f port)))))))

)

(module berkeley-db
  (database-environment?
   current-database-environment
   open-database-environment close-database-environment
   with-transaction
   copy-database rename-database delete-database
   database?
   open-database close-database
   database-type
   database-associate
   database-ref database-set! database-exists? database-delete!
   database-fold database-walk)
  (import
   scheme chicken foreign numbers
   srfi-1 srfi-4 srfi-18 srfi-69 lolevel data-structures ports
   berkeley-db-serialization)
  (foreign-declare
   "#include <db.h>"
   "#include <callback.h>")

(define-syntax define-foreign-tagged-type
  (syntax-rules ()
    ((define-foreign-tagged-type (id nonnull-id target-type)
       predicate tag)
     (begin
       (define tag
	 (gensym 'id))
       (define predicate
	 (cut tagged-pointer? <> tag))
       (define-foreign-type id (c-pointer target-type)
	 (lambda (v)
	   (if v (ensure predicate v) v))
	 (lambda (v)
	   (and v (tag-pointer v tag))))
       (define-foreign-type nonnull-id (nonnull-c-pointer target-type)
	 (lambda (v)
	   (ensure predicate v) v)
	 (lambda (v)
	   (tag-pointer v tag)))))))

(define-syntax define-foreign-enum-argconvert
  (syntax-rules ()
    ((define-foreign-enum-argconvert (id base-type)
       (key value) ...)
     (define (id v #!optional (seed 0))
       (case v
	 ((key) (fxior (foreign-value value base-type) seed)) ...
	 (else #f))))))

(define-syntax define-foreign-enum-retconvert
  (syntax-rules ()
    ((define-foreign-enum-retconvert (id base-type)
       (key value) ...)
     (define (id v)
       (select v
	 (((foreign-value value base-type)) 'key) ...
	 (else #f))))))

(define-syntax define-foreign-enum-type
  (syntax-rules ()
    ((define-foreign-enum-type (id base-type)
       argconvert retconvert
       (key value) ...)
     (begin
       (define-foreign-enum-argconvert (argconvert base-type)
	 (key value) ...)
       (define-foreign-enum-retconvert (retconvert base-type)
	 (key value) ...)
       (define-foreign-type id base-type
	 (lambda (v)
	   (or (argconvert v)
	       (abort
		(make-composite-condition
		 (make-property-condition
		  'exn
		  'location 'id
		  'message "unknown enumeration value"
		  'arguments (list v))
		 (make-property-condition
		  'type)))))
	 retconvert)))))

(define-syntax let-keys+flags
  (syntax-rules ()
    ((let-keys+flags loc args-expr
		     ((key key-var key-default) ...)
		     ((flag-argconvert flags-var) ...)
       expr ...)
     (let ((key-var key-default) ...
	   (flags-var 0) ...)
       (let next ((args args-expr) (pos 0))
	 (when (pair? args)
	   (let ((v (car args)))
	     (cond
	      ((flag-argconvert v flags-var)
	       => (lambda (v)
		    (set! flags-var v)
		    (next (cdr args) pos)))
	      ...
	      (else
	       (let-values (((k v next-args next-pos)
			     (if (keyword? v)
				 (values
				  v (if (pair? (cdr args))
					(cadr args)
					(error 'loc "illegal arguments" args))
				  (cddr args) pos)
				 (values
				  pos v
				  (cdr args) (fx+ pos 1)))))
		 (case k
		   ((key)
		    (set! key-var v)
		    (next next-args next-pos))
		   ...
		   (else
		    (error 'loc "illegal arguments" args)))))))))
       expr ...))))

(define (check-error loc s)
  (unless (zero? s)
    (abort
     (make-composite-condition
      (make-property-condition
       'exn
       'location loc
       'message ((foreign-lambda c-string "db_strerror" int) s))
      (make-property-condition
       'db
       'code s)))))

(define access-error?
  (letrec ((condition-code
	    (condition-property-accessor 'db 'code #f))
	   (not-found
	    (foreign-value "DB_NOTFOUND" int))
	   (access-error?
	    (lambda (exn)
	      (eqv? (condition-code exn) not-found))))
    access-error?))

(define (blob/string-size v)
  (cond
   ((blob? v) (blob-size v))
   ((string? v) (string-length v))))

;; Database environments

(define-foreign-tagged-type (database-environment
			     nonnull-database-environment
			     "DB_ENV")
  database-environment?
  tag:database-environment)

(define current-database-environment
  (make-parameter #f))

(define-foreign-enum-argconvert (database-environment-open-flags int)
  (#:locking "DB_INIT_LOCK")
  (#:logging "DB_INIT_LOG")
  (#:memory-pool "DB_INIT_MPOOL")
  (#:replication "DB_INIT_REP")
  (#:transactions "DB_INIT_TXN")
  (#:recover "DB_RECOVER")
  (#:recover/fatal "DB_RECOVER_FATAL")
  (#:use-environment "DB_USE_ENVIRON")
  (#:use-environment/root "DB_USE_ENVIRON_ROOT")
  (#:create "DB_CREATE")
  (#:lockdown "DB_LOCKDOWN")
  (#:failure-check "DB_FAILCHK")
  (#:private "DB_PRIVATE"))

(define-foreign-enum-argconvert (database-environment-open-extra-flags int)
  (#:auto-commit "DB_AUTO_COMMIT")
  (#:direct-i/o "DB_DIRECT_DB")
  (#:synchronous-i/o "DB_DSYNC_DB")
  (#:multiversion "DB_MULTIVERSION")
  (#:no-mmap "DB_NOMMAP")
  (#:overwrite "DB_OVERWRITE")
  (#:initialize-region "DB_REGION_INIT")
  (#:timeout->not-granted "DB_TIME_NOTGRANTED")
  (#:asynchronous "DB_TXN_NOSYNC")
  (#:no-wait "DB_TXN_NOWAIT")
  (#:snapshot "DB_TXN_SNAPSHOT")
  (#:asynchronous-write "DB_TXN_WRITE_NOSYNC"))

(define-foreign-enum-argconvert (database-encryption-flags int)
  (#:encrypt/aes "DB_ENCRYPT_AES"))

(define (open-database-environment home . args)
  (let-keys+flags open-database-environment args
		  ((#:mode mode 0)
		   (#:password password #f))
		  ((database-environment-open-flags flags)
		   (database-environment-open-extra-flags extra-flags)
		   (database-encryption-flags encryption-flags))
    (let-location ((env database-environment #f))
      (check-error
       'open-database-environment
       ((foreign-lambda
	 int "db_env_create"
	 (nonnull-c-pointer database-environment) int)
	(location env) 0))
      (condition-case
       (begin
	 (check-error
	  'open-database-environment
	  ((foreign-lambda*
	    int ((nonnull-database-environment env))
	    "C_return(env->set_alloc(env, &malloc, &realloc, &free));")
	   env))
	 (check-error
	  'open-database-environment
	  ((foreign-lambda*
	    int ((nonnull-database-environment env) (int flags))
	    "C_return(env->set_flags(env, flags, 1));")
	   env extra-flags))
	 (unless (zero? encryption-flags)
	   (check-error
	    'open-database-environment
	    ((foreign-lambda*
	      int ((nonnull-database-environment env)
		   (nonnull-c-string password) (int flags))
	      "C_return(env->set_encrypt(env, password, flags));")
	     env password encryption-flags)))
	 (check-error
	  'open-database-environment
	  ((foreign-lambda*
	    int ((nonnull-database-environment env) (nonnull-c-string home)
		 (int flags) (int mode))
	    "C_return(env->open(env, home, flags, mode));")
	   env home flags mode)))
       (exn (exn db)
	(close-database-environment env)
	(abort exn)))
      (current-database-environment env))))

(cond-expand
 (enable-v5
  (define-foreign-enum-argconvert (database-environment-close-flags int)
    (#:synchronous "DB_FORCESYNC")))
 (else
  (define-foreign-enum-argconvert (database-environment-close-flags int))))

(define (close-database-environment . args)
  (let-keys+flags close-database-environment args
		  ((0 env (current-database-environment)))
		  ((database-environment-close-flags flags))
    (when (equal? (current-database-environment) env)
      (current-database-environment #f))
    (check-error
     'close-database-environment
     ((foreign-lambda*
       int ((nonnull-database-environment env) (int flags))
       "C_return(env->close(env, flags));")
      env flags))))

(define-foreign-tagged-type (transaction nonnull-transaction "DB_TXN")
  transaction?
  tag:transaction)

(define current-transaction
  (make-parameter #f))

(cond-expand
 (enable-v5
  (define-foreign-enum-argconvert (transaction-flags int)
    (#:read-committed "DB_READ_COMMITTED")
    (#:read-uncommitted "DB_READ_UNCOMMITTED")
    (#:bulk "DB_TXN_BULK")
    (#:asynchronous "DB_TXN_NOSYNC")
    (#:no-wait "DB_TXN_NOWAIT")
    (#:snapshot "DB_TXN_SNAPSHOT")
    (#:synchronous "DB_TXN_SYNC")
    (#:wait "DB_TXN_WAIT")
    (#:asynchronous-write "DB_TXN_WRITE_NOSYNC")))
 (else
  (define-foreign-enum-argconvert (transaction-flags int)
    (#:read-committed "DB_READ_COMMITTED")
    (#:read-uncommitted "DB_READ_UNCOMMITTED")
    (#:asynchronous "DB_TXN_NOSYNC")
    (#:no-wait "DB_TXN_NOWAIT")
    (#:snapshot "DB_TXN_SNAPSHOT")
    (#:synchronous "DB_TXN_SYNC")
    (#:wait "DB_TXN_WAIT")
    (#:asynchronous-write "DB_TXN_WRITE_NOSYNC"))))

(define (with-transaction thunk . args)
  (let-keys+flags with-transaction args
		  ()
		  ((transaction-flags flags))
    (let-location ((txn transaction #f))
      (let ((success? #f))
	(dynamic-wind
	  (lambda ()
	    (cond
	     (txn
	      => (cut error 'with-transaction "cannot re-enter transaction" <>))))
	  (lambda ()
	    (check-error
	     'with-transaction
	     ((foreign-lambda*
	       int ((nonnull-database-environment env) (transaction parent)
		    ((nonnull-c-pointer transaction) txn) (int flags))
	       "C_return(env->txn_begin(env, parent, txn, flags));")
	      (current-database-environment) (current-transaction)
	      (location txn) flags))
	    (parameterize ((current-transaction txn))
	      (receive results (thunk)
		(set! success? #t)
		(apply values results))))
	  (lambda ()
	    (cond
	     (txn
	      => (lambda (txn)
		   (check-error
		    'with-transaction
		    (if success?
			((foreign-lambda*
			  int ((nonnull-transaction txn) (int flags))
			  "C_return(txn->commit(txn, flags));")
			 txn 0)
			((foreign-lambda*
			  int ((nonnull-transaction txn))
			  "C_return(txn->abort(txn));")
			 txn))))))))))))

;; Databases

(define-foreign-enum-argconvert (database-file-operation-flags int)
  (#:auto-commit "DB_AUTO_COMMIT"))

(define (copy-database file target #!key password)
  (check-error
   'copy-database
   ((foreign-lambda
     int "db_copy"
     nonnull-database-environment nonnull-c-string nonnull-c-string c-string)
    (current-database-environment)
    file target password)))

(define (rename-database file target . args)
  (let-keys+flags rename-database args
		  ((0 database #f))
		  ((database-file-operation-flags flags))
    (check-error
     'rename-database
     ((foreign-lambda*
       int ((nonnull-database-environment env) (transaction txn)
	    (nonnull-c-string file) (c-string database)
	    (nonnull-c-string target) (int flags))
       "C_return(env->dbrename(env, txn, file, database, target, flags));")
      (current-database-environment) (current-transaction)
      file database target flags))))

(define (delete-database file . args)
  (let-keys+flags delete-database args
		  ((0 database #f))
		  ((database-file-operation-flags flags))
    (check-error
     'delete-database
     ((foreign-lambda*
       int ((nonnull-database-environment env) (transaction txn)
	    (nonnull-c-string file) (c-string database) (int flags))
       "C_return(env->dbremove(env, txn, file, database, flags));")
    (current-database-environment) (current-transaction)
    file database flags))))

(define-foreign-tagged-type (database nonnull-database "DB")
  database?
  tag:database)

(cond-expand
 (enable-v5
  (define-foreign-enum-type (database-type int)
    database-type->integer integer->database-type
    (b-tree "DB_BTREE")
    (hash-table "DB_HASH")
    (heap "DB_HEAP")
    (queue "DB_QUEUE")
    (records "DB_RECNO")
    (#f "DB_UNKNOWN")))
 (else
  (define-foreign-enum-type (database-type int)
    database-type->integer integer->database-type
    (b-tree "DB_BTREE")
    (hash-table "DB_HASH")
    (queue "DB_QUEUE")
    (records "DB_RECNO")
    (#f "DB_UNKNOWN"))))

(define-foreign-enum-argconvert (database-open-flags int)
  (#:auto-commit "DB_AUTO_COMMIT")
  (#:create "DB_CREATE")
  (#:exclusive "DB_EXCL")
  (#:multiversion "DB_MULTIVERSION")
  (#:no-mmap "DB_NOMMAP")
  (#:read-only "DB_RDONLY")
  (#:read-uncommitted "DB_READ_UNCOMMITTED")
  (#:free-threaded "DB_THREAD")
  (#:truncate "DB_TRUNCATE"))

(define-foreign-enum-argconvert (database-open-extra-flags int)
  (#:checksum "DB_CHKSUM")
  (#:encrypt "DB_ENCRYPT")
  (#:transactions-not-durable "DB_TXN_NOT_DURABLE")
  (#:duplicates "DB_DUP")
  (#:duplicates/sorted "DB_DUPSORT")
  (#:no-reverse-splitting "DB_REVSPLITOFF")
  (#:in-order "DB_INORDER")
  (#:renumber "DB_RENUMBER")
  (#:snapshot "DB_SNAPSHOT"))

(define (open-database file . args)
  (let-keys+flags open-database args
		  ((0 type #f)
		   (1 database #f)
		   (#:mode mode 0)
		   (#:byte-order byte-order #f)
		   (#:page-size page-size #f)
		   (#:heap-max-size heap-max-size #f)
		   (#:queue-extent-size queue-extent-size #f)
		   (#:record-size record-size #f)
		   (#:record-delimiter record-delimiter #f)
		   (#:record-padding record-padding #f)
		   (#:record-source record-source #f)
		   (#:password password #f))
		  ((database-open-flags flags)
		   (database-open-extra-flags extra-flags)
		   (database-encryption-flags encryption-flags))
    (let-location ((db database #f))
      (check-error
       'open-database
       ((foreign-lambda
	 int "db_create"
	 (nonnull-c-pointer database) database-environment int)
	(location db) (current-database-environment) 0))
      (condition-case
       (begin
	 (check-error
	  'open-database
	  ((foreign-lambda*
	    int ((nonnull-database db) (int flags))
	    "C_return(db->set_flags(db, flags));")
	   db extra-flags))
	 (when byte-order
	   (check-error
	    'open-database
	    ((foreign-lambda*
	      int ((nonnull-database db) (unsigned-long order))
	      "C_return(db->set_lorder(db, order));")
	     db byte-order)))
	 (when page-size
	   (check-error
	    'open-database
	    ((foreign-lambda*
	      int ((nonnull-database db) (unsigned-long size))
	      "C_return(db->set_pagesize(db, size));")
	     db page-size)))
	 (when heap-max-size
	   (cond-expand
	    (enable-v5
	     (check-error
	      'open-database
	      (call-with-values
		(cut quotient&remainder
		     heap-max-size 1000000000)
		(cut (foreign-lambda*
		      int ((nonnull-database db)
			   (unsigned-long size_q) (unsigned-long size_r)
			   (int flags))
		      "C_return(db->set_heapsize(db, size_q, size_r, flags));")
		     db <> <> 0))))
	    (else
	     (void))))
	 (when queue-extent-size
	   (check-error
	    'open-database
	    ((foreign-lambda*
	      int ((nonnull-database db) (unsigned-long size))
	      "C_return(db->set_q_extentsize(db, size));")
	     db queue-extent-size)))
	 (when record-size
	   (check-error
	    'open-database
	    ((foreign-lambda*
	      int ((nonnull-database db) (unsigned-long size))
	      "C_return(db->set_re_len(db, size));")
	     db record-size)))
	 (when record-delimiter
	   (check-error
	    'open-database
	    ((foreign-lambda*
	      int ((nonnull-database db) (char delimiter))
	      "C_return(db->set_re_delim(db, delimiter));")
	     db record-delimiter)))
	 (when record-padding
	   (check-error
	    'open-database
	    ((foreign-lambda*
	      int ((nonnull-database db) (char padding))
	      "C_return(db->set_re_pad(db, padding));")
	     db record-padding)))
	 (when record-source
	   (check-error
	    'open-database
	    ((foreign-lambda*
	      int ((nonnull-database db) (nonnull-c-string file))
	      "C_return(db->set_re_source(db, file));")
	     db record-source)))
	 (unless (zero? encryption-flags)
	   (check-error
	    'open-database
	    ((foreign-lambda*
	      int ((nonnull-database db)
		   (nonnull-c-string password) (int flags))
	      "C_return(db->set_encrypt(db, password, flags));")
	     db password encryption-flags)))
	 (check-error
	  'open-database
	  ((foreign-lambda*
	    int ((nonnull-database db) (transaction txn)
		 (nonnull-c-string file) (c-string database)
		 (database-type type) (int flags) (int mode))
	    "C_return(db->open(db, txn, file, database, type, flags, mode));")
	   db (current-transaction) file database type flags mode)))
     (exn (exn db)
      (close-database db)
      (abort exn)))
    db)))

(define (database-type db)
  (let-location ((type database-type #f))
    (check-error
     'database-type
     ((foreign-lambda*
       int ((nonnull-database db) ((nonnull-c-pointer "DBTYPE") type))
       "C_return(db->get_type(db, type));")
      db (location type)))
    type))

(define-foreign-enum-argconvert (database-close-flags int)
  (#:asynchronous "DB_NOSYNC"))

(define (close-database db . args)
  (let-keys+flags close-database args
		  ()
		  ((database-close-flags flags))
    (check-error
     'close-database
     ((foreign-lambda*
       int ((nonnull-database db) (int flags))
       "C_return(db->close(db, flags));")
      db flags))))

(define-foreign-enum-argconvert (secondary-key-flags int)
  (#:create "DB_CREATE")
  (#:immutable "DB_IMMUTABLE_KEY"))

(define-foreign-enum-argconvert (foreign-key-flags int)
  (#:abort "DB_FOREIGN_ABORT")
  (#:cascade "DB_FOREIGN_CASCADE"))

(define (make-key-data type key)
  (case type
    ((heap)
     (if key
	 (ensure blob? key)
	 (make-blob
	  (cond-expand
	   (enable-v5 (foreign-value "DB_HEAP_RID_SZ" int))
	   (else 6)))))
    ((records queue)
     (u32vector->blob/shared (u32vector (or key 0))))
    (else
     (call-with-output-string (cut serialize key <>)))))

(define (import-key-data type ptr size)
  (case type
    ((heap)
     (let ((data (make-blob size)))
       (move-memory! ptr data size)
       data))
    ((records queue)
     (let ((data (make-blob size)))
       (move-memory! ptr data size)
       (u32vector-ref (blob->u32vector/shared data) 0)))
    (else
     (import-value-data ptr size))))

(define (make-value-data value)
  (call-with-output-string (cut serialize value <>)))

(define (import-value-data ptr size)
  (let ((data (make-string size)))
    (move-memory! ptr data size)
    (call-with-input-string data deserialize)))

(define-external (secondary_key (c-pointer root) (c-pointer args)) void
  ((foreign-lambda*
    void ((nonnull-c-pointer args) (bool ok))
    "va_return_int((va_alist)args, ok ? 0 : DB_DONOTINDEX);")
   args
   (handle-exceptions
    exn (begin
	  (print-error-message exn (current-error-port) "Callback Error")
	  #f)
    (let* ((info
	    ((foreign-lambda
	      scheme-object "CHICKEN_gc_root_ref"
	      nonnull-c-pointer)
	     root))
	   (proc (vector-ref info 0))
	   (key-type (vector-ref info 1))
	   (result-type (vector-ref info 2)))
      (let-location ((key-ptr c-pointer #f)
		     (key-size unsigned-long 0)
		     (value-ptr c-pointer #f)
		     (value-size unsigned-long 0)
		     (results (c-pointer "DBT") #f))
	((foreign-lambda*
	  void ((nonnull-c-pointer args)
		((nonnull-c-pointer c-pointer) key_data)
		((nonnull-c-pointer unsigned-long) key_size)
		((nonnull-c-pointer c-pointer) value_data)
		((nonnull-c-pointer unsigned-long) value_size)
		((nonnull-c-pointer (c-pointer "DBT")) results))
	  "va_start_int((va_alist)args);"
	  "DB *secondary = va_arg_ptr((va_alist)args, DB *);"
	  "const DBT *key = va_arg_ptr((va_alist)args, const DBT *);"
	  "*key_data = key->data; *key_size = key->size;"
	  "const DBT *value = va_arg_ptr((va_alist)args, const DBT *);"
	  "*value_data = value->data; *value_size = value->size;"
	  "*results = va_arg_ptr((va_alist)args, DBT *);")
	 args
	 (location key-ptr) (location key-size)
	 (location value-ptr) (location value-size)
	 (location results))
	(let* ((key (import-key-data key-type key-ptr key-size))
	       (value (import-value-data value-ptr value-size))
	       (result-data (list->vector
			     (map
			      (lambda (result)
				(make-key-data result-type result))
			      (receive (proc key value))))))
	  ((foreign-lambda*
	    void (((nonnull-c-pointer "DBT") results)
		  (unsigned-long result_count))
	    "size_t results_size = result_count * sizeof(DBT);"
	    "if ((results->data = malloc(results_size))) {"
	    "  memset(results->data, 0, results_size);"
	    "  results->size = result_count;"
	    "  results->flags = DB_DBT_APPMALLOC;"
	    "}")
	   results (vector-length result-data))
	  (do ((i 0 (fx+ i 1))) ((>= i (vector-length result-data)))
	    (let ((result-data (vector-ref result-data i)))
	      ((foreign-lambda*
		void (((nonnull-c-pointer "DBT") results)
		      (unsigned-long i)
		      (nonnull-scheme-pointer result_data)
		      (unsigned-long result_size))
		"if (results->data) {"
		"  DBT *result = &((DBT *)results)[i];"
		"  if ((result->data = malloc(result_size))) {"
		"    memcpy(result->data, result_data, result_size);"
		"    result->size = result_size;"
		"    result->flags = DB_DBT_APPMALLOC;"
		"  }"
		"}")
	       results i result-data (blob/string-size result-data))))))))))

(define secondary-key-callback
  (letrec ((cache
	    (make-mutex 'secondary-key-callback))
	   (secondary-key-callback
	    (lambda (proc key-type result-type)
	      (dynamic-wind
		(cut mutex-lock! cache)
		(lambda ()
		  (and
		   proc
		   (let ((info (vector proc key-type result-type))
			 (cache (mutex-specific cache)))
		     (cond
		      ((hash-table-ref/default cache proc #f)
		       => identity)
		      (else
		       (let ((callback
			      ((foreign-lambda*
				c-pointer ((scheme-object info))
				"void *root = CHICKEN_new_gc_root();"
				"CHICKEN_gc_root_set(root, info);"
				"C_return(alloc_callback(&secondary_key, root));")
			       info)))
			 (hash-table-set! cache proc callback)
			 callback))))))
		(cut mutex-unlock! cache)))))
    (mutex-specific-set! cache (make-hash-table equal? equal?-hash))
    secondary-key-callback))

(define (database-associate db proc secondary . args)
  (let-keys+flags database-associate args
		  ((0 foreign #f))
		  ((secondary-key-flags secondary-flags)
		   (foreign-key-flags foreign-flags))
    (check-error
     'database-associate
     ((foreign-safe-lambda*
       int ((nonnull-database db) (transaction txn) (nonnull-database secondary)
	    (c-pointer callback) (int flags))
       "C_return(db->associate(db, txn, secondary, callback, flags));")
      db (current-transaction) secondary
      (secondary-key-callback proc (database-type db) (database-type secondary))
      secondary-flags))
    (when foreign
      (check-error
       'database-associate
       ((foreign-lambda*
	 int ((nonnull-database db) (nonnull-database secondary)
	      (c-pointer callback) (int flags))
	 "C_return(db->associate_foreign(db, secondary, callback, flags));")
	foreign secondary #f foreign-flags)))))

(define-foreign-enum-argconvert (database-ref-flags int)
  (#:consume "DB_CONSUME")
  (#:consume/wait "DB_CONSUME_WAIT")
  (#:ignore-lease "DB_IGNORE_LEASE")
  (#:read-committed "DB_READ_COMMITTED")
  (#:read-uncommitted "DB_READ_UNCOMMITTED")
  (#:read-modify-write "DB_RMW"))

(define-foreign-enum-argconvert (database-set!-flags int)
  (#:append "DB_APPEND")
  (#:no-duplicate "DB_NODUPDATA")
  (#:no-overwrite "DB_NOOVERWRITE")
  (#:overwrite-duplicate "DB_OVERWRITE_DUP"))

(define-values (database-ref database-set!)
  (letrec ((database-ref
	    (lambda (db key . args)
	      (let-keys+flags database-ref args
			      ((0 default
				  (lambda ()
				    (abort
				     (make-composite-condition
				      (make-property-condition
				       'exn
				       'location 'database-ref
				       'message "database does not contain key"
				       'arguments (list db key))
				      (make-property-condition
				       'access))))))
			      ((database-ref-flags flags))
	        (condition-case
		 (let-location ((value-ptr c-pointer #f)
				(value-size unsigned-long 0))
		   (let ((key-data (make-key-data (database-type db) key)))
		     (check-error
		      'database-ref
		      ((foreign-lambda*
			int ((nonnull-database db) (transaction txn)
			     (nonnull-scheme-pointer key_data)
			     (unsigned-long key_size)
			     ((nonnull-c-pointer c-pointer) value_data)
			     ((nonnull-c-pointer unsigned-long) value_size)
			     (int flags))
			"int s;"
			"DBT key, value;"
			"memset(&key, 0, sizeof(DBT));"
			"key.data = key_data; key.size = key_size;"
			"memset(&value, 0, sizeof(DBT));"
			"s = db->get(db, txn, &key, &value, flags);"
			"*value_data = value.data; *value_size = value.size;"
			"C_return(s);")
		       db (current-transaction)
		       key-data (blob/string-size key-data)
		       (location value-ptr) (location value-size)
		       flags)))
		   (import-value-data value-ptr value-size))
		 (exn (exn db)
		  (if (access-error? exn)
		      (if (procedure? default) (default) default)
		      (abort exn)))))))
	   (database-set!
	    (lambda (db key value . args)
	      (let-keys+flags database-set! args
			      ()
			      ((database-set!-flags flags))
		(let* ((key-type (database-type db))
		       (key-data (make-key-data key-type key))
		       (key-size (blob/string-size key-data))
		       (value-data (make-value-data value))
		       (value-size (string-length value-data)))
		  (check-error
		   'database-set!
		   ((foreign-safe-lambda*
		     int ((nonnull-database db) (transaction txn)
			  (nonnull-scheme-pointer key_data)
			  (unsigned-long key_size)
			  (nonnull-scheme-pointer value_data)
			  (unsigned-long value_size)
			  (int flags))
		     "DBT key, value;"
		     "memset(&key, 0, sizeof(DBT));"
		     "key.data = key_data; key.size = key.ulen = key_size;"
		     "key.flags = DB_DBT_USERMEM;"
		     "memset(&value, 0, sizeof(DBT));"
		     "value.data = value_data; value.size = value_size;"
		     "C_return(db->put(db, txn, &key, &value, flags));")
		    db (current-transaction)
		    key-data key-size value-data value-size flags))
		  (if (memq #:append args)
		      (import-key-data key-type key-data key-size)
		      (void)))))))
    (values (getter-with-setter database-ref database-set!)
	    database-set!)))

(define-foreign-enum-argconvert (database-exists?-flags int)
  (#:read-committed "DB_READ_COMMITTED")
  (#:read-uncommitted "DB_READ_UNCOMMITTED")
  (#:read-modify-write "DB_RMW"))

(define (database-exists? db key . args)
  (let-keys+flags database-exists? args
		  ()
		  ((database-exists?-flags flags))
    (let ((key-data (make-key-data (database-type db) key)))
      ((foreign-lambda*
	bool ((nonnull-database db) (transaction txn)
	      (nonnull-scheme-pointer key_data) (unsigned-long key_size)
	      (int flags))
	"DBT key;"
	"memset(&key, 0, sizeof(DBT));"
	"key.data = key_data; key.size = key_size;"
	"C_return(!db->exists(db, txn, &key, flags));")
       db (current-transaction)
       key-data (blob/string-size key-data)
       flags))))

(define-foreign-enum-argconvert (database-delete!-flags int)
  (#:consume "DB_CONSUME"))

(define (database-delete! db key . args)
  (let-keys+flags database-delete! args
		  ()
		  ((database-delete!-flags flags))
    (let ((key-data (make-key-data (database-type db) key)))
      (check-error
       'database-delete!
       ((foreign-safe-lambda*
	 int ((nonnull-database db) (transaction txn)
	      (nonnull-scheme-pointer key_data) (unsigned-long key_size)
	      (int flags))
	 "DBT key;"
	 "memset(&key, 0, sizeof(DBT));"
	 "key.data = key_data; key.size = key_size;"
	 "C_return(db->del(db, txn, &key, flags));")
	db (current-transaction)
	key-data (blob/string-size key-data)
	flags)))))

(define-foreign-tagged-type (cursor nonnull-cursor "DBC")
  cursor?
  tag:cursor)

(define-foreign-enum-argconvert (database-cursor-flags int)
  (#:read-committed "DB_READ_COMMITTED")
  (#:read-uncommitted "DB_READ_UNCOMMITTED")
  (#:snapshot "DB_TXN_SNAPSHOT"))

(define-foreign-enum-argconvert (cursor-step-flags int)
  (current "DB_CURRENT")
  (first "DB_FIRST")
  (next "DB_NEXT")
  (next-duplicate "DB_NEXT_DUP")
  (next-no-duplicate "DB_NEXT_NODUP")
  (last "DB_LAST")
  (previous "DB_PREV")
  (previous-duplicate "DB_PREV_DUP")
  (previous-no-duplicate "DB_PREV_NODUP")
  (set "DB_SET")
  (ignore-lease "DB_IGNORE_LEASE")
  (read-committed "DB_READ_COMMITTED")
  (read-uncommitted "DB_READ_UNCOMMITTED")
  (read-modify-write "DB_RMW"))

(define (database-fold db proc seed . args)
  (let-keys+flags database-fold args
		  ((0 key #f))
		  ((database-cursor-flags flags))
    (let-location ((cur cursor #f))
      (dynamic-wind
	(lambda ()
	  (cond
	   (cur
	    => (cut error 'database-fold "cannot re-enter cursor walk" <>))))
	(lambda ()
	  (check-error
	   'database-fold
	   ((foreign-lambda*
	     int ((nonnull-database db) (transaction txn)
		  ((nonnull-c-pointer cursor) cur) (int flags))
	     "C_return(db->cursor(db, txn, cur, flags));")
	    db (current-transaction) (location cur) flags))
	  (let ((key-type (database-type db)) (cur cur))
	    (define (cursor-step key flag)
	      (condition-case
	       (let-location ((key-ptr c-pointer #f)
			      (key-size unsigned-long 0)
			      (value-ptr c-pointer #f)
			      (value-size unsigned-long 0))
		 (let ((key-data (make-key-data key-type key)))
		   (check-error
		    'database-fold
		    ((foreign-lambda*
		      int ((nonnull-cursor cur)
			   (scheme-pointer ikey_data)
			   (unsigned-long ikey_size)
			   ((nonnull-c-pointer c-pointer) okey_data)
			   ((nonnull-c-pointer unsigned-long) okey_size)
			   ((nonnull-c-pointer c-pointer) value_data)
			   ((nonnull-c-pointer unsigned-long) value_size)
			   (int flags))
		      "int s;"
		      "DBT key, value;"
		      "memset(&key, 0, sizeof(DBT));"
		      "key.data = ikey_data; key.size = ikey_size;"
		      "memset(&value, 0, sizeof(DBT));"
		      "s = cur->get(cur, &key, &value, flags);"
		      "*okey_data = key.data; *okey_size = key.size;"
		      "*value_data = value.data; *value_size = value.size;"
		      "C_return(s);")
		     cur
		     key-data (blob/string-size key-data)
		     (location key-ptr) (location key-size)
		     (location value-ptr) (location value-size)
		     (cursor-step-flags flag))))
		 (cons (import-key-data key-type key-ptr key-size)
		       (import-value-data value-ptr value-size)))
	       (exn (exn db)
		(if (access-error? exn)
		    #f
		    (abort exn)))))
	    (let loop ((seed seed)
		       (key+value (cursor-step key (if key 'set 'first))))
	      (if key+value
		  (loop (proc (car key+value) (cdr key+value) seed)
			(cursor-step #f (if key 'next-duplicate 'next)))
		  seed))))
	(lambda ()
	  (cond
	   (cur
	    => (lambda (cur)
		 (check-error
		  'database-fold
		  ((foreign-lambda*
		    int ((nonnull-cursor cur))
		    "C_return(cur->close(cur));")
		   cur))))))))))

(define (database-walk db proc . args)
  (apply
   database-fold db
   (lambda (key value seed) (proc key value) seed) (void)
   args))

)