(use test)
(use sqdb)
(use srfi-4)

;;(load "sqdb.scm")(import sqdb)

(define dbname "fooooooo.db")  ;; fixme use a temp name

(when (file-exists? dbname)
  (error "database exists" dbname))

(handle-exceptions e (begin (delete-file dbname) (abort e))

(define (cwdb proc)
  (call-with-database dbname proc))

(test '(1 100 #f)
      (cwdb (lambda (db)
              (add db 'ctr 0)
              (add db 'ctr2 100)
              (incr db 'ctr)
              (list (fetch db 'ctr)
                    (fetch db 'ctr2)
                    (fetch db 'ctr3)   ;; test for missing key
                    ))))
(test-error
 (cwdb (lambda (db)
         (add* db 'ctr 0) (incr db 'ctr) (fetch db 'ctr))))
(test 2
      (cwdb (lambda (db)
              (add db 'ctr 0) (incr db 'ctr) (fetch db 'ctr))))

(test 8
      (cwdb (lambda (db)
              (store db 'ctr 7) (incr db 'ctr) (fetch db 'ctr))))

(test '(10 . 105)
      (cwdb (lambda (db)
              (incr db 'ctr 2)
              (incr db 'ctr2 5)
              (cons (fetch db 'ctr)
                    (fetch db 'ctr2)))))

(test "barbaz"
      (cwdb (lambda (db)
              (store db 'foo "bar")
              (update db 'foo (lambda (v) (string-append v "baz")))
              (fetch db 'foo))))

(test '(#t . #f)
      (cwdb (lambda (db)
              (cons (exists? db 'foo)
                    (exists? db 'foo2)))))

(test "test update with non-existent and existing key"
      "barfoofoofoo"
      (cwdb (lambda (db)
              (let ((u (lambda (x) (string-append (or x "bar") "foo"))))
                (delete db 'upd0)       ;; just in case
                (update db 'upd0 u)
                (update db 'upd0 u)
                (update db 'upd0 u)
                (fetch db 'upd0)))))

(cwdb (lambda (db)
        (delete db 'inc)
        (assert (not (exists? db 'inc)))
        (test "inc non-existent returns #f" #f
              (incr db 'inc))
        (store db 'inc 0)
        (assert (= 0 (fetch db 'inc)))
        (test "inc existing returns #t" #t
              (incr db 'inc))
        (test "inc result correct" 1
              (fetch db 'inc))
        (test "dec existing returns #t" #t
              (decr db 'inc))
        (test "dec result correct" 0
              (fetch db 'inc))
        (delete db 'inc)
        (assert (not (exists? db 'inc)))        
        (test "dec non-existing returns #f" #f
              (decr db 'inc))))

(test-group
 "types"
 (cwdb (lambda (db)
         ;; Some of these are tested implicitly earlier.
         (delete db 'i)
         (delete db 'f)
         (delete db 's)
         (delete db 'z)
         (store db 'i 3)
         (store db 'f 3.0)
         (store db 's "3")
         (store db 'z "foo")
        
         (test "fetch exact integer" 3 (fetch db 'i))
         (test "fetch inexact integer" 3.0 (fetch db 'f))
         (test "fetch integer string" "3" (fetch db 's))
         (test "fetch non-numeric string" "foo" (fetch db 'z))
         (incr db 'i)
         (incr db 'f)
         (incr db 's)
         (incr db 'z)
         (test "increment int -> int + 1" 4 (fetch db 'i))
         (test "increment fp -> fp + 1" 4.0 (fetch db 'f))
         (incr db 'f 0.2)        
         (test "increment fp -> fp + 0.2" 4.2 (fetch db 'f))        
         (test "increment integer string -> int + 1" 4 (fetch db 's))
         (test "increment non-numeric string -> 1" 1 (fetch db 'z))

         (let ((vec '#u8(#xde #xad #xbe #xef #xaa #x55 #xa5 #x5a)))
           (delete db 'v)
           (store db 'v (u8vector->blob/shared vec))
           (test "fetch u8vector encapsulated in blob"
                 vec
                 (blob->u8vector/shared (fetch db 'v))))

         )
       ))

(delete-file dbname)  ;; Clear database.

(test-group
 "traversal"
 (cwdb (lambda (db)
         (define (sort-alist A)
           (sort A (lambda (s1 s2) (string<? (->string (car s1))
                                        (->string (car s2))))))
         (for-each (cut delete db <>) '(foo bar ctr ctr1 ctr2))
         
         (add db 'foo "FOO")
         (add db 'bar "BAR")
         (add db 'ctr 0)
         (add db 'ctr1 1)
         (add db 'ctr2 2)

         (test "list keys" '("bar" "ctr" "ctr1" "ctr2" "foo")
               (sort (list-keys db) string<?))
         (test "list keys subset" '("ctr" "ctr1" "ctr2")
               (sort (list-keys db "ctr%") string<?))

         ;; Implicitly tests map-items
         (test "fetch alist" '((bar . "BAR") (ctr . 0) (ctr1 . 1) (ctr2 . 2) (foo . "FOO"))
               (sort-alist (fetch-alist db)))

         (test "fetch alist subset" '((ctr . 0) (ctr1 . 1) (ctr2 . 2))
               (sort-alist (fetch-alist db "ctr%")))

         ;; Implicitly tests for-each-item
         (test "fetch hash table" '(("bar" . "BAR") ("ctr" . 0) ("ctr1" . 1) ("ctr2" . 2) ("foo" . "FOO"))
               (sort-alist (hash-table->alist (fetch-hash-table db))))

         (test "fetch hash table subset" '(("ctr" . 0) ("ctr1" . 1) ("ctr2" . 2))
               (sort-alist (hash-table->alist (fetch-hash-table db "ctr%"))))

         (test "fold hash table subset" 3
               (fold-items db (lambda (k v s) (+ s v)) 0
                           "ctr%"))
         
         ))
 )

) ;; handle-exceptions

(delete-file dbname)
(test-exit)