BerkeleyDB

   with-transaction
   copy-database rename-database delete-database
   database?
   open-database close-database
   database-type
   database-serializer database-deserializer
   database-associate
   database-primary database-mapper
   database-ref database-set! database-exists? database-delete!
   database-fold database-walk)
  (import
   scheme chicken foreign
   srfi-1 srfi-4 srfi-18 srfi-69
   lolevel data-structures ports extras)
  (foreign-declare
   "#include <db.h>")


(define-syntax define-foreign-tagged-type
  (syntax-rules ()
    ((define-foreign-tagged-type (id nonnull-id target-type)
       predicate tag)
     (begin
       (define tag

	    (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))
   (else 0)))

;; Database environments

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

    (current-database-environment) (current-transaction)
    file database flags))))

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

(define-record-type berkeley-db:info
  (make-database-info serializer deserializer primary mapper)
  database-info?
  (serializer %database-serializer)
  (deserializer %database-deserializer)
  (primary %database-primary %database-primary-set!)
  (mapper %database-mapper %database-mapper-set!))

(define database-info
  (foreign-lambda*
   scheme-object ((nonnull-database db))
   "C_return(db->app_private ? "
   "CHICKEN_gc_root_ref(db->app_private) : "
   "C_SCHEME_FALSE);"))

(define database-info-set!
  (foreign-lambda*
   void ((nonnull-database db) (scheme-object info))
   "if (!db->app_private) db->app_private = CHICKEN_new_gc_root();"
   "CHICKEN_gc_root_set(db->app_private, info);"))

