fix cursor-put: encode flags correctly

add support for DB_INIT_CDB
add constant DB_DBT_USERMEM
2005-02-14 12:33:59 +00:00 · 2005-02-14 07:14:36 +00:00 · 2005-02-02 15:00:44 +00:00 · 2004-11-30 09:50:07 +00:00 · 2004-11-29 16:54:36 +00:00 · 2004-11-22 16:58:07 +00:00
5 changed files with 2349 additions and 641 deletions
--- a/c/bdb.c
+++ b/c/bdb.c
--- a/c/bdb.h
+++ b/c/bdb.h
@ -9,6 +9,7 @@
 /* record types */
 static s48_value bdb_db_record_type = S48_FALSE;
 static s48_value bdb_env_record_type = S48_FALSE;
+static s48_value bdb_lock_record_type = S48_FALSE;
 static s48_value bdb_mpoolfile_record_type = S48_FALSE;
 static s48_value bdb_txn_record_type = S48_FALSE;
 static s48_value bdb_dbc_record_type = S48_FALSE;
@ -30,11 +31,20 @@ s48_value scsh_enter_dbenv(DB_ENV *h);
 #define scsh_extract_dbenv(x) \
        ((DB_ENV *) s48_extract_integer(S48_RECORD_REF(x, 0)))

+s48_value scsh_enter_lock(DB_LOCK *l);
+#define scsh_extract_lock(x) \
+	((DB_LOCK *) s48_extract_integer(S48_RECORD_REF(x, 0)))
+
+s48_value scsh_enter_DBT_as_bytevector(DBT* dt);
+void scsh_extract_bytevector_as_DBT(s48_value bytevector, DBT* dt);
+
 #define CHECK_BDB_RESULT_CODE(res)		\
 	do {					\
-	     if (res < 0)			\
+	     if (res != 0)			\
+	       fprintf(stderr, "scsh-bdb: %s\n", db_strerror(res)); \	
+	     if (res > 0)			\
               s48_raise_os_error(res);         \
-             if (res > 0)                       \
+             if (res < 0)                       \
               return s48_enter_integer(res);   \
            } while (0);

@ -46,3 +56,8 @@ s48_value scsh_enter_dbenv(DB_ENV *h);

 #define EXTRACT_OPTIONAL_ENV(env)		\
 	((env == S48_FALSE) ? NULL : scsh_extract_dbenv(env))
