391 lines
9.5 KiB
Scheme
Executable File
391 lines
9.5 KiB
Scheme
Executable File
#!/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))
|
|
|