610 lines
19 KiB
Scheme
610 lines
19 KiB
Scheme
;;; 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)))
|
|
|