+
+#define ENTER_INTEGER_CONSTANT(scm_value, c_value)		\
+	S48_GC_PROTECT_GLOBAL(scm_value);			\
+	scm_value = s48_enter_integer(c_value);			\
+	s48_define_exported_binding(#scm_value, scm_value);
--- a/scheme/bdb.scm
+++ b/scheme/bdb.scm
--- a/scheme/packages.scm
+++ b/scheme/packages.scm
@ -1,10 +1,29 @@
 (define-interface berkeley-db-interface
    (export
-     bdb-flags-object?
-     bdb-flags-elements
-     bdb-flags-name
-     (bdb-flags :syntax)
-     
+
+     with-database-env
+     with-database
+     with-database-flags
+     as-transaction
+
+     berkeley-db-version
+     berkeley-db-version-string
+
+     flag-object?
+     flag-elements
+     flag-name
+     (flag :syntax)
+
+     lock-mode-object?
+     lock-mode-elements
+     lock-mode-name
+     (lock-mode :syntax)
+
+     return-code-object?
+     return-code-elements
+     return-code-name
+     (return-code :syntax)
+
     database-type-object?
     database-type-elements
     database-type-name
@ -18,35 +37,92 @@
     &bdb-secondary-index-bad bdb-secondary-index-bad?
     &bdb-invalid-flag bdb-invalid-flag?

-     bdb-db?
-     bdb-env?
-     bdb-mpoolfile?
-     bdb-txn?
-     bdb-dbc?
+     database?
+     database-env?
+     mpoolfile?
+     transaction?
+     cursor?

-     bdb-env-create
-     bdb-env-open
-     bdb-env-close
-     ;bdb-env-remove
-
-     bdb-create
-     bdb-open
-     bdb-close
-     bdb-put
-     bdb-get
-     bdb-del
-     bdb-truncate
-     bdb-sync
-     ;bdb-create-cursor
-     ;bdb-cursor-cget
-
-     bdb-begin-transaction
-     bdb-abort-transaction
-     bdb-commit-transaction))
+     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
+     set-database-env-encrypt!
+     database-env-encrypt-flags
+     set-database-env-verbose!
+     database-env-verbose
+     set-database-env-lock-timeout!
+     set-database-env-transaction-timeout!
+     database-env-lock-timeout
+     database-env-transaction-timeout
+     set-database-env-tmp-dir!
+     database-env-tmp-dir
+     set-database-env-max-transactions!
+     database-env-max-transactions
+     set-database-env-transaction-timeout!
+     database-env-transaction-timeout
+     set-database-env-flags!
+     clear-database-env-flags!
+     database-env-flags
+     database-env-close
+     database-env-fresh-locker-id
+     database-env-free-locker-id
+     database-env-get-lock
+     database-env-put-lock
+     set-database-env-transaction-checkpoint!
+     
+     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
+     set-database-flags!
+     database-flags
+     turn-database-debugging-on
+     turn-database-debugging-off
+     set-database-byte-order!
+     database-big-endian?
+     database-little-endian?
+     set-database-page-size!
+     database-page-size
+     
+     make-cursor
+     cursor-get
+     cursor-get/fork
+     cursor-count
+     cursor-delete-item
+     cursor-delete-item/fork
+     cursor-put
+     cursor-put/fork
+     
+     begin-transaction
+     abort-transaction
+     commit-transaction
+     
+     string->byte-vector
+     byte-vector->string
+     
+     value->byte-vector
+     byte-vector->value))

 (define-structure berkeley-db berkeley-db-interface
  (open scheme
 	srfi-1
+	srfi-8
 	srfi-34
 	srfi-35
 	fluids
@ -58,6 +134,7 @@
 	bitwise
 	define-record-types
 	finite-types
-	external-calls)
+	external-calls
+	(subset scsh-level-0 (fork wait pipe)))
  (files bdb))
  
