db: clean up test suite, (test conditional) => (conditional test), timing

This commit is contained in:
Ryan Culpepper 2011-08-31 17:34:45 -06:00
parent f44337e28e
commit 69a56ef683
5 changed files with 29 additions and 28 deletions

View File

@ -250,5 +250,5 @@ Testing profiles are flattened, not hierarchical.
[else [else
(for ([test tests]) (for ([test tests])
(printf "Running ~s tests\n" (car test)) (printf "Running ~s tests\n" (car test))
(run-tests (cdr test)) (time (run-tests (cdr test)))
(newline))]))) (newline))])))

View File

@ -27,6 +27,7 @@
set-equal? set-equal?
sql sql
select-val select-val
dbsystem
NOISY? NOISY?
TESTFLAGS TESTFLAGS
ANYFLAGS)) ANYFLAGS))
@ -88,6 +89,14 @@
(sql (string-append "values (" str ")"))] (sql (string-append "values (" str ")"))]
[else (sql (string-append "select " str))])) [else (sql (string-append "select " str))]))
(define dbsystem
(with-handlers ([(lambda (e) #t)
(lambda (e) #f)])
(let* ([c (connect)]
[dbsystem (send c get-dbsystem)])
(disconnect c)
dbsystem)))
;; Flags = dbflags U dbsys ;; Flags = dbflags U dbsys
;; Returns #t if all are set. ;; Returns #t if all are set.

View File

@ -7,8 +7,8 @@
(export test^) (export test^)
(define (test-concurrency workers) (define (test-concurrency workers)
(test-case (format "lots of threads (~s)" workers)
(unless (ANYFLAGS 'isora 'isdb2) (unless (ANYFLAGS 'isora 'isdb2)
(test-case (format "lots of threads (~s)" workers)
(call-with-connection (call-with-connection
(lambda (c) (lambda (c)
(query-exec c "create temporary table play_numbers (n integer)") (query-exec c "create temporary table play_numbers (n integer)")
@ -40,8 +40,8 @@
(query-value c "select max(n) from play_numbers")))) (query-value c "select max(n) from play_numbers"))))
(define (kill-safe-test proxy?) (define (kill-safe-test proxy?)
(test-case (format "kill-safe test~a" (if proxy? " (proxy)" ""))
(unless (ANYFLAGS 'isora 'isdb2) (unless (ANYFLAGS 'isora 'isdb2)
(test-case (format "kill-safe test~a" (if proxy? " (proxy)" ""))
(call-with-connection (call-with-connection
(lambda (c0) (lambda (c0)
(let ([c (if proxy? (let ([c (if proxy?
@ -63,8 +63,8 @@
(sync t)))))))) (sync t))))))))
(define (async-test) (define (async-test)
(test-case "asynchronous execution"
(unless (ANYFLAGS 'ismy 'isora 'isdb2) (unless (ANYFLAGS 'ismy 'isora 'isdb2)
(test-case "asynchronous execution"
(call-with-connection (call-with-connection
(lambda (c) (lambda (c)
(query-exec c "create temporary table nums (n integer)") (query-exec c "create temporary table nums (n integer)")

View File

@ -33,8 +33,8 @@
(test-suite (format "simple (~a)" prep-mode) (test-suite (format "simple (~a)" prep-mode)
(test-case "query-exec"
(unless (ANYFLAGS 'isora 'isdb2) ;; table isn't temp, so don't tamper with it (unless (ANYFLAGS 'isora 'isdb2) ;; table isn't temp, so don't tamper with it
(test-case "query-exec"
(with-connection c (with-connection c
(check-pred void? (Q c query-exec "insert into the_numbers values(-1, 'mysterious')")) (check-pred void? (Q c query-exec "insert into the_numbers values(-1, 'mysterious')"))
(check-equal? (Q c query-value "select descr from the_numbers where N = -1") (check-equal? (Q c query-value "select descr from the_numbers where N = -1")
@ -143,8 +143,8 @@
(check set-equal? (check set-equal?
(map vector (map car test-data)) (map vector (map car test-data))
(rows-result-rows q))))) (rows-result-rows q)))))
(test-case "query - update"
(unless (ANYFLAGS 'isora 'isdb2) (unless (ANYFLAGS 'isora 'isdb2)
(test-case "query - update"
(with-connection c (with-connection c
(let [(q (query c "update the_numbers set N = -1 where N = 1"))] (let [(q (query c "update the_numbers set N = -1 where N = 1"))]
(check-pred simple-result? q))))) (check-pred simple-result? q)))))
@ -226,8 +226,8 @@
;; Added 18 May 2003: Corrected a bug which incorrectly interleaved ;; Added 18 May 2003: Corrected a bug which incorrectly interleaved
;; nulls with returned fields. ;; nulls with returned fields.
(test-case "nulls arrive in correct order"
(unless (TESTFLAGS 'odbc 'issl) (unless (TESTFLAGS 'odbc 'issl)
(test-case "nulls arrive in correct order"
(with-connection c (with-connection c
;; raw NULL has PostgreSQL type "unknown", not allowed ;; raw NULL has PostgreSQL type "unknown", not allowed
(define (clean . strs) (define (clean . strs)
@ -257,8 +257,8 @@
(test-case "query - not a statement" (test-case "query - not a statement"
(with-connection c (with-connection c
(check-exn exn:fail? (lambda () (query c 5))))) (check-exn exn:fail? (lambda () (query c 5)))))
(test-case "query - multiple statements in string"
(unless (or (TESTFLAGS 'odbc 'ispg) (ANYFLAGS 'isdb2)) (unless (or (TESTFLAGS 'odbc 'ispg) (ANYFLAGS 'isdb2))
(test-case "query - multiple statements in string"
(with-connection c (with-connection c
(check-exn exn:fail? (check-exn exn:fail?
(lambda () (lambda ()

View File

@ -12,8 +12,6 @@
(import config^ database^) (import config^ database^)
(export test^) (export test^)
(define dbsystem #f) ;; hack, set within test suite
(define current-type (make-parameter #f)) (define current-type (make-parameter #f))
(define-syntax-rule (type-test-case types . body) (define-syntax-rule (type-test-case types . body)
@ -23,10 +21,9 @@
(let* ([known-types (send dbsystem get-known-types)] (let* ([known-types (send dbsystem get-known-types)]
[type (for/or ([type types]) [type (for/or ([type types])
(and (member type known-types) type))]) (and (member type known-types) type))])
(if type (when type
(test-case (format "~s" type) (test-case (format "~s" type)
(parameterize ((current-type type)) (proc))) (parameterize ((current-type type)) (proc))))))
(test-case (format "unsupported: ~s" types) (void)))))
(define (check-timestamptz-equal? a b) (define (check-timestamptz-equal? a b)
(check srfi:time=? (check srfi:time=?
@ -143,11 +140,6 @@
(define test (define test
(test-suite "SQL types (roundtrip, etc)" (test-suite "SQL types (roundtrip, etc)"
#:before (lambda ()
(call-with-connection
(lambda (c) (set! dbsystem (connection-dbsystem c)))))
#:after (lambda () (set! dbsystem #f))
(type-test-case '(bool boolean) (type-test-case '(bool boolean)
(call-with-connection (call-with-connection
(lambda (c) (lambda (c)
@ -205,8 +197,8 @@
(check-roundtrip c -inf.0) (check-roundtrip c -inf.0)
(check-roundtrip c +nan.0))))) (check-roundtrip c +nan.0)))))
(type-test-case '(numeric decimal)
(unless (ANYFLAGS 'isdb2) ;; "Driver not capable" (unless (ANYFLAGS 'isdb2) ;; "Driver not capable"
(type-test-case '(numeric decimal)
(call-with-connection (call-with-connection
(lambda (c) (lambda (c)
(check-roundtrip c 0) (check-roundtrip c 0)