diff --git a/test/tests.scm b/test/tests.scm new file mode 100755 index 0000000..923a4e1 --- /dev/null +++ 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)) +