diff --git a/c/bdb.c b/c/bdb.c index d425a21..1d6d6cd 100644 --- a/c/bdb.c +++ b/c/bdb.c @@ -160,7 +160,7 @@ s48_value scsh_bdb_env_create(s48_value sflags) res = db_env_create(&dbenv, flags); CHECK_BDB_RESULT_CODE(res); - return scsh_enter_env(dbenv); + return scsh_enter_dbenv(dbenv); } /* close an environment */ @@ -522,6 +522,21 @@ s48_value scsh_bdb_create_cursor(s48_value handle, s48_value stxnid, return scsh_enter_cursor(dbcp); } +s48_value scsh_bdb_close_cursor(s48_value scursor) +{ + int res; + DBC *cursor; + S48_DECLARE_GC_PROTECT(1); + + S48_GC_PROTECT_1(scursor); + cursor = scsh_extract_cursor(scursor); + S48_GC_UNPROTECT(); + + res = cursor->c_close(cursor); + CHECK_BDB_RESULT_CODE(res); + return s48_enter_integer(res); +} + /* retrieve values from cursor */ s48_value scsh_bdb_cursor_cget(s48_value dbc, s48_value sflags) { @@ -556,7 +571,7 @@ s48_value scsh_bdb_txn_begin (s48_value handle, s48_value sparent, S48_DECLARE_GC_PROTECT(3); S48_GC_PROTECT_3(handle, sflags, ret); - env = scsh_extract_env(handle); + env = scsh_extract_dbenv(handle); flags = s48_extract_integer(sflags); S48_GC_UNPROTECT(); @@ -715,6 +730,7 @@ void scsh_init_bdb_bindings(void) S48_EXPORT_FUNCTION(scsh_bdb_truncate); S48_EXPORT_FUNCTION(scsh_bdb_sync); S48_EXPORT_FUNCTION(scsh_bdb_create_cursor); + S48_EXPORT_FUNCTION(scsh_bdb_close_cursor); S48_EXPORT_FUNCTION(scsh_bdb_cursor_cget); S48_EXPORT_FUNCTION(scsh_bdb_txn_begin); S48_EXPORT_FUNCTION(scsh_bdb_txn_abort); diff --git a/scheme/bdb.scm b/scheme/bdb.scm index 9d175dc..1622251 100644 --- a/scheme/bdb.scm +++ b/scheme/bdb.scm @@ -229,9 +229,34 @@ ;;; define bdb records ;;; DB handle : DB (define-record-type database :database - (make-database c-pointer) + (make-database c-pointer closed? weak-list) database? - (c-pointer database-c-pointer)) + (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) @@ -271,9 +296,10 @@ ;;; DB transaction : DB_TXN (define-record-type transaction :transaction - (make-transaction c-pointer) + (make-transaction c-pointer env) transaction? - (c-pointer transaction-c-pointer)) + (c-pointer transaction-c-pointer) + (env transaction-env set-transaction-env!)) (define-exported-binding "bdb-txn" :transaction) @@ -285,6 +311,12 @@ (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") @@ -320,11 +352,14 @@ (env-handle) "scsh_bdb_env_close") -(define (database-env-close env-handle) - (let ((result (bdb-env-close-int env-handle))) - (if (integer? result) - (raise-bdb-condition result) - (values)))) +(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 @@ -354,7 +389,8 @@ (bdb-create-int env (flags->value flags)))) (if (integer? handle) (raise-bdb-condition handle) - (begin + (begin + (set-database-closed?! handle #f) (add-finalizer! handle close-database) handle))))) @@ -378,19 +414,18 @@ (raise-bdb-condition result) (values))))) -(import-lambda-definition - bdb-close-int - (db-handle flags) - "scsh_bdb_close") - (define (close-database db-handle . args) (let-optionals args ((flags (or (current-flags) '()))) - (let ((result - (bdb-close-int db-handle (flags->value flags)))) - (if (integer? result) - (raise-bdb-condition result) - (values))))) + (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 @@ -419,7 +454,8 @@ (flags (or (current-flags) '()))) (let ((result (bdb-get-int db-handle key txn-id (flags->value flags)))) (if (integer? result) - (if (or (= result -30990) (= result -30997)) + (if (or (= result (return-code-value (return-code not-found))) + (= result (return-code-value (return-code key-empty)))) #f (raise-bdb-condition result)) result)))) @@ -470,26 +506,32 @@ (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)))))) +(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 (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)))))) +(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 @@ -503,7 +545,10 @@ (let ((result (bdb-txn-begin-int db-env parent (flags->value flags)))) (if (integer? result) (raise-bdb-condition result) - (values))))) + (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) @@ -561,5 +606,4 @@ (let ((port (make-string-input-port (byte-vector->string byte-vector)))) (read port))) - diff --git a/scheme/packages.scm b/scheme/packages.scm index a38ca29..bf3e586 100644 --- a/scheme/packages.scm +++ b/scheme/packages.scm @@ -48,7 +48,10 @@ database-delete-item database-truncate database-sync - + + make-cursor + database-get-via-cursor + begin-transaction abort-transaction commit-transaction