basic tests for Berkeley DB bindings

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