#!/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))