1163 lines
34 KiB
Scheme
1163 lines
34 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 db-env flags proc)
|
|
(let-fluid
|
|
$current-transaction-id
|
|
(begin-transaction db-env flags)
|
|
(lambda ()
|
|
(proc (lambda ()
|
|
(abort-transaction (current-transaction-id))))
|
|
(commit-transaction (current-transaction-id)))))
|
|
|
|
(define (with-transaction transaction proc)
|
|
(let-fluid
|
|
$current-transaction-id
|
|
transaction
|
|
proc))
|
|
|
|
;; constants
|
|
|
|
(define (berkeley-db-version)
|
|
(lookup-shared-value "scheme_DB_VERSION"))
|
|
|
|
(define (berkeley-db-version-string)
|
|
(lookup-shared-value "scheme_DB_VERSION_VERBOSE"))
|
|
|
|
(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"))
|
|
(lock-nowait (lookup-shared-value "scheme_DB_LOCK_NOWAIT"))
|
|
(encrypt-aes (lookup-shared-value "scheme_DB_ENCRYPT_AES"))
|
|
(cdb-alldb (lookup-shared-value "scheme_DB_CDB_ALLDB"))
|
|
(direct-db (lookup-shared-value "scheme_DB_DIRECT_DB"))
|
|
(direct-log (lookup-shared-value "scheme_DB_DIRECT_LOG"))
|
|
(log-autoremove (lookup-shared-value "scheme_DB_LOG_AUTOREMOVE"))
|
|
(no-locking (lookup-shared-value "scheme_DB_NOLOCKING"))
|
|
(no-panic (lookup-shared-value "scheme_DB_NOPANIC"))
|
|
(overwrite (lookup-shared-value "scheme_DB_OVERWRITE"))
|
|
(panic-environment (lookup-shared-value "scheme_DB_PANIC_ENVIRONMENT"))
|
|
(region-init (lookup-shared-value "scheme_DB_REGION_INIT"))
|
|
(time-not-granted (lookup-shared-value "scheme_DB_TIME_NOTGRANTED"))
|
|
(transaction-not-durable
|
|
(lookup-shared-value "scheme_DB_TXN_NOT_DURABLE"))
|
|
(transaction-write-no-sync
|
|
(lookup-shared-value "scheme_DB_TXN_NOSYNC"))
|
|
(force (lookup-shared-value "scheme_DB_FORCE"))
|
|
(checksum (lookup-shared-value "scheme_DB_CHKSUM"))
|
|
(encrypt (lookup-shared-value "scheme_DB_ENCRYPT"))
|
|
(duplicate-keys (lookup-shared-value "scheme_DB_DUP"))
|
|
(duplicate-keys-sort (lookup-shared-value "scheme_DB_DUPSORT"))
|
|
(record-numbers (lookup-shared-value "scheme_DB_RECNUM"))
|
|
(no-reverse-splits (lookup-shared-value "scheme_DB_REVSPLITOFF"))
|
|
(renumber (lookup-shared-value "scheme_DB_RENUMBER"))
|
|
(snapshot (lookup-shared-value "scheme_DB_SNAPSHOT"))
|
|
(prev-no-duplicates (lookup-shared-value "scheme_DB_PREV_NODUP"))
|
|
(after (lookup-shared-value "scheme_DB_AFTER"))
|
|
(before (lookup-shared-value "scheme_DB_BEFORE"))
|
|
(key-first (lookup-shared-value "scheme_DB_KEYFIRST"))
|
|
(key-last (lookup-shared-value "scheme_DB_KEYLAST"))
|
|
(init-cdb (lookup-shared-value "scheme_DB_INIT_CDB"))
|
|
(dbt-user-memory (lookup-shared-value "scheme_DB_DBT_USERMEM"))))
|
|
|
|
(define-finite-type lock-mode :lock-mode
|
|
(id)
|
|
lock-mode-object?
|
|
lock-mode-elements
|
|
lock-mode-name
|
|
lock-mode-index
|
|
(id lock-mode-value)
|
|
((read-shared (lookup-shared-value "scheme_DB_LOCK_READ"))
|
|
(write-exclusive (lookup-shared-value "scheme_DB_LOCK_WRITE"))
|
|
(intention-to-write (lookup-shared-value "scheme_DB_LOCK_IWRITE"))
|
|
(intention-to-read (lookup-shared-value "scheme_DB_LOCK_IREAD"))
|
|
(intention-to-read-and-write
|
|
(lookup-shared-value "scheme_DB_LOCK_IWR"))))
|
|
|
|
(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
|
|
(really-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)
|
|
|
|
(define-record-type database-lock :database-lock
|
|
(make-database-lock c-pointer)
|
|
database-lock?
|
|
(c-pointer database-lock-c-pointer))
|
|
|
|
(define-exported-binding "bdb-lock" :database-lock)
|
|
|
|
;;; 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
|
|
(really-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-db-remove-int
|
|
(env-handle txn-id file database flags)
|
|
"scsh_bdb_db_remove")
|
|
|
|
(define (remove-database database-env file-name database-name . args)
|
|
(let-optionals args
|
|
((txn-id (or (current-transaction-id) #f))
|
|
(flags (or (current-flags) '())))
|
|
(cond
|
|
((bdb-db-remove-int database-env txn-id file-name database-name
|
|
(flags->value flags))
|
|
=> raise-bdb-condition))))
|
|
|
|
(define (remove-database/fork . args)
|
|
(wait (fork
|
|
(lambda ()
|
|
(apply remove-database args))))
|
|
(values))
|
|
|
|
(import-lambda-definition bdb-db-rename-int
|
|
(env-handle txn-id file database new-name flags)
|
|
"scsh_bdb_dbrename")
|
|
|
|
;; untested
|
|
(define (rename-database database-env file-name database-name new-name . args)
|
|
(let-optionals args
|
|
((txn-id (or (current-transaction-id) #f))
|
|
(flags (or (current-flags) '())))
|
|
(cond
|
|
((bdb-db-rename-int database-env txn-id file-name database-name
|
|
new-name (flags->value flags))
|
|
=> raise-bdb-condition))))
|
|
|
|
(define (rename-database/fork args)
|
|
(wait (fork
|
|
(lambda ()
|
|
(apply rename-database args))))
|
|
(values))
|
|
|
|
(import-lambda-definition bdb-env-open-int
|
|
(env-handle db-home flags mode)
|
|
"scsh_bdb_env_open")
|
|
|
|
;; untested
|
|
(define (database-env-open db-env home-dir . args)
|
|
(let-optionals args
|
|
((flags (or (current-flags) '()))
|
|
(mode 0))
|
|
(cond
|
|
((bdb-env-open-int db-env home-dir (flags->value flags) mode)
|
|
=> raise-bdb-condition))))
|
|
|
|
(import-lambda-definition bdb-env-set-data-dir-int
|
|
(env-handle dir)
|
|
"scsh_bdb_env_set_data_dir")
|
|
|
|
(define (set-database-env-data-dir! db-env dir)
|
|
(cond
|
|
((bdb-env-set-data-dir-int db-env dir)
|
|
=> raise-bdb-condition)))
|
|
|
|
(import-lambda-definition bdb-env-get-data-dirs
|
|
(env-handle)
|
|
"scsh_bdb_env_get_data_dirs")
|
|
|
|
(define (database-env-data-dirs db-env)
|
|
(let ((result (bdb-env-get-data-dirs db-env)))
|
|
(if (integer? result)
|
|
(raise-bdb-condition result)
|
|
result)))
|
|
|
|
(import-lambda-definition bdb-env-set-encrypt-int
|
|
(env-handle password flags)
|
|
"scsh_bdb_env_set_encrypt")
|
|
|
|
(define (set-database-env-encrypt! database-env password . args)
|
|
(let-optionals args
|
|
((flags (or (current-flags) '())))
|
|
(cond
|
|
((bdb-env-set-encrypt-int database-env password
|
|
(flags->value flags))
|
|
=> raise-bdb-condition))))
|
|
|
|
(import-lambda-definition bdb-env-get-encrypt-flags-int
|
|
(env-handle)
|
|
"scsh_bdb_env_get_encrypt_flags")
|
|
|
|
(define (database-env-encrypt-flags database-env)
|
|
(call-with-values
|
|
(lambda ()
|
|
(apply values (bdb-env-get-encrypt-flags-int database-env)))
|
|
(lambda (error-code flags)
|
|
(if (zero? error-code)
|
|
flags
|
|
(raise-bdb-condition error-code)))))
|
|
|
|
(import-lambda-definition bdb-env-set-timeout-int
|
|
(env-handle timeout lock?)
|
|
"scsh_bdb_env_set_timeout")
|
|
|
|
(define (set-database-env-lock-timeout! db-env timeout)
|
|
(cond
|
|
((bdb-env-set-timeout-int db-env timeout #t)
|
|
=> raise-bdb-condition)))
|
|
|
|
(define (set-database-env-transaction-timeout! db-env timeout)
|
|
(cond
|
|
((bdb-env-set-timeout-int db-env timeout #f)
|
|
=> raise-bdb-condition)))
|
|
|
|
(import-lambda-definition bdb-env-get-timeout-int
|
|
(env-handle lockp)
|
|
"scsh_bdb_env_get_timeout")
|
|
|
|
(define (database-env-lock-timeout db-env)
|
|
(call-with-values
|
|
(lambda ()
|
|
(apply values (bdb-env-get-timeout-int db-env #t)))
|
|
(lambda (error-code timeout)
|
|
(if (zero? error-code)
|
|
timeout
|
|
(raise-bdb-condition error-code)))))
|
|
|
|
(define (database-env-transaction-timeout db-env)
|
|
(call-with-values
|
|
(lambda ()
|
|
(apply values (bdb-env-get-timeout-int db-env #f)))
|
|
(lambda (error-code timeout)
|
|
(if (zero? error-code)
|
|
timeout
|
|
(raise-bdb-condition error-code)))))
|
|
|
|
(import-lambda-definition bdb-env-set-tmp-dir-int
|
|
(env-handle dir)
|
|
"scsh_bdb_env_set_tmp_dir")
|
|
|
|
(define (set-database-env-tmp-dir! db-env dir)
|
|
(cond
|
|
((bdb-env-set-tmp-dir-int db-env dir)
|
|
=> raise-bdb-condition)))
|
|
|
|
(import-lambda-definition bdb-env-get-tmp-dir-int
|
|
(env-handle)
|
|
"scsh_bdb_env_get_tmp_dir")
|
|
|
|
(define (database-env-tmp-dir db-env)
|
|
(call-with-values
|
|
(lambda ()
|
|
(apply values (bdb-env-get-tmp-dir-int db-env)))
|
|
(lambda (error-code tmp-dir)
|
|
(if (zero? error-code)
|
|
tmp-dir
|
|
(raise-bdb-condition error-code)))))
|
|
|
|
(import-lambda-definition bdb-env-set-tx-max
|
|
(env-handle max)
|
|
"scsh_bdb_env_set_tx_max")
|
|
|
|
(define (set-database-env-max-transactions! db-env max)
|
|
(cond ((bdb-env-set-tx-max db-env max)
|
|
=> raise-bdb-condition)))
|
|
|
|
(import-lambda-definition bdb-env-get-tx-max
|
|
(env-handle)
|
|
"scsh_bdb_env_get_tx_max")
|
|
|
|
(define (database-env-max-transactions db-env)
|
|
(call-with-values
|
|
(lambda ()
|
|
(apply values (bdb-env-get-tx-max db-env)))
|
|
(lambda (error-code max)
|
|
(if (zero? error-code)
|
|
max
|
|
(raise-bdb-condition error-code)))))
|
|
|
|
(import-lambda-definition bdb-env-set-tx-timestamp
|
|
(env-handle timestamp)
|
|
"scsh_bdb_env_set_tx_timestamp")
|
|
|
|
(define (set-database-env-transaction-timestamp! db-env timestamp)
|
|
(cond ((bdb-env-set-tx-timestamp db-env timestamp)
|
|
=> raise-bdb-condition)))
|
|
|
|
(import-lambda-definition bdb-env-get-tx-timestamp
|
|
(env-handle)
|
|
"scsh_bdb_env_get_tx_timestamp")
|
|
|
|
(define (database-env-transaction-timestamp db-env)
|
|
(call-with-values
|
|
(lambda ()
|
|
(apply values (bdb-env-get-tx-timestamp db-env)))
|
|
(lambda (error-code timestamp)
|
|
(if (zero? error-code)
|
|
timestamp
|
|
(raise-bdb-condition error-code)))))
|
|
|
|
(import-lambda-definition bdb-env-set-flags
|
|
(env-handle flags clear?)
|
|
"scsh_bdb_env_set_flags")
|
|
|
|
(define (modify-database-env-flags! db-env flags clear?)
|
|
(cond
|
|
((bdb-env-set-flags db-env (flags->value flags) clear?)
|
|
=> raise-bdb-condition)))
|
|
|
|
(define (set-database-env-flags! db-env flags)
|
|
(modify-database-env-flags! db-env flags #f))
|
|
|
|
(define (clear-database-env-flags! db-env flags)
|
|
(modify-database-env-flags! db-env flags #t))
|
|
|
|
(import-lambda-definition bdb-env-get-flags
|
|
(env-handle)
|
|
"scsh_bdb_env_get_flags")
|
|
|
|
(define (database-env-flags db-env)
|
|
(call-with-values
|
|
(lambda ()
|
|
(apply values (bdb-env-get-flags db-env)))
|
|
(lambda (error-code flags)
|
|
(if (zero? error-code)
|
|
flags
|
|
(raise-bdb-condition error-code)))))
|
|
|
|
(import-lambda-definition bdb-env-set-verbose
|
|
(env-handle which on-or-off?)
|
|
"scsh_bdb_env_set_verbose")
|
|
|
|
(define (set-database-env-verbose! db-env which on-or-off?)
|
|
(cond
|
|
((bdb-env-set-verbose db-env which on-or-off?)
|
|
=> raise-bdb-condition)))
|
|
|
|
(import-lambda-definition bdb-env-get-verbose
|
|
(env-handle which)
|
|
"scsh_bdb_env_get_verbose")
|
|
|
|
(define (database-env-verbose db-env which)
|
|
(let ((res (bdb-env-get-verbose db-env which)))
|
|
(if (number? res)
|
|
(raise-bdb-condition res)
|
|
res)))
|
|
|
|
(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))
|
|
(cond
|
|
((bdb-env-close-int db-env)
|
|
=> raise-bdb-condition)
|
|
(else
|
|
(add-finalizer! db-env (lambda (x) x))))))
|
|
|
|
(import-lambda-definition bdb-env-lock-id
|
|
(env-handle)
|
|
"scsh_bdb_env_lock_id")
|
|
|
|
(define (database-env-fresh-locker-id db-env)
|
|
(call-with-values
|
|
(lambda ()
|
|
(apply values (bdb-env-lock-id db-env)))
|
|
(lambda (error-code locker-id)
|
|
(if (zero? error-code)
|
|
locker-id
|
|
(raise-bdb-condition error-code)))))
|
|
|
|
(import-lambda-definition bdb-env-locker-id-free
|
|
(env-handler locker-id)
|
|
"scsh_bdb_env_lock_id_free")
|
|
|
|
(define (database-env-free-locker-id db-env locker-id)
|
|
(cond
|
|
((bdb-env-locker-id-free db-env locker-id)
|
|
=> raise-bdb-condition)))
|
|
|
|
(import-lambda-definition bdb-env-lock-get
|
|
(env-handle locker-id flags object mode)
|
|
"scsh_bdb_env_lock_get")
|
|
|
|
(define (database-env-get-lock db-env locker-id object lock-mode . args)
|
|
(let-optionals args
|
|
((flags (or (current-flags) '())))
|
|
(call-with-values
|
|
(lambda ()
|
|
(receive (rport wport)
|
|
(pipe)
|
|
(wait
|
|
(fork
|
|
(lambda ()
|
|
(write (bdb-env-lock-get db-env locker-id (flags->value flags)
|
|
object (lock-mode-value lock-mode))
|
|
wport))))
|
|
(apply values (read rport))))
|
|
(lambda (error-code lock-pointer)
|
|
(cond
|
|
((= error-code (return-code-value (return-code lock-deadlock)))
|
|
(return-code lock-deadlock))
|
|
((= error-code (return-code-value (return-code lock-not-granted)))
|
|
(return-code lock-not-granted))
|
|
((zero? error-code)
|
|
(make-database-lock lock-pointer))
|
|
(else
|
|
(raise-bdb-condition error-code)))))))
|
|
|
|
(import-lambda-definition bdb-env-lock-put
|
|
(env-handle lock)
|
|
"scsh_bdb_env_lock_put")
|
|
|
|
(define (database-env-put-lock db-env lock)
|
|
(cond ((bdb-env-lock-put db-env lock)
|
|
=> raise-bdb-condition)))
|
|
|
|
(import-lambda-definition bdb-txn-checkpoint
|
|
(env-handle kbyte min flags)
|
|
"scsh_bdb_env_txn_checkpoint")
|
|
|
|
(define (set-database-env-transaction-checkpoint! db-env kbyte min . args)
|
|
(let-optionals args
|
|
((flags (or (current-flags) '())))
|
|
(cond
|
|
((bdb-txn-checkpoint db-env kbyte min (flags->value flags))
|
|
=> raise-bdb-condition))))
|
|
|
|
(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)))
|
|
(cond
|
|
((bdb-open-int db-handle db-file database-name txn-id
|
|
(database-type-id type)
|
|
(flags->value flags) mode)
|
|
=> raise-bdb-condition))))
|
|
|
|
(define (open-database/fork . args)
|
|
(wait (fork
|
|
(lambda ()
|
|
(apply open-database args))))
|
|
(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)))
|
|
(cond
|
|
((bdb-close-int db-handle (flags->value flags))
|
|
=> raise-bdb-condition)
|
|
(else
|
|
(set-database-closed?! db-handle #t))))))
|
|
|
|
(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) '())))
|
|
(cond
|
|
((bdb-put-int db-handle key data txn-id (flags->value flags))
|
|
=> raise-bdb-condition))))
|
|
|
|
(define (database-put/fork . args)
|
|
(wait (fork
|
|
(lambda ()
|
|
(apply database-put args))))
|
|
(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))))
|
|
|
|
(define (database-get/fork . args)
|
|
(receive (rport wport)
|
|
(pipe)
|
|
(wait (fork (lambda ()
|
|
(cond
|
|
((apply database-get args)
|
|
=> (lambda (byte-vector)
|
|
(write (byte-vector->list byte-vector) wport)))
|
|
(else (write #f wport))))))
|
|
(let ((result (read rport)))
|
|
(if (list? result)
|
|
(list->byte-vector 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) '())))
|
|
(cond
|
|
((bdb-del-int db-handle key txn-id (flags->value flags))
|
|
=> raise-bdb-condition))))
|
|
|
|
(define (database-delete-item/fork . args)
|
|
(wait (fork
|
|
(lambda ()
|
|
(apply database-delete-item args))))
|
|
(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) '())))
|
|
(call-with-values
|
|
(lambda ()
|
|
(apply values
|
|
(bdb-truncate-int db-handle txn-id (flags->value flags))))
|
|
(lambda (error-code count)
|
|
(if (zero? error-code)
|
|
count
|
|
raise-bdb-condition)))))
|
|
|
|
(define (database-truncate/fork . args)
|
|
(wait (fork
|
|
(lambda ()
|
|
(apply database-truncate args))))
|
|
(values))
|
|
|
|
(import-lambda-definition bdb-sync-int
|
|
(db-handle)
|
|
"scsh_bdb_sync")
|
|
|
|
(define (database-sync database)
|
|
(cond ((bdb-sync-int database)
|
|
=> raise-bdb-condition)))
|
|
|
|
(import-lambda-definition bdb-set-encrypt
|
|
(database password flags)
|
|
"scsh_bdb_set_encrypt")
|
|
|
|
(define (set-database-encrypt! database password . args)
|
|
(let-optionals args
|
|
((flags (or (current-flags) '())))
|
|
(cond
|
|
((bdb-set-encrypt database password (flags->value flags))
|
|
=> raise-bdb-condition))))
|
|
|
|
;; retest
|
|
(import-lambda-definition bdb-get-encrypt-flags
|
|
(database)
|
|
"scsh_bdb_get_encrypt_flags")
|
|
|
|
(define (database-encrypt-flags database)
|
|
(call-with-values
|
|
(lambda ()
|
|
(apply values (bdb-get-encrypt-flags database)))
|
|
(lambda (error-code flags)
|
|
(if (zero? error-code)
|
|
flags
|
|
(raise-bdb-condition error-code)))))
|
|
|
|
(import-lambda-definition bdb-set-flags
|
|
(database flags)
|
|
"scsh_bdb_set_flags")
|
|
|
|
(define (set-database-flags! database flags)
|
|
(cond
|
|
((bdb-set-flags database (flags->value flags))
|
|
=> raise-bdb-condition)))
|
|
|
|
(import-lambda-definition bdb-get-flags
|
|
(database)
|
|
"scsh_bdb_get_flags")
|
|
|
|
(define (database-flags database)
|
|
(call-with-values
|
|
(lambda ()
|
|
(apply values (bdb-get-flags database)))
|
|
(lambda (error-code flags)
|
|
(if (zero? error-code)
|
|
flags
|
|
(raise-bdb-condition error-code)))))
|
|
|
|
(import-lambda-definition bdb-set-debug-file
|
|
(database filename-or-false)
|
|
"scsh_bdb_set_debug_file")
|
|
|
|
(define (turn-database-debugging-on database file-name)
|
|
(bdb-set-debug-file database file-name))
|
|
|
|
(define (turn-database-debugging-off database)
|
|
(bdb-set-debug-file database #f))
|
|
|
|
(import-lambda-definition bdb-set-lorder
|
|
(database big-endian?)
|
|
"scsh_bdb_set_lorder")
|
|
|
|
(define (set-database-byte-order! database use-big-endian?)
|
|
(cond ((bdb-set-lorder database use-big-endian?)
|
|
=> raise-bdb-condition)))
|
|
|
|
(import-lambda-definition bdb-get-lorder
|
|
(database)
|
|
"scsh_bdb_get_lorder")
|
|
|
|
(define (database-big-endian? database)
|
|
(call-with-values
|
|
(lambda ()
|
|
(apply values (bdb-get-lorder database)))
|
|
(lambda (error-code big-endian?)
|
|
(if (zero? error-code)
|
|
big-endian?
|
|
(raise-bdb-condition error-code)))))
|
|
|
|
(define (database-little-endian? database)
|
|
(not (database-big-endian? database)))
|
|
|
|
(import-lambda-definition bdb-set-pagesize
|
|
(database pagesize)
|
|
"scsh_bdb_set_pagesize")
|
|
|
|
(define (set-database-page-size! database page-size)
|
|
(cond
|
|
((bdb-set-pagesize database page-size)
|
|
=> raise-bdb-condition)))
|
|
|
|
(import-lambda-definition bdb-get-pagesize
|
|
(database)
|
|
"scsh_bdb_get_pagesize")
|
|
|
|
(define (database-page-size database)
|
|
(call-with-values
|
|
(lambda ()
|
|
(apply values (bdb-get-pagesize database)))
|
|
(lambda (error-code page-size)
|
|
(if (zero? error-code)
|
|
page-size
|
|
(raise-bdb-condition error-code)))))
|
|
|
|
(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) #f))
|
|
(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
|
|
(cursor key flags)
|
|
"scsh_bdb_cursor_cget")
|
|
|
|
(define (cursor-get cursor key . args)
|
|
(let-optionals args
|
|
((flags (or (current-flags) '())))
|
|
(let ((result
|
|
(bdb-cursor-cget-int cursor key (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))))
|
|
|
|
(define (cursor-get/fork . args)
|
|
(receive (rport wport)
|
|
(pipe)
|
|
(wait (fork (lambda ()
|
|
(write (byte-vector->list (apply cursor-get args))
|
|
wport))))
|
|
(list->byte-vector (read rport))))
|
|
|
|
(import-lambda-definition bdb-cursor-count
|
|
(cursor)
|
|
"scsh_bdb_cursor_count")
|
|
|
|
(define (cursor-count cursor)
|
|
(call-with-values
|
|
(lambda ()
|
|
(apply values (bdb-cursor-count cursor)))
|
|
(lambda (error-code count)
|
|
(if (zero? error-code)
|
|
count
|
|
(raise-bdb-condition error-code)))))
|
|
|
|
(import-lambda-definition bdb-cursor-del
|
|
(cursor)
|
|
"scsh_bdb_cursor_del")
|
|
|
|
(define (cursor-delete-item cursor)
|
|
(cond ((bdb-cursor-del cursor)
|
|
=> raise-bdb-condition)))
|
|
|
|
(define (cursor-delete-item/fork cursor)
|
|
(wait (fork
|
|
(lambda ()
|
|
(cursor-delete-item cursor))))
|
|
(values))
|
|
|
|
(import-lambda-definition bdb-cursor-put
|
|
(cursor key data flags)
|
|
"scsh_bdb_cursor_put")
|
|
|
|
(define (cursor-put cursor key data . args)
|
|
(let-optionals args
|
|
((flags (flags->value (or (current-flags) '()))))
|
|
(cond
|
|
((bdb-cursor-put cursor key data flags)
|
|
=> raise-bdb-condition))))
|
|
|
|
(define (cursor-put/fork args)
|
|
(wait (fork
|
|
(lambda ()
|
|
(apply cursor-put args))))
|
|
(values))
|
|
|
|
(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 flags))))
|
|
(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)))
|
|
|
|
(define (byte-vector->list bv)
|
|
(let ((length (byte-vector-length bv)))
|
|
(let lp ((index (- length 1)) (res '()))
|
|
(if (< index 0)
|
|
res
|
|
(lp (- index 1) (cons (byte-vector-ref bv index) res))))))
|
|
|
|
(define (list->byte-vector lst)
|
|
(let ((bv (make-byte-vector (length lst) 0)))
|
|
(let lp ((index 0) (lst lst))
|
|
(if (null? lst)
|
|
bv
|
|
(begin
|
|
(byte-vector-set! bv index (car lst))
|
|
(lp (+ index 1) (cdr lst)))))))
|