(cond-expand
 (enable-heap
  (define-foreign-enum-type (database-type int)
    database-type->integer integer->database-type
    (b-tree "DB_BTREE")
    (hash-table "DB_HASH")
    (heap "DB_HEAP")

	   (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))
	 (database-info-set!
	  db
	  (make-database-info
	   (cond (serialize+deserialize => car) (else #f))
	   (cond (serialize+deserialize => cdr) (else #f))
	   #f #f)))
     (exn (exn db)
      (close-database db)
      (abort exn)))
    db)))

(define (database-type db)
  (let-location ((type database-type #f))

       "if (db->app_private) {"
       "  CHICKEN_delete_gc_root(db->app_private);"
       "  db->app_private = NULL;"
       "}"
       "C_return(db->close(db, flags));")
      db flags))))

(define (database-serializer db)
  (cond
   ((database-info db) => %database-serializer)
   (else #f)))

(define (database-deserializer db)
  (cond
   ((database-info db) => %database-deserializer)
   (else #f)))

(define (database-primary db)
  (cond
   ((database-info db) => %database-primary)
   (else #f)))

(define (database-mapper db)
  (cond
   ((database-info db) => %database-mapper)
   (else #f)))

(define (database-primary+mapper-set! db primary mapper)
  (cond
   ((database-info db) =>
    (lambda (info)
      (%database-primary-set! info primary)
      (%database-mapper-set! info mapper)))
   (else
    (database-info-set! db (make-database-info #f #f primary mapper)))))

(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 db key)
  (case (database-type db)
    ((heap)
     (if key
	 (ensure blob? key)
	 (make-blob
	  (cond-expand

       (move-memory! ptr data size)
       (u32vector-ref (blob->u32vector/shared data) 0)))
    (else
     (import-value-data db ptr size))))

(define (make-value-data db value)
  (cond
   ((and value (database-serializer db))
    => (lambda (serialize)
	 (call-with-output-string (cut serialize value <>))))
   (else
    value)))

(define (import-value-data db ptr size)
  (let ((data (make-string size)))
    (move-memory! ptr data size)
    (cond
     ((database-deserializer db)
      => (cut call-with-input-string data <>))
     (else
      data))))

(define (dbt->data+size dbt)













  (let-location ((data c-pointer #f)

		 (size unsigned-long 0))



    ((foreign-lambda*

      void (((nonnull-c-pointer (const "DBT")) dbt)
	    ((nonnull-c-pointer c-pointer) data)
	    ((nonnull-c-pointer unsigned-long) size))
      "*data = dbt->data;"
      "*size = dbt->size;")
     dbt (location data) (location size))
    (values data size)))

(define-external (secondary_key (database secondary)
				((c-pointer (const "DBT")) key)

				((c-pointer (const "DBT")) data)

				((c-pointer "DBT") results))

  int
  (handle-exceptions

   exn (begin
	 (print-error-message exn (current-error-port) "Callback Error")
	 (foreign-value "DB_DONOTINDEX" int))
   (let ((primary (database-primary secondary))
	 (mapper (database-mapper secondary)))
     (let* ((result-data


	     (list->vector
	      (map
	       (cut make-key-data secondary <>)
	       (receive
		(mapper
		 (call-with-values (cut dbt->data+size key)
		   (cut import-key-data primary <> <>))
		 (call-with-values (cut dbt->data+size data)
		   (cut import-value-data primary <> <>)))))))
	    (result-count
	     (vector-length result-data)))
       ((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 result-count)
       (do ((i 0 (fx+ i 1))) ((fx>= i result-count))
	 (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))))))






















   0))






(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))
    (database-primary+mapper-set! secondary db proc)
    (check-error
     'database-associate
     ((foreign-safe-lambda*
       int ((nonnull-database db) (transaction txn) (nonnull-database secondary)
	    (int flags))
       "C_return(db->associate(db, txn, secondary, secondary_key, flags));")
      db (current-transaction) secondary secondary-flags))


    (when foreign
      (check-error
       'database-associate
       ((foreign-lambda*
	 int ((nonnull-database db) (nonnull-database secondary)
	      (int flags))
	 "C_return(db->associate_foreign(db, secondary, NULL, flags));")
	foreign secondary 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")

			"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
		    (or (database-primary db) db) 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-data (make-key-data db key))
		       (key-size (blob/string-size key-data))
		       (value-data (make-value-data
				    (or (database-primary db) db) 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 (zero? (fxand flags (foreign-value "DB_APPEND" int)))
		      (void)
		      (import-key-data db key-data key-size)))))))

    (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-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 (database-cursor-set-flags int)
  (#:range "DB_SET_RANGE"))

(define-foreign-enum-argconvert (database-cursor-key-flags int)
  (#:primary "1"))

(define (database-fold db proc seed . args)
  (let-keys+flags database-fold args
		  ((0 key #f))
		  ((database-cursor-flags flags)
		   (database-cursor-set-flags set-flags)
		   (database-cursor-key-flags key-flags))
    (define step-flags (foreign-value "DB_NEXT" int))
    (define primary? (bit-set? key-flags 0))
    (if key
	(if (zero? set-flags)
	    (set!-values (set-flags step-flags)
	      (values (foreign-value "DB_SET" int)
		      (foreign-value "DB_NEXT_DUP" int))))
	(set! set-flags (foreign-value "DB_FIRST" int)))
    (let-location ((cur cursor #f))

	   '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 ((cur cur))
	    (define (cursor-step key flags)
	      (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 db 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) (bool primary))
		      "int s;"
		      "DBT key, skey, value;"
		      "memset(&key, 0, sizeof(DBT));"
		      "memset(&skey, 0, sizeof(DBT));"
		      "memset(&value, 0, sizeof(DBT));"
		      "if (primary) {"
		      "  skey.data = ikey_data; skey.size = ikey_size;"
		      "  s = cur->pget(cur, &skey, &key, &value, flags);"
		      "} else {"
		      "  key.data = ikey_data; key.size = ikey_size;"
		      "  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)
		     flags (and primary? (database-primary db)))))
		 (let ((primary (database-primary db)))
		   (cons (import-key-data
			  (or (and primary? primary) db) key-ptr key-size)
			 (import-value-data
			  (or primary db) value-ptr value-size))))
	       (exn (exn db)
		(if (access-error? exn)
		    #f
		    (abort exn)))))
	    (let loop ((seed seed)
		       (key+value (cursor-step key set-flags)))
	      (if key+value

;; -*- mode: Scheme; -*-
(define d*
  (cond-expand
   (debug '-d2)
   (else  '-d1)))

(compile -s -O2 ,d* "berkeley-db.scm" -ldb -J)
(compile -s -O2 -d0 "berkeley-db.import.scm")

(install-extension
 'berkeley-db
 '("berkeley-db.so"
   "berkeley-db.import.so")
 '((version "2.2.0")))

  =>
  (void)
</verbatim>

Associates a database with a secondary index and optionally associates
the secondary index with a foreign key constraint.

The serializers and deserializers of <tt>SECONDARY</tt> and
<tt>FOREIGN</tt>, if configured, must be compatible.

<verbatim>
  (database-primary DATABASE) => DATABASE
</verbatim>

Retrieves the primary database associated with a secondary index.
Returns <tt>#f</tt> for a normal database.

<verbatim>
  (database-mapper DATABASE) => PROC
</verbatim>

Retrieves the mapping from primary keys and values to secondary keys
associated with a secondary index. Returns <tt>#f</tt> for a normal
database.

<verbatim>
  (database-ref
   DATABASE KEY [DEFAULT]
   [#:consume] [#:consume/wait] [#:ignore-lease]
   [#:read-committed] [#:read-uncommitted] [#:read-modify-write])
  =>

</verbatim>

Deletes a record from the database.

<verbatim>
  (database-fold
   DATABASE PROC SEED [KEY]
   [#:range] [#:primary] [#:read-committed] [#:read-uncommitted] [#:snapshot])
  =>
  (PROC KEY VALUE (... (PROC KEY VALUE SEED)))
</verbatim>

Folds over the records in the database. If <tt>KEY</tt> is given, only
fold over the records with matching key, unless <tt>#:range</tt> is
also specified to start walking from the first index greater than or
equal to <tt>KEY</tt> in a b-tree database.

If <tt>#:primary</tt> is specified and the database is a secondary
index, <tt>PROC</tt> will be invoked with the primary keys and values
instead of the secondary keys and primary values.

<verbatim>
  (database-walk
   DATABASE PROC [KEY]
   [#:range] [#:primary] [#:read-committed] [#:read-uncommitted] [#:snapshot])
  =>
  (void)
</verbatim>

Like <tt>database-fold</tt>, but discarding the result.