db: fixed kill-safe-connection, improved tests

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

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)

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)]

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")

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

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))))))