diff --git a/collects/db/private/generic/connect-util.rkt b/collects/db/private/generic/connect-util.rkt index 6d4074fbcc..8cf6af3f12 100644 --- a/collects/db/private/generic/connect-util.rkt +++ b/collects/db/private/generic/connect-util.rkt @@ -22,7 +22,7 @@ (loop))))) (define/public (call proc) - (thread-resume mthread) + (thread-resume mthread (current-thread)) (let ([result #f] [sema (make-semaphore 0)]) (channel-put req-channel diff --git a/collects/db/private/generic/prepared.rkt b/collects/db/private/generic/prepared.rkt index e61e2b737a..8c9ed4bffa 100644 --- a/collects/db/private/generic/prepared.rkt +++ b/collects/db/private/generic/prepared.rkt @@ -81,7 +81,7 @@ (send owner free-statement this)))) (define/public (register-finalizer) - (thread-resume finalizer-thread) + (thread-resume finalizer-thread (current-thread)) (will-register will-executor this (lambda (pst) (send pst finalize)))) (super-new) diff --git a/collects/tests/db/all-tests.rkt b/collects/tests/db/all-tests.rkt index 6b49295867..42b1d03fe6 100644 --- a/collects/tests/db/all-tests.rkt +++ b/collects/tests/db/all-tests.rkt @@ -114,6 +114,9 @@ Testing profiles are flattened, not hierarchical. ;; ---- +;; Set below by command-line parsing +(define kill-safe? #f) + (define (dbconf->unit x) (match x [(dbconf dbtestname (and r (data-source connector _args exts))) @@ -219,6 +222,7 @@ Testing profiles are flattened, not hierarchical. (command-line #:once-each [("--gui") "Run tests in RackUnit GUI" (set! gui? #t)] + [("-k" "--killsafe") "Wrap with kill-safe-connection" (set! kill-safe? #t)] [("-g" "--generic") "Run generic tests" (set! include-generic? #t)] [("-s" "--sqlite3") "Run sqlite3 in-memory db tests" (set! include-sqlite? #t)] [("-f" "--config-file") file "Use configuration file" (pref-file file)] diff --git a/collects/tests/db/config.rkt b/collects/tests/db/config.rkt index 53730b70ee..434698cf6b 100644 --- a/collects/tests/db/config.rkt +++ b/collects/tests/db/config.rkt @@ -11,7 +11,8 @@ (dbtestname connect dbsys - dbflags)) + dbflags + kill-safe?)) (define-signature test^ (test)) (define-signature config^ @@ -37,7 +38,8 @@ (define NOISY? #f) (define (connect-for-test) - (connect)) + (cond [kill-safe? (kill-safe-connection (connect))] + [else (connect)])) (define test-data '((0 "nothing") diff --git a/collects/tests/db/db/connection.rkt b/collects/tests/db/db/connection.rkt index 2e9c52d5be..77ba036012 100644 --- a/collects/tests/db/db/connection.rkt +++ b/collects/tests/db/db/connection.rkt @@ -1,8 +1,10 @@ #lang racket/unit (require (for-syntax racket/base) + racket/class rackunit "../config.rkt" - db/base) + db/base + (only-in db/private/generic/interfaces locking%)) (import config^ database^) (export test^) @@ -30,22 +32,33 @@ (check-true (dbsystem? sys)) (check-pred symbol? (dbsystem-name sys)))))) - (test-case "connected?, disconnect work w/ custodian 'damage'" + (test-case "connected?, disconnect work w/ custodian damage" (let ([c0 (current-custodian)] [c1 (make-custodian)]) (let ([cx (parameterize ((current-custodian c1)) (connect-for-test))]) - ;; cx's ports (if applicable) are controlled by c1 + ;; cx's ports (if applicable) are managed by c1 (check-true (connected? cx)) (custodian-shutdown-all c1) (check-completes (lambda () (connected? cx)) "connected?") (when (memq dbsys '(mysql postgresql)) + ;; wire-based connection is disconnected; it had better know it (check-false (connected? cx))) - (check-completes (lambda () (disconnect cx)) "disconnect")))) + (check-completes (lambda () (disconnect cx)) "disconnect") + (check-false (connected? cx))))) - ;; FIXME: Still need to test the disconnect works on cx left locked - ;; because of kill-thread (currently probably doesn't for sqlite3,odbc). - ;; ie: "connected?, disconnect work w/ kill-thread 'damage'" + (test-case "connected?, disconnect work w/ kill-thread damage" + (let ([cx (connect-for-test)]) + (when (is-a? cx locking%) + (check-true (connected? cx)) + (let ([thd + (thread + (lambda () + (send cx call-with-lock 'test (lambda () (sync never-evt)))))]) + (kill-thread thd) + (check-completes (lambda () (connected? cx)) "connected?") + (check-completes (lambda () (disconnect cx)) "disconnect") + (check-false (connected? cx)))))) )) (define TIMEOUT 2) ;; seconds diff --git a/collects/tests/db/db/sql-types.rkt b/collects/tests/db/db/sql-types.rkt index ed5aa436bc..402de55fb4 100644 --- a/collects/tests/db/db/sql-types.rkt +++ b/collects/tests/db/db/sql-types.rkt @@ -212,12 +212,13 @@ (check-roundtrip c 0) (check-roundtrip c 10) (check-roundtrip c -5) - (check-roundtrip c 1/2) - (check-roundtrip c 1/40) - (check-roundtrip c #e1234567890.0987654321) - (check-roundtrip c 1/10) - (check-roundtrip c 1/400000) - (check-roundtrip c 12345678901234567890) + (unless (TESTFLAGS 'odbc 'ismy) + (check-roundtrip c 12345678901234567890) + (check-roundtrip c 1/2) + (check-roundtrip c 1/40) + (check-roundtrip c #e1234567890.0987654321) + (check-roundtrip c 1/10) + (check-roundtrip c 1/400000)) (when (supported? 'numeric-infinities) (check-roundtrip c +nan.0))))))