scsh-bdb/scheme/bdb.scm

;;; 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 options proc)
  (let-fluid        
     $current-transaction-id
     (begin-transaction options)
     (lambda ()
       (proc (lambda ()
	       (abort-transaction (current-transaction-id))))
       (commit-transaction (current-transaction-id)))))

;; constants
(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"))))

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

;;; 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
  (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-env-open-int 
  (env-handle db-home flags mode)
  "scsh_bdb_env_open")

(define (database-env-open env-handle home-dir . args)
  (let-optionals args
      ((flags (or (current-flags) '()))
       (mode 0))
    (let ((result
	   (bdb-env-open-int 
	    env-handle home-dir (flags->value flags) mode)))
      (if (integer? result)
	  (raise-bdb-condition result)
	  (values)))))

(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))
      (let ((result (bdb-env-close-int db-env)))
	(if (integer? result)
	    (raise-bdb-condition result)
	    (begin
	      (add-finalizer! db-env (lambda (x) x))
	      (values))))))

(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)))
    (let ((result
	   (bdb-open-int db-handle db-file database-name txn-id
			 (database-type-id type)
			 (flags->value flags) mode)))
      (if (integer? result)
	  (raise-bdb-condition result)
	  (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)))
	(let ((result
	       (bdb-close-int db-handle (flags->value flags))))
	  (if (integer? result)
	      (raise-bdb-condition result)
	      (begin
		(set-database-closed?! db-handle #t)
		(values)))))))

(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) '())))
    (let ((result (bdb-put-int 
		   db-handle key data
		   txn-id (flags->value flags))))
      (if (integer? result)
	  (raise-bdb-condition result)
	  (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))))

(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) '())))
    (let ((result
	   (bdb-del-int db-handle key txn-id (flags->value flags))))
      (if (integer? result)
	  (raise-bdb-condition result)
	  (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) '())))
    (let ((result
	   (bdb-truncate-int db-handle txn-id (flags->value flags))))
      (if (integer? result)
	  (raise-bdb-condition result)
	  result))))

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

(define (database-sync db-handle)
  (let ((result (bdb-sync-int db-handle)))
    (if (integer? result)
	(raise-bdb-condition result)
	(values))))

(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) '()))
       (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 
  (db-handle flags)
  "scsh_bdb_cursor_cget")

(define (database-get-via-cursor cursor . args)
  (let-optionals args
      ((flags (or (current-flags) '())))
    (let ((result (bdb-cursor-cget-int cursor (flags->value flags))))
      (if (integer? result)
	  (raise-bdb-condition result)
	  result))))

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