db: fixed virtual-statement

Eliminated interface test (shallow) in favor of method test
(correct, recursive). Also made vstmts work with virtual-connections.

collects/db/private/generic/connect-util.rkt

@@ -61,6 +61,7 @@
       (get-dbsystem)
       (query fsym stmt)
       (prepare fsym stmt close-on-exec?)
+      (get-base)
       (free-statement stmt)
       (transaction-status fsym)
       (start-transaction fsym isolation)
@@ -80,7 +81,7 @@
 ;; Virtual connection
 
 (define virtual-connection%
-  (class* object% (connection<%> no-cache-prepare<%>)
+  (class* object% (connection<%>)
     (init-private connector     ;; called from client thread
                   get-key       ;; called from client thread
                   timeout)
@@ -178,6 +179,9 @@
       (#f #f     (transaction-status fsym))
       (#t '_     (list-tables fsym schema)))
 
+    (define/public (get-base)
+      (get-connection #t))
+
     (define/public (disconnect)
       (let ([c (get-connection #f)]
             [key (get-key)])
@@ -187,7 +191,8 @@
       (void))
 
     (define/public (prepare fsym stmt close-on-exec?)
-      (unless close-on-exec?
+      ;; FIXME: hacky way of supporting virtual-statement
+      (unless (or close-on-exec? (eq? fsym 'virtual-statement))
         (error fsym "cannot prepare statement with virtual connection"))
       (send (get-connection #t) prepare fsym stmt close-on-exec?))
 
@@ -329,6 +334,7 @@
       (get-dbsystem)
       (query fsym stmt)
       (prepare fsym stmt close-on-exec?)
+      (get-base)
       (free-statement stmt)
       (transaction-status fsym)
       (start-transaction fsym isolation)

collects/db/private/generic/functions.rkt

@@ -63,14 +63,16 @@
 (struct virtual-statement (table gen)
         #:property prop:statement
         (lambda (stmt c)
-          (let ([table (virtual-statement-table stmt)]
-                [gen (virtual-statement-gen stmt)]
-                [cache? (not (is-a? c no-cache-prepare<%>))])
-            (let ([table-pst (hash-ref table c #f)])
+          (let* ([table (virtual-statement-table stmt)]
+                 [gen (virtual-statement-gen stmt)]
+                 [base-c (send c get-base)])
+            (let ([table-pst (and base-c (hash-ref table base-c #f))])
               (or table-pst
                   (let* ([sql-string (gen (send c get-dbsystem))]
-                         [pst (prepare1 'virtual-statement c sql-string (not cache?))])
-                    (when cache? (hash-set! table c pst))
+                         ;; FIXME: virtual-connection:prepare1 handles
+                         ;; fsym = 'virtual-statement case specially
+                         [pst (prepare1 'virtual-statement c sql-string #f)])
+                    (hash-set! table base-c pst)
                     pst))))))
 
 (define virtual-statement*

collects/db/private/generic/interfaces.rkt

@@ -13,8 +13,6 @@
 
          define-type-table
 
-         no-cache-prepare<%>
-
          locking%
          transactions%
 
@@ -41,21 +39,12 @@
     get-dbsystem  ;; -> dbsystem<%>
     query         ;; symbol statement -> QueryResult
     prepare       ;; symbol preparable boolean -> prepared-statement<%>
-
+    get-base      ;; -> connection<%> or #f (#f means base isn't fixed)
+    list-tables   ;; symbol symbol -> (listof string)
     start-transaction  ;; symbol (U 'serializable ...) -> void
     end-transaction    ;; symbol (U 'commit 'rollback) -> void
     transaction-status ;; symbol -> (U boolean 'invalid)
-
-    list-tables ;; symbol symbol -> (listof string)
-
-    free-statement)) ;; prepared-statement<%> -> void
-
-;; no-cache-prepare<%>
-;; Interface to identify connections such as connection-generators:
-;; prepare method must be called with close-on-exec? = #t and result must
-;; not be cached.
-(define no-cache-prepare<%>
-  (interface ()))
+    free-statement))   ;; prepared-statement<%> -> void
 
 ;; ==== DBSystem
 

collects/db/private/mysql/connection.rkt

@@ -356,6 +356,8 @@
           [(? field-packet?)
            (cons (parse-field-dvec r) (prepare1:get-field-descriptions fsym))])))
 
+    (define/public (get-base) this)
+
     (define/public (free-statement pst)
       (call-with-lock* 'free-statement
         (lambda ()

collects/db/private/odbc/connection.rkt

@@ -452,6 +452,8 @@
               (void)))))
       (call-with-lock* 'disconnect go go #f))
 
+    (define/public (get-base) this)
+
     (define/public (free-statement pst)
       (define (go) (free-statement* 'free-statement pst))
       (call-with-lock* 'free-statement go go #f))

collects/db/private/postgresql/connection.rkt

@@ -403,6 +403,8 @@
         (set! name-counter (add1 name-counter))
         (format "λmz_~a_~a" process-id n)))
 
+    (define/public (get-base) this)
+
     ;; free-statement : prepared-statement -> void
     (define/public (free-statement pst)
       (call-with-lock* 'free-statement

collects/db/private/sqlite3/connection.rkt

@@ -165,6 +165,8 @@
             (void))))
       (call-with-lock* 'disconnect go go #f))
 
+    (define/public (get-base) this)
+
     (define/public (free-statement pst)
       (define (go)
         (let ([stmt (send pst get-handle)])

collects/tests/db/db/query.rkt

@@ -276,6 +276,30 @@
         (check-equal? (query-value c (select-val "17"))
                       (if (TESTFLAGS 'odbc 'issl) "17" 17))))))
 
+(define virtual-statement-tests
+  (let ()
+    (define (check-prep-once mk-connection)
+      (let* ([counter 0]
+             [c (mk-connection)]
+             [vstmt (virtual-statement
+                     (lambda (dbsys)
+                       (set! counter (add1 counter))
+                       (select-val "17")))])
+        (query-value c vstmt)
+        (check-equal? counter 1 "first query")
+        (query-value c vstmt)
+        (check-equal? counter 1 "second query")
+        (disconnect c)))
+    (test-suite "virtual-statements"
+      (test-case "prep once"
+        (check-prep-once connect-and-setup))
+      (test-case "prep once for virtual-connection"
+        (check-prep-once
+         (lambda () (virtual-connection connect-and-setup))))
+      (test-case "prep once for virtual-connection/pool"
+        (check-prep-once
+         (lambda () (virtual-connection (connection-pool connect-and-setup))))))))
+
 (define test
   (test-suite "query API"
     (simple-tests 'string)
@@ -284,4 +308,5 @@
     (simple-tests 'gen)
     low-level-tests
     misc-tests
+    virtual-statement-tests
     error-tests))