--- a/test/tests.scm
+++ b/test/tests.scm
@ -0,0 +1,390 @@
+#!/bin/sh
+exec scsh -lel exceptions/load.scm -lel bdb/load.scm -o berkeley-db -e main -s "$0" "$@"
+!#
+
+(define *tests* '())
+
+(define (test-dir)
+  "/tmp/bdb-test/")
+
+(define (add-test! name proc)
+  (set! *tests* (append *tests* (list (cons name proc)))))
+
+(define (make-empty-test-dir)
+  (if (file-exists? (test-dir))
+      (run (rm -rf ,(test-dir))))
+  (run (mkdir -p ,(test-dir))))
+
+(define (fail-if-error try-thunk else-thunk)
+  (and (call-with-current-continuation
+	(lambda (escape)
+	  (with-errno-handler*
+	   (lambda (errno packet)
+	     (escape #f))
+	   try-thunk)))
+       (else-thunk)))
+
+(add-test! 
+    "berkeley-db-version and berkeley-db-version-string"
+    (lambda ()
+      (let ((version (berkeley-db-version)))
+	(and (list? version) 
+	     (= 3 (length version))
+	     (string? (berkeley-db-version-string))))))
+
+(add-test! 
+    "make-database-env"
+    (lambda ()
+      (and (database-env? (make-database-env))
+	   (database-env? (make-database-env (flag rpc-client)))
+	   (database-env? (make-database-env (list (flag rpc-client)))))))
+
+;remove-database
+;remove-database*
+;rename-database
+;rename-database*
+
+'(add-test!
+    "database-env-open"
+    (lambda ()
+      (let ((env (make-database-env)))
+	(fail-if-error
+	 (lambda ()
+	   (database-env-open env (test-dir) 
+			      (list (flag truncate) (flag create))))
+	 (lambda () #t)))))
+
+(add-test!
+    "set/get database-env data-dirs"
+    (lambda ()
+      (let ((env (make-database-env))
+	    (dirs #f))
+	(fail-if-error
+	 (lambda ()
+	   (set-database-env-data-dir! env (test-dir))
+	   (set! dirs (database-env-data-dirs env)))
+	 (lambda () (equal? dirs (list (test-dir))))))))
+
+(add-test!
+    "set-database-env-encrypt!"
+    (lambda ()
+      (let ((env (make-database-env)))
+	(fail-if-error
+	 (lambda ()
+	   (set-database-env-encrypt! env "foo"))
+	 (lambda () #t)))))
+
+(add-test!
+    "database-env-encrypt-flags"
+    (lambda ()
+      (fail-if-error
+       (lambda ()
+	 (database-env-encrypt-flags (make-database-env)))
+       (lambda () #t))))
+
+(add-test!
+    "set-database-env-lock-timeout! and database-env-lock-timeout"
+    (lambda ()
+      (let ((env (make-database-env))
+	    (timeout #f))
+	(fail-if-error
+	 (lambda ()
+	   (set-database-env-lock-timeout! env 128)
+	   (set! timeout (database-env-lock-timeout env)))
+	 (lambda ()
+	   (equal? timeout 128))))))
+
+(add-test!
+    "set-database-env-transaction-timeout! and database-env-transaction-timeout"
+    (lambda ()
+      (let ((env (make-database-env))
+	    (timeout #f))
+	(fail-if-error
+	 (lambda ()
+	   (set-database-env-transaction-timeout! env 100)
+	   (set! timeout
+		 (database-env-transaction-timeout env)))
+	 (lambda ()
+	   (equal? timeout 100))))))
+
+(add-test!
+    "set-database-env-tmp-dir! and database-env-tmp-dir"
+    (lambda ()
+      (let ((env (make-database-env))
+	    (dir #f))
+	(fail-if-error
+	 (lambda ()
+	   (set-database-env-tmp-dir! env (test-dir))
+	   (set! dir (database-env-tmp-dir env)))
+	 (lambda ()
+	   (equal? dir (test-dir)))))))
+
+(add-test!
+    "set-database-env-max-transactions! and database-env-max-transactions"
+    (lambda ()
+      (let ((env (make-database-env))
+	    (max #f))
+	(fail-if-error
+	 (lambda ()
+	   (set-database-env-max-transactions! env 12)
+	   (set! max (database-env-max-transactions env)))
+	 (lambda ()
+	   (equal? max 12))))))
+
+(add-test!
+    "set-database-env-flags!, clear-database-env-flags! and database-env-flags"
+    (lambda ()
+      (let ((env (make-database-env))
+	    (f1 #f)
+	    (f2 #f)
+	    (f3 #f))
+	(fail-if-error
+	 (lambda ()
+	   (set! f1 (database-env-flags env))
+	   (set-database-env-flags! env (flag encrypt))
+	   (set! f2 (database-env-flags env))
+	   (clear-database-env-flags! env (flag encrypt))
+	   (set! f3 (database-env-flags env)))
+	 (lambda ()
+	   (and (= f1 f3) (not (= f1 f2))))))))
+
+(add-test!
+    "database-env-close"
+    (lambda ()
+      (fail-if-error
+       (lambda ()
+	 (database-env-close (make-database-env)))
+       (lambda () #t))))
+
+(add-test!
+    "database-env-fresh-locker-id"
+    (lambda ()
+      (let ((env (make-database-env))
+	    (id #f))
+	(fail-if-error
+	 (lambda ()
+	   (database-env-open env (test-dir)
+			      (list (flag init-lock) (flag create)))
+	   (set! id
+		 (database-env-fresh-locker-id env)))
+	 (lambda ()
+	   (integer? id))))))
+
+(add-test!
+    "database-env-free-locker-id"
+    (lambda ()
+      (let ((env (make-database-env)))
+	(fail-if-error
+	 (lambda ()
+	   (database-env-open env (test-dir)
+			      (list (flag init-lock) (flag create)))
+	   (database-env-free-locker-id 
+	    env
+	    (database-env-fresh-locker-id env))
+	   (database-env-close env))
+	 (lambda () #t)))))
+
+;database-env-get-lock
+;database-env-put-lock
+
+(add-test!
+    "set-database-env-transaction-checkpoint!"
+    (lambda ()
+      (let ((env (make-database-env)))
+	(fail-if-error
+	 (lambda ()
+	   (database-env-open env (test-dir)
+			      (list (flag init-transactions) (flag create)))
+	   (set-database-env-transaction-checkpoint! env 100 5)
+	   (database-env-close env))
+	 (lambda () #t)))))
+
+(add-test! 
+    "make-database"
+    (lambda ()
+      (let ((db1 #f)
+	    (db2 #f))
+	(fail-if-error
+	 (lambda ()
+	   (set! db1 (make-database))
+	   (set! db2 (make-database (make-database-env))))
+	 (lambda ()
+	   (and (database? db1) (database? db2)))))))
+
+(add-test!
+    "open-database"
+    (lambda ()
+      (fail-if-error
+       (lambda ()
+	 (open-database (make-database)
+			(string-append (test-dir) "/bla.db")
+			(database-type binary-tree)
+			(list (flag create) (flag truncate))))
+       (lambda () #t))))
+
+;open-database/fork
+
+(add-test!
+    "close-database"
+    (lambda ()
+      (fail-if-error
+       (lambda ()
+	 (let ((db (make-database)))
+	   (open-database db (string-append (test-dir) "/bla.db")
+			  (database-type binary-tree)
+			  (list (flag create) (flag truncate)))
+	   (close-database db)))
+       (lambda () #t))))
+
+(add-test!
+    "value->byte-vector and byte-vector->value"
+    (lambda ()
+      (let ((conv (lambda (v) 
+		    (byte-vector->value
+		     (value->byte-vector v)))))
+	(fold-right 
+	 (lambda (val res)
+	   (and res (equal? val (conv val))))
+	 #t
+	 '(42 42.0 (1 2 3) (1.0 2.0 3.0) ()
+	      "" "abc" #t #f abc
+	      #(vector 1 2 3) #())))))
+
+(add-test!
+    "string->byte-vector and byte-vector->string"
+    (lambda ()
+      (let ((conv (lambda (s)
+		    (byte-vector->string
+		     (string->byte-vector s)))))
+	(and (string=? "" (conv ""))
+	     (string=? "abc" (conv "abc"))))))
+
+(add-test!
+    "database-put and database-get"
+    (lambda ()
+      (let ((data #f)
+	    (key "donaudampfschifffahrtskapitaenanwaerter")
+	    (value "donaudampfschifffahrtskapitaenspatent"))
+	(fail-if-error
+	 (lambda ()
+	   (let ((db (make-database)))
+	     (open-database db (string-append (test-dir) "/bla.db")
+			    (database-type binary-tree)
+			    (list (flag create) (flag truncate)))
+	     (database-put db (string->byte-vector key)
+			   (string->byte-vector value))
+	     (set! data (database-get db (string->byte-vector key)))
+	     (close-database db)))
+	 (lambda ()
+	   (equal? (byte-vector->string data) value))))))
+
+(add-test!
+    "database-delete-item"
+    (lambda ()
+      (fail-if-error
+       (lambda ()
+	 (let ((db (make-database))
+	       (data (string->byte-vector "hm")))
+	   (open-database db (string-append (test-dir) "/bla.db")
+			  (database-type binary-tree)
+			  (list (flag create) (flag truncate)))
+	   (database-put db data data)
+	   (database-delete-item db data)
+	   (close-database db)))
+       (lambda () #t))))
+
+(add-test!
+    "database-truncate"
+    (lambda ()
+      (fail-if-error 
+       (lambda ()
+	 (let ((db (make-database)))
+	   (open-database db (string-append (test-dir) "/bla.db")
+			  (database-type binary-tree)
+			  (list (flag create) (flag truncate)))
+	   (database-truncate db)
+	   (close-database db)))
+       (lambda () #t))))
+
+(add-test!
+    "database-sync!"
+    (lambda ()
+      (fail-if-error 
+       (lambda ()
+	 (let ((db (make-database)))
+	   (open-database db (string-append (test-dir) "/bla.db")
+			  (database-type binary-tree)
+			  (list (flag create) (flag truncate)))
+	   (database-sync db)
+	   (close-database db)))
+       (lambda () #t))))
+
+(add-test!
+    "set-database-encrypt!"
+    (lambda ()
+      (fail-if-error
+       (lambda ()
+	 (set-database-encrypt! (make-database) "geheim"))
+       (lambda () #t))))
+
+(add-test!
+    "database-encrypt-flags"
+    (lambda ()
+      (let ((flags #f))
+	(fail-if-error
+	 (lambda ()
+	   (let ((db (make-database)))
+	     (open-database db (string-append (test-dir) "/bla.db")
+			    (database-type binary-tree)
+			    (list (flag create) (flag truncate)))
+	     (set! flags (database-encrypt-flags db))
+	     (close-database db)))
+	 (lambda () 
+	   (integer? flags))))))
+
+(add-test!
+    "set-database-flags!"
+    (lambda ()
+      (fail-if-error
+       (lambda ()
+	 (let ((db (make-database)))
+	   (open-database db (string-append (test-dir) "/bla.db")
+			  (database-type binary-tree)
+			  (list (flag create) (flag truncate)))
+	   (set-database-flags! db (flag checksum))
+	   (close-database db)))
+       (lambda () #t))))
+
+(add-test!
+    "database-flags"
+    (lambda ()
+      (let ((flags #f))
+	(fail-if-error
+	 (lambda ()
+	   (let ((db (make-database)))
+	     (open-database db (string-append (test-dir) "/bla.db")
+			    (database-type binary-tree)
+			    (list (flag create) (flag truncate)))
+	     (set! flags (database-flags db))
+	     (close-database db)))
+	 (lambda () 
+	   (integer? flags))))))
+
+(define (run-tests)
+  (make-empty-test-dir)
+  (let lp ((tests *tests*))
+    (if (null? tests)
+	(display "Finished.\n")
+	(begin
+	  (display "Testing ")
+	  (display (caar tests))
+	  (display "...")
+	  (if ((cdar tests))
+	      (begin
+		(display "ok\n")
+		(lp (cdr tests)))
+	      (display "failed\n"))))))
+
+(define (main args)
+  (run-tests))
+
Author	SHA1	Message	Date
eknauel	0b9248184f	fix cursor-put: encode flags correctly	2005-02-14 12:33:59 +00:00
eknauel	d110aa567d	add support for DB_INIT_CDB	2005-02-14 07:14:36 +00:00
eknauel	e2f497619a	add constant DB_DBT_USERMEM	2005-02-02 15:00:44 +00:00
eknauel	244453c1dc	fix commit-transaction	2004-11-30 09:50:07 +00:00
eknauel	8c5b4602cb	Add functions for better application debugging: - turn-database-debugging-on - turn-database-debugging-off - set-database-env-verbose! - database-env-verbose	2004-11-29 16:54:36 +00:00
eknauel	c01134e623	fix return values of CURSOR-GET and DATABASE-GET	2004-11-22 16:58:07 +00:00
eknauel	ed7ab6948e	fix optional txn-id parameter for some functions	2004-11-22 12:24:54 +00:00
eknauel	a61acd45e9	fix two typos	2004-11-15 14:10:21 +00:00
eknauel	bba2de6fae	added with-transaction	2004-11-15 14:09:48 +00:00
eknauel	dcce8de4de	basic tests for Berkeley DB bindings	2004-10-06 08:04:01 +00:00
eknauel	510be37638	fix bdb-truncate	2004-09-24 14:40:45 +00:00
eknauel	13694207f1	- added missing flags - added non-blocking versions for blocking calls to berkeley-db - small fixes - better support for cursors	2004-09-24 13:35:19 +00:00
eknauel	8eae87ddbc	- added some missing flag values - various fixes - added scsh_bdb_cursor_count() and scsh_bdb_cursor_put()	2004-09-24 13:32:36 +00:00
eknauel	ecb0244b52	- support for locks - many setters and getters for DB_ENV and DB	2004-09-22 15:53:38 +00:00
eknauel	c0fc436bf3	various getters/setters for DB_ENV	2004-09-21 14:38:59 +00:00
eknauel	fb5c2a89bc	initialize all DBT structs with 0	2004-09-20 14:39:57 +00:00
eknauel	68a340c591	fixed memory handling, calling of finalizers	2004-09-20 08:21:31 +00:00
eknauel	321045b329	more fixes, simplified	2004-09-20 07:03:52 +00:00
eknauel	0a9aefb9d4	Imported Daniel Brintzinger's code Added package definition, fixed some bugs and rewrote some weird code parts	2004-09-17 10:50:50 +00:00