;;;; uuid-lib-test.scm

(import test)
(import (only (chicken format) format) (test-utils gloss))

;;
(import (chicken condition))
(import (chicken fixnum))
(import (chicken gc))

(test-begin "Uuid-Lib")

(import uuid-lib)

(cond-expand
  (compiling
    (glossln)
    (gloss "**********")
    (gloss "*")
    (gloss "* Expect Compiler Warnings!")
    (gloss "*")
    (gloss "**********") )
  (else) )

(test-group "Common API"

  (test-group "make-uuid"
    (define (make-uuid-test ityp typ ver)
      (let ((tuuid (if (eq? ityp 'default) (make-uuid) (make-uuid ityp))))
        (gloss tuuid)
        (test-assert (uuid? tuuid))
        (test typ (uuid-method tuuid))
        (test ver (uuid-version-number tuuid))
        (test-assert "check is/is-not null"
                     (if (eq? ityp 'default) (uuid-null? tuuid)
                         (not (uuid-null? tuuid)))) ) )

    (test-group "default" (make-uuid-test 'default #f 0))
    #; ;platform dependent
    (test-group "#f" (make-uuid-test #f ??? 0))
    (test-group "V1" (make-uuid-test 'V1 'v1 1))
    (test-group "time" (make-uuid-test 'time 'v1 1))
    (test-group "V4" (make-uuid-test 'V4 'v4 4))
    (test-group "random" (make-uuid-test 'random 'v4 4))
  )

  (test-assert (uuid-null? (uuid-clear! (make-uuid 'V4))))

  (let* ((tuuid (make-uuid 'V4))
         (cuuid (uuid-copy tuuid)) )
    (test-assert "uuid-copy =" (uuid=? tuuid cuuid))
    (test-assert "uuid-copy !eq" (not (eq? tuuid cuuid))) )

  (test-assert "A uuid is = & <= & >= to itself"
    (let ((tuuid (make-uuid 'random)))
      (and (uuid=? tuuid tuuid)
           (uuid<=? tuuid tuuid)
           (uuid>=? tuuid tuuid))))

  (test-assert "A !null uuid is \"unique\"" (not (uuid=? (make-uuid 'V1) (make-uuid 'V1))))
  (test-assert "A !null uuid is \"unique\"" (not (uuid=? (make-uuid 'V4) (make-uuid 'V4))))
  (test-assert "A null uuid is not \"unique\"" (uuid=? (make-uuid) (make-uuid)))

  (test-assert "External form of uuid"
    (let ((tuuid (make-uuid 'V1)))
      (uuid=? tuuid (string->uuid (uuid->string tuuid)))))

  (test "Finalizer"
    #t
    (condition-case (number? (gc))
      (v () ((condition-property-accessor 'exn 'message) v))))
)

(define-constant hash-default-bound 536870912)

(test-group "Hash API"
  (let ((v1 (make-uuid 'v1))
        (v4 (make-uuid 'v4)) )
    (test-assert "fixnum hash" (fixnum? (uuid-hash v1)))
    (test-assert "fixnum hash" (fixnum? (uuid-hash v4)))
    (test-assert "same hash" (fx= (uuid-hash v1) (uuid-hash v1)))
    (test-assert "same hash" (fx= (uuid-hash v4) (uuid-hash v4)))
    (test-assert "different hash" (not (fx= (uuid-hash v1) (uuid-hash v4))))
    (test-assert "32bit hash" (fx< (uuid-hash v1) hash-default-bound))
    (test-assert "32bit hash" (fx< (uuid-hash v4) hash-default-bound)) )
)

(test-group "Specific API"

  (test #f (uuid-method (make-uuid)))
  (test 'v1 (uuid-method (make-uuid 'v1)))
  (test 'v4 (uuid-method (make-uuid 'v4)))

  (test-assert "A uuid is unique" (not (uuid=? (uuid-generate) (uuid-generate))))

  (test "clear! resets method" #f (uuid-method (uuid-clear! (make-uuid 'V4))))

  (test-group "Generate Default"
    (let ((tuuid (uuid-generate)))
      (test-assert (uuid? tuuid))
      (test-assert (symbol? (uuid-method tuuid)))
      (test-assert (fixnum? (uuid-version-number tuuid)))
      (test-assert (not (uuid-null? tuuid)))
      (test-assert "unparse - parse"
                   (uuid=? tuuid (uuid-parse (uuid-unparse tuuid 'lower))))
      (test "same method"
            (uuid-method tuuid)
            (uuid-method (uuid-parse (uuid-unparse tuuid 'lower)))) )
  )

  (test-group "Generate V4"
    (let ((tuuid (uuid-generate 'v4)))
      (test-assert (uuid? tuuid))
      (test 'v4 (uuid-method tuuid))
      (test 4 (uuid-version-number tuuid))
      (test-assert (not (uuid-null? tuuid)))
      (test-assert "unparse - parse v4"
                   (uuid=? tuuid (uuid-parse (uuid-unparse tuuid))))
      (test 'v4
            (uuid-method (uuid-parse (uuid-unparse tuuid))))
      (test "same method"
            (uuid-method tuuid)
            (uuid-method (uuid-parse (uuid-unparse tuuid)))) )
  )
)

;generates compiler warnings
(test-group "Error caught correctly"
  (test "generate"
    "bad argument type - invalid method; #f or symbol 'v[0..15]"
    (condition-case (uuid-generate 2)
      (v () ((condition-property-accessor 'exn 'message) v))))

  (test "unparse"
    "bad argument type - invalid case; #f, upper, or lower"
    (condition-case (uuid-unparse (uuid-generate) 2)
      (v () ((condition-property-accessor 'exn 'message) v))))
)

(test-end "Uuid-Lib")

(test-exit)