fixed memory handling, calling of finalizers

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);

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)))
+(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)
-	(values))))
+	    (begin
+	      (add-finalizer! db-env (lambda (x) x))
+	      (values))))))
 
 (import-lambda-definition 
     bdb-env-remove-int 
@@ -355,6 +390,7 @@
       (if (integer? handle)
 	  (raise-bdb-condition handle)
 	  (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) '())))
+    (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)
-	  (values)))))
+	      (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)
@@ -562,4 +607,3 @@
 	       (byte-vector->string byte-vector))))
     (read port)))
      
-     

scheme/packages.scm

@@ -49,6 +49,9 @@
      database-truncate
      database-sync
 
+     make-cursor
+     database-get-via-cursor
+
      begin-transaction
      abort-transaction
      commit-transaction