;; -*- mode: Scheme; -*-
;;
;; This file is part of BerkeleyDB for CHICKEN
;; Copyright (c) 2011-2013 by Thomas Chust.  All rights reserved.
;;
;; Permission is hereby granted, free of charge, to any person
;; obtaining a copy of this software and associated documentation
;; files (the Software), to deal in the Software without restriction,
;; including without limitation the rights to use, copy, modify,
;; merge, publish, distribute, sublicense, and/or sell copies of the
;; Software, and to permit persons to whom the Software is furnished
;; to do so, subject to the following conditions:
;; 
;; The above copyright notice and this permission notice shall be
;; included in all copies or substantial portions of the Software.
;; 
;; THE SOFTWARE IS PROVIDED ASIS, WITHOUT WARRANTY OF ANY KIND,
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.

(require-extension
 numbers
 srfi-4 srfi-42 srfi-69 srfi-78 posix extras
 berkeley-db)

(define-record-type foo
  (make-foo a b)
  foo?
  (a foo-a)
  (b foo-b))

(define-record-printer (foo v port)
  (fprintf port "#,(foo ~s ~s)" (foo-a v) (foo-b v)))

(define-reader-ctor 'foo
  make-foo)

;; Database tests

(create-directory "test.db-env")
(check
 (database-environment?
  (open-database-environment
   "test.db-env" #:create #:memory-pool #:transactions))
 =>
 #t)

(define blurbs
  (with-transaction
   (cut open-database "blurbs.db" 'b-tree
	#:create)))
(check
 (database? blurbs) => #t)

(with-transaction
 (lambda ()
   (database-set! blurbs "foo" "bar")
   (database-set! blurbs "baz" "kawumm")))

(check
 (database-ref blurbs "foo") => "bar")
(check
 (database-ref blurbs "baz") => "kawumm")

(check
 (database-ref blurbs "no key" #f) => #f)
(check
 (condition-case (database-ref blurbs "still no key")
   ((exn access) 'exn-access))
 => 'exn-access)

(define write+read
  (cons write read))

(define records
  (with-transaction
   (cut open-database "records.db" 'records
	#:create
	#:serialize+deserialize write+read)))
(check
 (database? records) => #t)

(define records-a
  (with-transaction
   (cut open-database "records-a.db" 'b-tree
	#:create #:duplicates/sorted
	#:serialize+deserialize write+read)))
(check
 (database? records-a) => #t)

(define notes
  (with-transaction
   (cut open-database "notes.db" 'b-tree
	#:create
	#:serialize+deserialize write+read)))
(check
 (database? notes) => #t)

(database-associate
 records (lambda (k v) (foo-a v)) records-a notes
 #:cascade)

(define sample
  #f)

(with-transaction
 (lambda ()
   (database-set! notes 1 "the number one")
   (database-set! notes 2 "the number two")
   (database-set! records #f (make-foo 1 'blubb) #:append)
   (set! sample (database-set! records #f (make-foo 1 'blabb) #:append))
   (database-set! records #f (make-foo 2 'blargh) #:append)))

(define (count k v n)
  (add1 n))

(check
 (database-fold records count 0) => 3)

(check
 (database-fold records-a count 0 1) => 2)

(check
 (database-ref records sample) => (make-foo 1 'blabb))

(check
 (database-ref records-a 2) => (make-foo 2 'blargh))

(database-delete! notes 1)

(check
 (database-ref records-a 1 'fubar) => 'fubar)

(check
 (database-fold records (lambda (k v l) (cons v l)) '())
 =>
 (list (make-foo 2 'blargh)))

(cond-expand
 (enable-forcesync
  (close-database-environment #:synchronous))
 (else
  (close-database records)
  (close-database records-a)
  (close-database notes)
  (close-database-environment)))

(check-report)
(exit (if (check-passed? 15) 0 1))