diff --git a/scheme/bdb.scm b/scheme/bdb.scm index 21b16f2..89b8e02 100644 --- a/scheme/bdb.scm +++ b/scheme/bdb.scm @@ -51,6 +51,13 @@ (commit-transaction (current-transaction-id))))) ;; 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? @@ -112,7 +119,37 @@ (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")))) + (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")))) (define-finite-type lock-mode :lock-mode (id) @@ -257,8 +294,7 @@ (set-database-weak-list! db (filter-collected (database-weak-list db)))) -(import-lambda-definition - bdb-close-int +(import-lambda-definition bdb-close-int (db-handle flags) "scsh_bdb_close") @@ -366,6 +402,12 @@ (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") @@ -380,8 +422,13 @@ new-name (flags->value flags)) => raise-bdb-condition)))) -(import-lambda-definition - bdb-env-open-int +(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") @@ -566,8 +613,7 @@ flags (raise-bdb-condition error-code))))) -(import-lambda-definition - bdb-env-close-int +(import-lambda-definition bdb-env-close-int (env-handle) "scsh_bdb_env_close") @@ -612,11 +658,12 @@ (lambda () (receive (rport wport) (pipe) - (fork - (lambda () - (write (bdb-env-lock-get db-env locker-id (flags->value flags) - object (lock-mode-value lock-mode)) - wport))) + (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 @@ -648,8 +695,7 @@ ((bdb-txn-checkpoint db-env kbyte min (flags->value flags)) => raise-bdb-condition)))) -(import-lambda-definition - bdb-env-remove-int +(import-lambda-definition bdb-env-remove-int (db-home flags) "scsh_bdb_env_remove") @@ -663,8 +709,7 @@ ; (begin ; (values ret-object)))))) -(import-lambda-definition - bdb-create-int +(import-lambda-definition bdb-create-int (env-handle flags) "scsh_bdb_create") @@ -681,8 +726,7 @@ (add-finalizer! handle close-database) handle))))) -(import-lambda-definition - bdb-open-int +(import-lambda-definition bdb-open-int (db-handle db-file database txnid type flags mode) "scsh_bdb_open") @@ -699,6 +743,12 @@ (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) '()))) @@ -710,8 +760,7 @@ (else (set-database-closed?! db-handle #t)))))) -(import-lambda-definition - bdb-put-int +(import-lambda-definition bdb-put-int (db-handle key data txn-id flags) "scsh_bdb_put") @@ -723,8 +772,13 @@ ((bdb-put-int db-handle key data txn-id (flags->value flags)) => raise-bdb-condition)))) -(import-lambda-definition - bdb-get-int +(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") @@ -740,8 +794,21 @@ (raise-bdb-condition result)) result)))) -(import-lambda-definition - bdb-del-int +(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") @@ -753,8 +820,13 @@ ((bdb-del-int db-handle key txn-id (flags->value flags)) => raise-bdb-condition)))) -(import-lambda-definition - bdb-truncate-int +(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") @@ -766,8 +838,13 @@ ((bdb-truncate-int db-handle txn-id (flags->value flags)) => raise-bdb-condition)))) -(import-lambda-definition - bdb-sync-int +(define (database-truncate/fork . args) + (wait (fork + (lambda () + (apply database-truncate args)))) + (values)) + +(import-lambda-definition bdb-sync-int (db-handle) "scsh_bdb_sync") @@ -782,11 +859,10 @@ (define (set-database-encrypt! database password . args) (let-optionals args ((flags (or (current-flags) '()))) - (let ((result - (bdb-set-encrypt database password (flags->value flags)))) - (if (integer? result) - (raise-bdb-condition result) - (values))))) + (cond + ((bdb-set-encrypt database password (flags->value flags)) + => raise-bdb-condition)))) + ;; retest (import-lambda-definition bdb-get-encrypt-flags (database) @@ -869,8 +945,7 @@ page-size (raise-bdb-condition error-code))))) -(import-lambda-definition - bdb-create-cursor-int +(import-lambda-definition bdb-create-cursor-int (db-handle txn-id flags) "scsh_bdb_create_cursor") @@ -888,12 +963,11 @@ (add-finalizer! result cursor-finalizer) result))))) -(import-lambda-definition - bdb-cursor-cget-int +(import-lambda-definition bdb-cursor-cget-int (db-handle flags) "scsh_bdb_cursor_cget") -(define (database-get-via-cursor cursor . args) +(define (cursor-get cursor . args) (let-optionals args ((flags (or (current-flags) '()))) (let ((result (bdb-cursor-cget-int cursor (flags->value flags)))) @@ -901,8 +975,59 @@ (raise-bdb-condition result) result)))) -(import-lambda-definition - bdb-txn-begin-int +(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 (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") @@ -918,9 +1043,9 @@ (database-env-weak-list-add! db-env result) result))))) -(import-lambda-definition - bdb-txn-abort-int (txn-id) - "scsh_bdb_txn_abort") +(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))) @@ -928,8 +1053,7 @@ (raise-bdb-condition result) (values)))) -(import-lambda-definition - bdb-txn-commit-int +(import-lambda-definition bdb-txn-commit-int (txn-id flags) "scsh_bdb_txn_commit") @@ -974,3 +1098,19 @@ (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))))))) diff --git a/scheme/packages.scm b/scheme/packages.scm index 0898401..5120bc6 100644 --- a/scheme/packages.scm +++ b/scheme/packages.scm @@ -6,6 +6,9 @@ with-database-flags as-transaction + berkeley-db-version + berkeley-db-version-string + flag-object? flag-elements flag-name @@ -42,7 +45,9 @@ make-database-env remove-database + remove-database/fork rename-database + rename-database/fork database-env-open set-database-env-data-dir! database-env-data-dirs @@ -70,11 +75,16 @@ make-database open-database + open-database/fork close-database database-put + database-put/fork database-get + database-get/fork database-delete-item + database-delete-item/fork database-truncate + database-truncate/fork database-sync set-database-encrypt! database-encrypt-flags @@ -87,7 +97,13 @@ database-page-size make-cursor - database-get-via-cursor + cursor-get + cursor-get/fork + cursor-count + cursor-delete-item + cursor-delete-item/fork + cursor-put + cursor-put/fork begin-transaction abort-transaction @@ -115,6 +131,6 @@ define-record-types finite-types external-calls - (subset scsh-level-0 (fork pipe))) + (subset scsh-level-0 (fork wait pipe))) (files bdb)) \ No newline at end of file