diff --git a/collects/db/private/generic/connect-util.rkt b/collects/db/private/generic/connect-util.rkt index 9dc8cda696..6d4074fbcc 100644 --- a/collects/db/private/generic/connect-util.rkt +++ b/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) diff --git a/collects/db/private/generic/functions.rkt b/collects/db/private/generic/functions.rkt index 25fbbbad61..d5bd0e8f20 100644 --- a/collects/db/private/generic/functions.rkt +++ b/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* diff --git a/collects/db/private/generic/interfaces.rkt b/collects/db/private/generic/interfaces.rkt index 8dd09def6c..9ac8eaf7c9 100644 --- a/collects/db/private/generic/interfaces.rkt +++ b/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 diff --git a/collects/db/private/mysql/connection.rkt b/collects/db/private/mysql/connection.rkt index a1fa843c93..78848a4d99 100644 --- a/collects/db/private/mysql/connection.rkt +++ b/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 () diff --git a/collects/db/private/odbc/connection.rkt b/collects/db/private/odbc/connection.rkt index 6dc463463a..b96ef2f293 100644 --- a/collects/db/private/odbc/connection.rkt +++ b/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)) diff --git a/collects/db/private/postgresql/connection.rkt b/collects/db/private/postgresql/connection.rkt index ded03dffc6..fbd65cfa2b 100644 --- a/collects/db/private/postgresql/connection.rkt +++ b/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 diff --git a/collects/db/private/sqlite3/connection.rkt b/collects/db/private/sqlite3/connection.rkt index d2a72db847..3fb1c65d80 100644 --- a/collects/db/private/sqlite3/connection.rkt +++ b/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)]) diff --git a/collects/tests/db/db/query.rkt b/collects/tests/db/db/query.rkt index 5b267f2912..0d7038380d 100644 --- a/collects/tests/db/db/query.rkt +++ b/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))