604 lines
18 KiB
Scheme
604 lines
18 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-env)
|
|
(fluid $current-env))
|
|
|
|
(define (current-db)
|
|
(fluid $current-db))
|
|
|
|
(define (current-transaction-id)
|
|
(fluid $current-transaction-id))
|
|
|
|
(define (with-env db-env thunk)
|
|
(let-fluid $current-env db-env thunk))
|
|
|
|
(define (with-db db thunk)
|
|
(let-fluid $current-db db thunk))
|
|
|
|
(define (with-transaction options proc)
|
|
(let-fluid
|
|
$current-transaction-id
|
|
(bdb-begin-transaction options)
|
|
(lambda ()
|
|
(proc (lambda ()
|
|
(bdb-abort-transaction (current-transaction-id))))
|
|
(bdb-commit-transaction (current-transaction-id)))))
|
|
|
|
;; constants
|
|
(define-finite-type bdb-flags :bdb-flags
|
|
(id)
|
|
bdb-flags-object?
|
|
bdb-flags-elements
|
|
bdb-flags-name
|
|
bdb-flags-index
|
|
(id bdb-flags-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 (fold-flags valid unit given)
|
|
(fold-right
|
|
(lambda (f flag)
|
|
(if (member f valid)
|
|
(bitwise-ior (bdb-flags-id f) flag)
|
|
(raise (condition
|
|
(&bdb-invalid-flag (value given))))))
|
|
(bdb-flags-id unit)
|
|
(if (list? given) given (list given))))
|
|
|
|
(define (flag-one-of valid given)
|
|
(cond
|
|
((null? given)
|
|
(bdb-flags-id (bdb-flags default)))
|
|
((member given valid)
|
|
=> (lambda (l)
|
|
(bdb-flags-id (car l))))
|
|
(else
|
|
(raise
|
|
(condition
|
|
(&bdb-invalid-flag (value given)))))))
|
|
|
|
(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?)
|
|
|
|
;;; 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
|
|
`((,-30995 ,&bdb-lock-deadlock)
|
|
(,-30994 ,&bdb-lock-not-granted)
|
|
(,-30989 ,&bdb-old-db-version)
|
|
(,-30986 ,&bdb-db-handle-dead)
|
|
(,-30977 , &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 bdb-db :bdb-db
|
|
(make-bdb-db c-pointer)
|
|
bdb-db?
|
|
(c-pointer bdb-db-c-pointer))
|
|
|
|
(define-exported-binding "bdb-db" :bdb-db)
|
|
|
|
;;; DB environement handle : DB_ENV
|
|
(define-record-type bdb-env :bdb-env
|
|
(make-bdb-env c-pointer weak-list)
|
|
bdb-env?
|
|
(c-pointer bdb-env-c-pointer)
|
|
(weak-list bdb-env-weak-list set-bdb-env-weak-list!))
|
|
|
|
(define-exported-binding "bdb-env" :bdb-env)
|
|
|
|
(define (bdb-env-weak-list-add! session thing)
|
|
(set-bdb-env-weak-list!
|
|
session (cons-weak thing (bdb-env-weak-list session))))
|
|
|
|
(define (bdb-env-weak-list-filter! session)
|
|
(set-bdb-env-weak-list!
|
|
session (filter-collected (bdb-env-weak-list session))))
|
|
|
|
(define (bdb-env-finalizer-free session)
|
|
(bdb-env-close session))
|
|
|
|
(define (bdb-env-finalizer session)
|
|
(bdb-env-weak-list-filter! session)
|
|
(if (null? (bdb-env-weak-list session))
|
|
(add-finalizer! session bdb-env-finalizer-free)
|
|
(add-finalizer! session bdb-env-finalizer)))
|
|
|
|
;;; DB memory poolfile : DB_MPOOLFILE
|
|
(define-record-type bdb-mpoolfile :bdb-mpoolfile
|
|
(make-bdb-mpoolfile c-pointer)
|
|
bdb-mpoolfile?
|
|
(c-pointer bdb-mpoolfile-c-pointer))
|
|
|
|
(define-exported-binding "bdb-mpoolfile" :bdb-mpoolfile)
|
|
|
|
;;; DB transaction : DB_TXN
|
|
(define-record-type bdb-txn :bdb-txn
|
|
(make-bdb-txn c-pointer)
|
|
bdb-txn?
|
|
(c-pointer bdb-txn-c-pointer))
|
|
|
|
(define-exported-binding "bdb-txn" :bdb-txn)
|
|
|
|
;;; DB Cursor : DBC
|
|
(define-record-type bdb-dbc :bdb-dbc
|
|
(make-bdb-dbc c-pointer)
|
|
bdb-dbc?
|
|
(c-pointer bdb-dbc-c-pointer))
|
|
|
|
(define-exported-binding "bdb-dbc" :bdb-dbc)
|
|
|
|
(import-lambda-definition bdb-env-create-int (flags)
|
|
"scsh_bdb_env_create")
|
|
|
|
(define bdb-env-create
|
|
(let ((valid-flags (list (bdb-flags rpc-client))))
|
|
(lambda args
|
|
(let-optionals args
|
|
((flags '()))
|
|
(let ((handle
|
|
(bdb-env-create-int (flag-one-of valid-flags flags))))
|
|
(if (integer? handle)
|
|
(raise-bdb-condition handle)
|
|
(begin
|
|
(add-finalizer! handle bdb-env-close)
|
|
handle)))))))
|
|
|
|
(import-lambda-definition
|
|
bdb-env-open-int
|
|
(env-handle db-home flags mode)
|
|
"scsh_bdb_env_open")
|
|
|
|
(define bdb-env-open
|
|
(let ((valid-flags
|
|
(list (bdb-flags join-env) (bdb-flags init-lock)
|
|
(bdb-flags init-log) (bdb-flags init-mpool)
|
|
(bdb-flags init-replication) (bdb-flags init-transactions)
|
|
(bdb-flags run-recover) (bdb-flags recover-fatal))))
|
|
(lambda (env-handle home-dir . args)
|
|
(let-optionals args
|
|
((flags '())
|
|
(mode 0))
|
|
(let ((ret-object
|
|
(bdb-env-open-int
|
|
env-handle home-dir
|
|
(fold-flags valid-flags (bdb-flags default) flags)
|
|
mode)))
|
|
(if (integer? ret-object)
|
|
(raise-bdb-condition ret-object)
|
|
ret-object))))))
|
|
|
|
(import-lambda-definition
|
|
bdb-env-close-int
|
|
(env-handle flags)
|
|
"scsh_bdb_env_close")
|
|
|
|
(define (bdb-env-close env-handle)
|
|
(let ((ret-object
|
|
(bdb-env-close-int env-handle (bdb-flags default))))
|
|
(if (integer? ret-object)
|
|
(raise-bdb-condition ret-object)
|
|
ret-object)))
|
|
|
|
(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 (bdb-create . args)
|
|
(let ((valid-flags (list (bdb-flags xa-create))))
|
|
(let-optionals args
|
|
((env (or (current-env) #f))
|
|
(flags '()))
|
|
(let ((handle
|
|
(bdb-create-int
|
|
env
|
|
(flag-one-of valid-flags flags))))
|
|
(if (integer? handle)
|
|
(raise-bdb-condition handle)
|
|
(begin
|
|
(add-finalizer! handle bdb-close)
|
|
handle))))))
|
|
|
|
(import-lambda-definition
|
|
bdb-open-int
|
|
(db-handle db-file database txnid type flags mode)
|
|
"scsh_bdb_open")
|
|
|
|
(define bdb-open
|
|
(let ((valid-flags
|
|
(list (bdb-flags auto-commit)(bdb-flags create)
|
|
(bdb-flags dirty-read) (bdb-flags excl)
|
|
(bdb-flags nommap) (bdb-flags rdonly)
|
|
(bdb-flags thread) (bdb-flags truncate))))
|
|
(lambda (db-handle db-file . args)
|
|
(let-optionals args
|
|
((type (database-type binary-tree))
|
|
(flags '())
|
|
(mode 0)
|
|
(database (or (current-db) #f))
|
|
(txn-id (or (current-transaction-id) #f)))
|
|
(let ((ret-object
|
|
(bdb-open-int db-handle db-file database txn-id
|
|
(database-type-id type)
|
|
(fold-flags valid-flags (bdb-flags default) flags)
|
|
mode)))
|
|
(if (integer? ret-object)
|
|
(raise-bdb-condition ret-object)
|
|
ret-object))))))
|
|
|
|
(import-lambda-definition
|
|
bdb-close-int
|
|
(db-handle flags)
|
|
"scsh_bdb_close")
|
|
|
|
(define bdb-close
|
|
(let ((valid-flags (list (bdb-flags nosync))))
|
|
(lambda (db-handle . args)
|
|
(let-optionals args
|
|
((flags '()))
|
|
(let ((ret-object
|
|
(bdb-close-int
|
|
db-handle
|
|
(fold-flags valid-flags (bdb-flags default) flags))))
|
|
(if (integer? ret-object)
|
|
(raise-bdb-condition ret-object)
|
|
ret-object))))))
|
|
|
|
(import-lambda-definition
|
|
bdb-put-int
|
|
(db-handle key data txn-id flags)
|
|
"scsh_bdb_put")
|
|
|
|
(define bdb-put
|
|
(let ((valid-flags-0
|
|
(list (bdb-flags append) (bdb-flags nodupdata)
|
|
(bdb-flags nooverwrite)))
|
|
(valid-flags-1
|
|
(list (bdb-flags auto-commit))))
|
|
(lambda (db-handle key data . args)
|
|
(let-optionals args
|
|
((txn-id (or (current-transaction-id) #f))
|
|
(flags-0 #f)
|
|
(flags-1 #f))
|
|
(let* ((flags-0
|
|
(if flags-0
|
|
(fold-flags valid-flags-0 (bdb-flags default) flags-0)
|
|
(bdb-flags-id (bdb-flags default))))
|
|
(flags-1
|
|
(if flags-1
|
|
(fold-flags valid-flags-1 flags-0 flags-1)
|
|
(bdb-flags-id (bdb-flags default))))
|
|
(ret-object
|
|
(bdb-put-int db-handle key data txn-id flags-1)))
|
|
(if (integer? ret-object)
|
|
(raise-bdb-condition ret-object)
|
|
ret-object))))))
|
|
|
|
(import-lambda-definition
|
|
bdb-get-int
|
|
(db-handle key txn-id flags)
|
|
"scsh_bdb_get")
|
|
|
|
(define bdb-get
|
|
(let ((valid-flags-0
|
|
(list (bdb-flags consume) (bdb-flags consume-wait)
|
|
(bdb-flags get-both) (bdb-flags set-recno)))
|
|
(valid-flags-1
|
|
(list (bdb-flags auto-commit) (bdb-flags multiple)
|
|
(bdb-flags rmw))))
|
|
(lambda (db-handle key . args)
|
|
(let-optionals args
|
|
((txn-id (or (current-transaction-id) #f))
|
|
(flags-0 #f)
|
|
(flags-1 #f))
|
|
(let* ((flags-0
|
|
(if flags-0
|
|
(fold-flags valid-flags-0 (bdb-flags default) flags-0)
|
|
(bdb-flags-id (bdb-flags default))))
|
|
(flags-1
|
|
(if flags-1
|
|
(fold-flags valid-flags-1 flags-0 flags-1)
|
|
(bdb-flags-id (bdb-flags default))))
|
|
(ret-object
|
|
(bdb-get-int db-handle key txn-id flags-1)))
|
|
(if (integer? ret-object)
|
|
(raise-bdb-condition ret-object)
|
|
ret-object))))))
|
|
|
|
(import-lambda-definition
|
|
bdb-del-int
|
|
(db-handle key txn-id flags)
|
|
"scsh_bdb_del")
|
|
|
|
(define bdb-del
|
|
(let ((valid-flags (list (bdb-flags auto-commit))))
|
|
(lambda (db-handle key . args)
|
|
(let-optionals args
|
|
((txn-id (or (current-transaction-id) #f))
|
|
(flags '()))
|
|
(let ((ret-object
|
|
(bdb-del-int db-handle key txn-id
|
|
(flag-one-of valid-flags flags))))
|
|
(if (integer? ret-object)
|
|
(raise-bdb-condition ret-object)
|
|
ret-object))))))
|
|
|
|
(import-lambda-definition
|
|
bdb-truncate-int
|
|
(db-home txn-id flags)
|
|
"scsh_bdb_truncate")
|
|
|
|
(define bdb-truncate
|
|
(let ((valid-flags (list (bdb-flags auto-commit))))
|
|
(lambda (db-handle . args)
|
|
(let-optionals args
|
|
((txn-id (or (current-transaction-id) #f))
|
|
(flags '()))
|
|
(let ((ret-object
|
|
(bdb-truncate-int db-handle txn-id
|
|
(flag-one-of valid-flags flags))))
|
|
(if (integer? ret-object)
|
|
(raise-bdb-condition ret-object)
|
|
ret-object))))))
|
|
|
|
(import-lambda-definition
|
|
bdb-sync-int
|
|
(db-handle)
|
|
"scsh_bdb_sync")
|
|
|
|
(define bdb-sync
|
|
(lambda (db-handle)
|
|
(let ((ret-object (bdb-sync-int db-handle)))
|
|
(if (integer? ret-object)
|
|
(raise-bdb-condition ret-object)
|
|
ret-object))))
|
|
|
|
(import-lambda-definition
|
|
bdb-create-cursor-int
|
|
(db-handle txn-id flags)
|
|
"scsh_bdb_create_cursor")
|
|
|
|
;;; no need for finalizer since cursor is unitialized after return
|
|
; (define (bdb-create-cursor db_handle . args)
|
|
; (let-optionals args
|
|
; ((txnid #f)
|
|
; (flags (bdb-flags DB_DEFAULT)))
|
|
; (let* ((ret-object(bdb-create-cursor-int db_handle txnid (bdb-flags-id flags))))
|
|
; (if (integer? ret-object)(raise-bdb-condition ret-object)
|
|
; (begin (values ret-object))))))
|
|
|
|
(import-lambda-definition
|
|
bdb-cursor-cget-int
|
|
(db-handle flags)
|
|
"scsh_bdb_cursor_cget")
|
|
|
|
; (define (bdb-cursor-cget dbc . args)
|
|
; (let-optionals args
|
|
; ((flags (bdb-flags DB_DEFAULT)))
|
|
; (let* ((ret-object(bdb-cursor-cget-int dbc (bdb-flags-id flags))))
|
|
; (if (integer? ret-object)(raise-bdb-condition ret-object)
|
|
; (begin (values ret-object))))))
|
|
|
|
(import-lambda-definition
|
|
bdb-txn-begin-int
|
|
(env-handle parent flags)
|
|
"scsh_bdb_txn_begin")
|
|
|
|
(define bdb-begin-transaction
|
|
(let ((valid-flags
|
|
(list (bdb-flags dirty-read) (bdb-flags txn-nosync)
|
|
(bdb-flags txn-nowait) (bdb-flags txn-sync))))
|
|
(lambda (db-env . args)
|
|
(let-optionals args
|
|
((parent #f)
|
|
(flags #f))
|
|
(let* ((flags
|
|
(if flags
|
|
(fold-flags valid-flags (bdb-flags default) flags)
|
|
(bdb-flags-id (bdb-flags default))))
|
|
(ret-object (bdb-txn-begin-int db-env parent flags)))
|
|
(if (integer? ret-object)
|
|
(raise-bdb-condition ret-object)
|
|
ret-object))))))
|
|
|
|
(import-lambda-definition
|
|
bdb-txn-abort-int (txn-id)
|
|
"scsh_bdb_txn_abort")
|
|
|
|
(define (bdb-abort-transaction txn-id)
|
|
(let ((ret-object (bdb-txn-abort-int txn-id)))
|
|
(if (integer? ret-object)
|
|
(raise-bdb-condition ret-object)
|
|
ret-object)))
|
|
|
|
(import-lambda-definition
|
|
bdb-txn-commit-int
|
|
(txn-id flags)
|
|
"scsh_bdb_txn_commit")
|
|
|
|
(define bdb-commit-transaction
|
|
(let ((valid-flags
|
|
(list (bdb-flags txn-nosync) (bdb-flags txn-sync))))
|
|
(lambda (txn-id . args)
|
|
(let-optionals args
|
|
((flags '()))
|
|
(let ((ret-object
|
|
(bdb-txn-commit-int txn-id (flag-one-of valid-flags flags))))
|
|
(if (integer? ret-object)
|
|
(raise-bdb-condition ret-object)
|
|
ret-object))))))
|
|
|
|
(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)))
|
|
|
|
|