From dba35c311648a1b6b71cead7d34f871d5ef1ddf7 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sat, 31 Dec 2011 01:47:03 -0700 Subject: [PATCH] db: added nested transactions --- collects/db/TODO | 27 ++ collects/db/private/generic/connect-util.rkt | 12 +- collects/db/private/generic/functions.rkt | 24 +- collects/db/private/generic/interfaces.rkt | 240 +++++++++++++++++- collects/db/private/generic/place-client.rkt | 8 +- collects/db/private/generic/place-server.rkt | 4 +- collects/db/private/generic/prepared.rkt | 7 +- collects/db/private/mysql/connection.rkt | 126 ++++----- collects/db/private/mysql/dbsystem.rkt | 41 ++- collects/db/private/odbc/connection.rkt | 110 ++++---- collects/db/private/odbc/dbsystem.rkt | 34 ++- collects/db/private/postgresql/connection.rkt | 155 +++++------ collects/db/private/postgresql/dbsystem.rkt | 35 ++- collects/db/private/sqlite3/connection.rkt | 101 ++++---- collects/db/private/sqlite3/dbsystem.rkt | 25 +- collects/db/scribblings/connect.scrbl | 24 +- collects/db/scribblings/query.scrbl | 139 ++++++---- collects/tests/db/all-tests.rkt | 6 +- collects/tests/db/db/query.rkt | 192 +++++++++++++- collects/tests/db/gen/misc.rkt | 19 ++ 20 files changed, 974 insertions(+), 355 deletions(-) create mode 100644 collects/tests/db/gen/misc.rkt diff --git a/collects/db/TODO b/collects/db/TODO index 1c31fcc149..2a282d5855 100644 --- a/collects/db/TODO +++ b/collects/db/TODO @@ -78,3 +78,30 @@ Misc - sqlite3: sqlite3_last_insert_rowid(), use sqlite3_changes() to see if insert succeeded, but still need to tell if stmt was even insert (parse sql?) - odbc: ??? + +- add recursive locking? + - cons: - considered by experts to be bad design, sloppy + - pros: - would simplify cleanup for one-shot pstmts + - would enable simple impl of user-level 'call-with-lock' for grouping + multiple operations together + (but this could also be done by two locks: outer "ownership" lock + and inner "invariant-protecting" lock) + +- audit code for break-safety, disable breaks as needed + +- dialect info for ODBC + - can get some tx data from ODBC... + - on the other hand, not supposed to do tx-SQL in ODBC anyway, so low-priority + +- postgresql query path optimizations + - once all types have binary readers... + - can eliminate prepare step when args given (use unnamed statement) + - then, can remember what SQL in unnamed statement, avoid re-parse + +- mysql, sqlite3, odbc query path optimization + - can do something similar, but messier because no unnamed statement + - might make close-on-exec? obsolete + - add sql field to pstmt%, add sql=>pstmt hash in connection (update on pstmt finalize) + - use as stmt cache, avoid re-prepare + - sql field would be good for eventually implementing cursors, too + - PROBLEM: if schema changes, may invalidate pstmt, change types, etc diff --git a/collects/db/private/generic/connect-util.rkt b/collects/db/private/generic/connect-util.rkt index 87d23a0523..6907ae3d2b 100644 --- a/collects/db/private/generic/connect-util.rkt +++ b/collects/db/private/generic/connect-util.rkt @@ -67,8 +67,8 @@ (get-base) (free-statement stmt) (transaction-status fsym) - (start-transaction fsym isolation) - (end-transaction fsym mode) + (start-transaction fsym isolation cwt?) + (end-transaction fsym mode cwt?) (list-tables fsym schema)) (super-new))) @@ -177,8 +177,8 @@ (#f #f (connected?)) (#t '_ (get-dbsystem)) (#t '_ (query fsym stmt)) - (#t '_ (start-transaction fsym isolation)) - (#f (void) (end-transaction fsym mode)) + (#t '_ (start-transaction fsym isolation cwt?)) + (#f (void) (end-transaction fsym mode cwt?)) (#f #f (transaction-status fsym)) (#t '_ (list-tables fsym schema))) @@ -340,8 +340,8 @@ (get-base) (free-statement stmt) (transaction-status fsym) - (start-transaction fsym isolation) - (end-transaction fsym mode) + (start-transaction fsym isolation cwt?) + (end-transaction fsym mode cwt?) (list-tables fsym schema)) ;; (define-forward define/override (connected?)) diff --git a/collects/db/private/generic/functions.rkt b/collects/db/private/generic/functions.rkt index 54527bbe0e..e8b448ea10 100644 --- a/collects/db/private/generic/functions.rkt +++ b/collects/db/private/generic/functions.rkt @@ -253,13 +253,22 @@ ;; ======================================== (define (start-transaction c #:isolation [isolation #f]) - (send c start-transaction 'start-transaction isolation)) + (send c start-transaction 'start-transaction isolation #f)) (define (commit-transaction c) - (send c end-transaction 'commit-transaction 'commit)) + (send c end-transaction 'commit-transaction 'commit #f)) (define (rollback-transaction c) - (send c end-transaction 'rollback-transaction 'rollback)) + (send c end-transaction 'rollback-transaction 'rollback #f)) + +(define (call-with-transaction c proc #:isolation [isolation #f]) + (send c start-transaction '|call-with-transaction (start)| isolation #t) + (with-handlers ([(lambda (e) #t) + (lambda (e) + (send c end-transaction '|call-with-transaction (rollback)| 'rollback #t) + (raise e))]) + (begin0 (call-with-continuation-barrier proc) + (send c end-transaction '|call-with-transaction (commit)| 'commit #t)))) (define (in-transaction? c) (and (send c transaction-status 'in-transaction?) #t)) @@ -267,15 +276,6 @@ (define (needs-rollback? c) (eq? (send c transaction-status 'needs-rollback?) 'invalid)) -(define (call-with-transaction c proc #:isolation [isolation #f]) - (send c start-transaction 'call-with-transaction isolation) - (begin0 (with-handlers ([(lambda (e) #t) - (lambda (e) - (send c end-transaction 'call-with-transaction 'rollback) - (raise e))]) - (proc)) - (send c end-transaction 'call-with-transaction 'commit))) - ;; ======================================== ;; list-tables : ... -> (listof string) diff --git a/collects/db/private/generic/interfaces.rkt b/collects/db/private/generic/interfaces.rkt index 73af6fba0f..ec6e534b65 100644 --- a/collects/db/private/generic/interfaces.rkt +++ b/collects/db/private/generic/interfaces.rkt @@ -1,5 +1,6 @@ #lang racket/base (require racket/class + racket/string ffi/unsafe/atomic) (provide connection<%> dbsystem<%> @@ -18,6 +19,8 @@ transactions% isolation-symbol->string + make-sql-classifier + sql-skip-comments hex-string->bytes @@ -42,8 +45,11 @@ 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 + + ;; in start-tx and end-tx, the final boolean arg indicates whether the + ;; transaction is managed manually (#f) or by call-with-tx (#t) + start-transaction ;; symbol (U 'serializable ...) boolean -> void + end-transaction ;; symbol (U 'commit 'rollback) boolean -> void transaction-status ;; symbol -> (U boolean 'invalid) free-statement)) ;; prepared-statement<%> -> void @@ -279,13 +285,178 @@ (define transactions% (class locking% + (inherit call-with-lock) + + #| + A transaction created via SQL is "unmanaged". + A transaction created via start-tx, call-with-tx is "managed". + + FIXME: eliminate distinction, if possible. + - currently: tx-stack != null means tx-status != #f + - would also like: tx-stack = null iff tx-status = #f + |# + ;; tx-status : #f, #t, 'invalid (field [tx-status #f]) + ;; tx-stack : (list (cons string boolean) ... (cons #f boolean) + ;; Represents the "managed" transaction stack. + (field [tx-stack null]) + ;; check-valid-tx-status : symbol -> void (define/public (check-valid-tx-status fsym) (when (eq? tx-status 'invalid) - (uerror fsym "current transaction is invalid and must be explicitly rolled back"))) + (uerror fsym "current transaction is invalid"))) + + ;; ---- + + (define/public (transaction-status fsym) + (call-with-lock fsym (lambda () tx-status))) + + ;; transaction-nesting : -> (U #f 'unmanaged 'top-level 'nested) + (define/public (transaction-nesting) + (cond [(eq? tx-status #f) #f] + [(null? tx-stack) 'unmanaged] + [(null? (cdr tx-stack)) 'top-level] + [else 'nested])) + + (define/public (tx-state->string) + (string-append (case (transaction-nesting) + ((#f) "not in transaction") + ((unmanaged) "in unmanaged transaction") + ((top-level nested) "in managed transaction")) + (let ([savepoints (filter string? (map car tx-stack))]) + (if (pair? savepoints) + (string-append "; savepoints: " + (string-join savepoints ", ")) + "")))) + + ;; ---- + + (define/public (start-transaction fsym isolation cwt?) + (call-with-lock fsym + (lambda () + (check-valid-tx-status fsym) + (cond [(not tx-status) + (start-transaction* fsym isolation) + (set! tx-stack (list (cons #f cwt?)))] + [else ;; in transaction + (unless (eq? isolation #f) + (error fsym "invalid isolation level for nested transaction: ~e" isolation)) + (let ([savepoint (start-transaction* fsym 'nested)]) + (set! tx-stack (cons (cons savepoint cwt?) tx-stack)))]))) + (void)) + + (define/public (start-transaction* fsym isolation) + ;; returns string (savepoint name) if isolation = 'nested, #f otherwise + (error/internal fsym "not implemented")) + + (define/public (end-transaction fsym mode cwt?) + (call-with-lock fsym + (lambda () + (unless (eq? mode 'rollback) + ;; PostgreSQL: otherwise COMMIT statement would cause silent ROLLBACK! + (check-valid-tx-status fsym)) + (define tx-stack* + (cond [(and (eq? mode 'rollback) cwt?) + ;; Need to rollback any open start-tx transactions within call-with-tx. + ;; No need to complain, because cwt/rollback means exn already raised, + ;; either by thunk or commit attempt. + (let loop ([tx-stack* tx-stack]) + (cond [(pair? tx-stack*) + (if (cdar tx-stack*) + tx-stack* + (loop (cdr tx-stack*)))] + [else + (error/internal "unmatched end of call-with-transaction")]))] + [else tx-stack])) + (cond [(pair? tx-stack*) + (let ([savepoint (caar tx-stack*)] + [saved-cwt? (cdar tx-stack*)]) + (unless (eq? saved-cwt? cwt?) + (case saved-cwt? + ((#f) ;; saved-cwt = #f, cwt = #t + (error/unclosed-tx fsym mode #t)) + ((#t) ;; saved-cwt = #t, cwt = #f: possible + (error/unbalanced-tx fsym mode #t)))) + (end-transaction* fsym mode savepoint) + (set! tx-stack (cdr tx-stack*)))] + [else ;; not in managed transaction + (when #f ;; DISABLED! + #| + FIXME: Unmatched {commit,rollback}-transaction should + probably be illegal outside of transaction for consistency + with requirements within call-with-tx. But that would break + backwards compatibility, so disabled. + |# + (error/unbalanced-tx fsym mode #f)) + (when tx-status + ;; Allow closing unmanaged transaction + (end-transaction* fsym mode #f))]) + (void)))) + + (define/public (end-transaction* fsym mode savepoint) + (error/internal fsym "not implemented")) + + ;; check-statement/tx-status : symbol symbol/#f -> void + ;; Used to check whether SQL command is allowed given managed tx status. + (define/public (check-statement/tx fsym stmt-type) + #| + Nested transaction safety + + For simplicity, we put rules for all statement types here, including + non-standard statements. FIXME: need to decouple eventually. + + if in "unmanaged" top-level transaction + - allow all SQL commands (but restrict tx functions) + - yes, even implicit-commit + + if in "managed" top-level transaction (no "managed" savepoints): + - START not allowed + - COMMIT, ROLLBACK not allowed (for now!) + - SAVEPOINT allowed + - RELEASE TO, ROLLBACK TO allowed + - implicit-commit not allowed + + if in nested "managed" transaction (impl as "managed" savepoint): + - START not allowed + - COMMIT, ROLLBACK not allowed + - SAVEPOINT not allowed -- because it could not be used; see next + - RELEASE TO, ROLLBACK TO not allowed -- because it may cross nesting levels + - implicit-commit now allowed + |# + + (define (no! why) + (error fsym "~a not allowed~a" + (or (statement-type->string stmt-type) + (case stmt-type + ((implicit-commit) "statement with implicit commit") + (else "unknown"))) + (or why ""))) + + (case (transaction-nesting) + ((#f) + (void)) + ((unmanaged) + (void)) + ((top-level) + (case stmt-type + ((start) + (no! " within transaction")) + ((commit rollback + implicit-commit) + (no! " within managed transaction")) + (else (void)))) + ((nested) + (case stmt-type + ((start) + (no! " within transaction")) + ((commit rollback + savepoint prepare-transaction + release-savepoint rollback-savepoint + implicit-commit) + (no! " in managed transaction")) + (else (void)))))) (super-new))) @@ -303,6 +474,57 @@ ;; ---------------------------------------- +;; Simple SQL "parsing" (just classification) + +(define (make-sql-classifier table-spec + #:hash-comments? [hash-comments? #f]) + (define (make-sql-regexp stmt-str) + ;; eg, turns "alter table" into #px"^[[:space:]]*(?i:alter)[[:space:]](?i:table)" + ;; FIXME/TODO: comments (need real tokenizer; keep regexps as fast path?) + (pregexp + (apply string-append + "^" + (for/list ([piece (in-list (regexp-split #rx" " stmt-str))]) + (format "[[:space:]]*(?i:~a)(?i:[[:space:]]|$)" piece))))) + (define classifier-table + (for/list ([rule-spec (in-list table-spec)]) + (cons (make-sql-regexp (car rule-spec)) (cadr rule-spec)))) + (lambda (str [start 0]) + (let ([start (sql-skip-comments str start #:hash-comments? hash-comments?)]) + (for/first ([rule (in-list classifier-table)] + #:when (regexp-match? (car rule) str start)) + (cdr rule))))) + +;; sql-skip-comments : string nat -> nat +(define (sql-skip-comments str start #:hash-comments? [hash-comments? #f]) + (define dash-rx #px"^[[:space:]]*-- [^\n\r]*(?:[\n\r]|$)") + (define sh-like-rx #px"^[[:space:]]*#[^\n\r]*(?:[\n\r]|$)") + (define c-like-rx #px"^[[:space:]]*/\\*(?:[^\\*]|\\*[^/])*\\*/") + (let loop ([start start]) + (cond [(or (regexp-match-positions dash-rx str start) + (regexp-match-positions c-like-rx str start) + (and hash-comments? + (regexp-match-positions sh-like-rx str start))) + => (lambda (pl) (loop (cdar pl)))] + [else start]))) + +;; statement-type->string : symbol -> string/#f +(define (statement-type->string stmt-type) + (case stmt-type + ;; standard + ((start) "START TRANSACTION") + ((commit) "COMMIT") + ((rollback) "ROLLBACK") + ((savepoint) "SAVEPOINT") + ((release-savepoint) "RELEASE SAVEPOINT") + ((rollback-savepoint) "ROLLBACK TO SAVEPOINT") + ;; postgresql extensions + ((prepare-transaction) "PREPARE TRANSACTION") + ;; unknown + (else #f))) + +;; ---------------------------------------- + ;; Passwords #| @@ -382,7 +604,6 @@ producing plain old exn:fail. error/comm error/hopeless error/unsupported-type - error/already-in-tx error/no-convert) ;;(define uerror raise-user-error) @@ -410,9 +631,14 @@ producing plain old exn:fail. (uerror fsym "unsupported type: ~a (typeid ~a)" type typeid) (uerror fsym "unsupported type: (typeid ~a)" typeid))) -(define (error/already-in-tx fsym) - (uerror fsym "already in transaction")) - (define (error/no-convert fsym sys type param [note #f]) (uerror fsym "cannot convert to ~a ~a type~a~a: ~e" sys type (if note " " "") (or note "") param)) + +(define (error/unbalanced-tx fsym mode saved-cwt?) + (error fsym "~a-transaction without matching start-transaction~a" + mode (if saved-cwt? " (within the extent of call-with-transaction)" ""))) + +(define (error/unclosed-tx fsym mode saved-cwt?) + (error fsym "unclosed nested transaction~a" + (if saved-cwt? " (within extent of call-with-transaction)" ""))) diff --git a/collects/db/private/generic/place-client.rkt b/collects/db/private/generic/place-client.rkt index 13e226ca15..9f373a0fd3 100644 --- a/collects/db/private/generic/place-client.rkt +++ b/collects/db/private/generic/place-client.rkt @@ -74,10 +74,10 @@ (call 'prepare fsym stmt close-on-exec?)) (define/public (transaction-status fsym) (call 'transaction-status fsym)) - (define/public (start-transaction fsym iso) - (call 'start-transaction fsym iso)) - (define/public (end-transaction fsym mode) - (call 'end-transaction fsym mode)) + (define/public (start-transaction fsym iso cwt?) + (call 'start-transaction fsym iso cwt?)) + (define/public (end-transaction fsym mode cwt?) + (call 'end-transaction fsym mode cwt?)) (define/public (list-tables fsym schema) (call 'list-tables fsym schema)) diff --git a/collects/db/private/generic/place-server.rkt b/collects/db/private/generic/place-server.rkt index c758bebe4d..dc41571bce 100644 --- a/collects/db/private/generic/place-server.rkt +++ b/collects/db/private/generic/place-server.rkt @@ -109,8 +109,8 @@ server -> client: (or (list 'values result ...) (forward-methods (connected?) (prepare w s m) (list-tables w s) - (start-transaction w m) - (end-transaction w m) + (start-transaction w m c) + (end-transaction w m c) (transaction-status w))])) (lambda results (let ([results (for/list ([result (in-list results)]) (result->sexpr result))]) diff --git a/collects/db/private/generic/prepared.rkt b/collects/db/private/generic/prepared.rkt index e70f033467..f965a73e97 100644 --- a/collects/db/private/generic/prepared.rkt +++ b/collects/db/private/generic/prepared.rkt @@ -8,11 +8,12 @@ ;; prepared-statement% (define prepared-statement% (class* object% (prepared-statement<%>) + (init ([-owner owner])) (init-field handle ;; handle, determined by database system, #f means closed close-on-exec? ;; boolean param-typeids ;; (listof typeid) - result-dvecs) ;; (listof vector), layout depends on dbsys - (init ([-owner owner])) + result-dvecs ;; (listof vector), layout depends on dbsys + [stmt-type #f]) ;; usually symbol or #f (see classify-*-sql) (define owner (make-weak-box -owner)) (define dbsystem (send -owner get-dbsystem)) @@ -39,6 +40,8 @@ (define/public (get-result-types) (send dbsystem describe-typeids result-typeids)) + (define/public (get-stmt-type) stmt-type) + ;; checktype is either #f, 'rows, or exact-positive-integer (define/public (check-results fsym checktype obj) (cond [(eq? checktype 'rows) diff --git a/collects/db/private/mysql/connection.rkt b/collects/db/private/mysql/connection.rkt index 09d9226232..0c7e7d1180 100644 --- a/collects/db/private/mysql/connection.rkt +++ b/collects/db/private/mysql/connection.rkt @@ -24,7 +24,8 @@ (inherit call-with-lock call-with-lock* add-delayed-call! - check-valid-tx-status) + check-valid-tx-status + check-statement/tx) (inherit-field tx-status) (super-new) @@ -38,12 +39,10 @@ ;; == Debugging - (define DEBUG-RESPONSES #f) - (define DEBUG-SENT-MESSAGES #f) + (define DEBUG? #f) - (define/public (debug incoming? [outgoing? incoming?]) - (set! DEBUG-RESPONSES incoming?) - (set! DEBUG-SENT-MESSAGES outgoing?)) + (define/public (debug debug?) + (set! DEBUG? debug?)) ;; ======================================== @@ -62,7 +61,7 @@ ;; buffer-message : message -> void (define/private (buffer-message msg) - (when DEBUG-SENT-MESSAGES + (when DEBUG? (fprintf (current-error-port) " >> ~s\n" msg)) (with-disconnect-on-error (write-packet outport msg next-msg-num) @@ -93,7 +92,7 @@ (error/comm fsym)) (let-values ([(msg-num next) (parse-packet inport expectation field-dvecs)]) (set! next-msg-num (add1 msg-num)) - (when DEBUG-RESPONSES + (when DEBUG? (eprintf " << ~s\n" next)) ;; Update transaction status (see Transactions below) (when (ok-packet? next) @@ -145,7 +144,7 @@ (define/private (disconnect* lock-not-held?) (define (go politely?) - (when DEBUG-SENT-MESSAGES + (when DEBUG? (eprintf " ** Disconnecting\n")) (let ([outport* outport] [inport* inport]) @@ -258,18 +257,22 @@ ;; == Query - ;; name-counter : number - (define name-counter 0) - ;; query : symbol Statement -> QueryResult (define/public (query fsym stmt) (check-valid-tx-status fsym) (let*-values ([(stmt result) (call-with-lock fsym (lambda () - (let ([stmt (check-statement fsym stmt)]) + (let* ([stmt (check-statement fsym stmt)] + [stmt-type + (cond [(statement-binding? stmt) + (send (statement-binding-pst stmt) get-stmt-type)] + [(string? stmt) + (classify-my-sql stmt)])]) + (check-statement/tx fsym stmt-type) (values stmt (query1 fsym stmt #t)))))]) - ;; For some reason, *really* slow: (statement:after-exec stmt) + (when #f ;; DISABLED---for some reason, *really* slow + (statement:after-exec stmt)) (query1:process-result fsym result))) ;; query1 : symbol Statement -> QueryResult @@ -373,6 +376,7 @@ (close-on-exec? close-on-exec?) (param-typeids (map field-dvec->typeid param-dvecs)) (result-dvecs field-dvecs) + (stmt-type (classify-my-sql stmt)) (owner this)))]))) (define/private (prepare1:get-field-descriptions fsym) @@ -425,33 +429,41 @@ ;; - transaction deadlock = 1213 (ER_LOCK_DEADLOCK) ;; - lock wait timeout (depends on config) = 1205 (ER_LOCK_WAIT_TIMEOUT) - (define/public (transaction-status fsym) - (call-with-lock fsym (lambda () tx-status))) + (define/override (start-transaction* fsym isolation) + (cond [(eq? isolation 'nested) + (let ([savepoint (generate-name)]) + (query1 fsym (format "SAVEPOINT ~a" savepoint) #t) + savepoint)] + [else + (let ([isolation-level (isolation-symbol->string isolation)]) + (when isolation-level + (query1 fsym (format "SET TRANSACTION ISOLATION LEVEL ~a" isolation-level) #t)) + (query1 fsym "START TRANSACTION" #t) + #f)])) - (define/public (start-transaction fsym isolation) - (call-with-lock fsym - (lambda () - (when tx-status - (error/already-in-tx fsym)) - ;; SET TRANSACTION ISOLATION LEVEL sets mode for *next* transaction - ;; so need lock around both statements - (let* ([isolation-level (isolation-symbol->string isolation)] - [set-stmt "SET TRANSACTION ISOLATION LEVEL "]) - (when isolation-level - (query1 fsym (string-append set-stmt isolation-level) #t))) - (query1 fsym "START TRANSACTION" #t) - (void)))) + (define/override (end-transaction* fsym mode savepoint) + (case mode + ((commit) + (cond [savepoint + (query1 fsym (format "RELEASE SAVEPOINT ~a" savepoint) #t)] + [else + (query1 fsym "COMMIT" #t)])) + ((rollback) + (cond [savepoint + (query1 fsym (format "ROLLBACK TO SAVEPOINT ~a" savepoint) #t) + (query1 fsym (format "RELEASE SAVEPOINT ~a" savepoint) #t)] + [else + (query1 fsym "ROLLBACK" #t)]))) + (void)) - (define/public (end-transaction fsym mode) - (call-with-lock fsym - (lambda () - (unless (eq? mode 'rollback) - (check-valid-tx-status fsym)) - (let ([stmt (case mode - ((commit) "COMMIT") - ((rollback) "ROLLBACK"))]) - (query1 fsym stmt #t) - (void))))) + ;; name-counter : number + (define name-counter 0) + + ;; generate-name : -> string + (define/private (generate-name) + (let ([n name-counter]) + (set! name-counter (add1 name-counter)) + (format "λmz_~a" n))) ;; Reflection @@ -461,11 +473,7 @@ (string-append "SELECT table_name FROM information_schema.tables " "WHERE table_schema = schema()")] [rows - (vector-ref - (call-with-lock fsym - (lambda () - (query1 fsym stmt #t))) - 2)]) + (vector-ref (call-with-lock fsym (lambda () (query1 fsym stmt #t))) 2)]) (for/list ([row (in-list rows)]) (vector-ref row 0)))) @@ -598,34 +606,8 @@ On the other hand, we want to force all rows-returning statements through the prepared-statement path to use the binary data protocol. That would seem to be the following: - CALL (?) and SELECT - -The following bit of heinously offensive code determines the kind of -SQL statement is contained in a string. - ----- - -3 kinds of comments in mysql SQL: - - "#" to end of line - - "-- " to end of line - - "/*" to next "*/" (not nested), except some weird conditional-inclusion stuff - -I'll ignore the third kind. + SELECT and SHOW |# (define (force-prepare-sql? fsym stmt) - (let ([kw (get-sql-keyword stmt)]) - (cond [(not kw) - ;; better to have unpreparable stmt rejected than - ;; to have SELECT return unconvered types - #t] - [(string-ci=? kw "select") #t] - [(string-ci=? kw "call") #t] - [else #f]))) - -(define sql-statement-rx - #rx"^(?:(?:#[^\n\r]*[\n\r])|(?:-- [^\n\r]*[\n\r])|[ \t\n\r])*([A-Za-z]+)") - -(define (get-sql-keyword stmt) - (let ([m (regexp-match sql-statement-rx stmt)]) - (and m (cadr m)))) + (memq (classify-my-sql stmt) '(select show))) diff --git a/collects/db/private/mysql/dbsystem.rkt b/collects/db/private/mysql/dbsystem.rkt index 37cb2efa2c..de7aeac1ab 100644 --- a/collects/db/private/mysql/dbsystem.rkt +++ b/collects/db/private/mysql/dbsystem.rkt @@ -4,7 +4,8 @@ "../generic/sql-data.rkt" "../../util/private/geometry.rkt" (only-in "message.rkt" field-dvec->typeid)) -(provide dbsystem) +(provide dbsystem + classify-my-sql) (define mysql-dbsystem% (class* object% (dbsystem<%>) @@ -55,6 +56,44 @@ ;; ======================================== +;; SQL "parsing" +;; We care about: +;; - determining whether commands must be prepared (to use binary data) +;; see http://dev.mysql.com/doc/refman/5.0/en/c-api-prepared-statements.html +;; - detecting commands that affect transaction status (maybe implicitly) +;; see http://dev.mysql.com/doc/refman/5.0/en/implicit-commit.html + +;; classify-my-sql : string [nat] -> symbol/#f +(define classify-my-sql + (make-sql-classifier #:hash-comments? #t + '(;; Must be prepared + ("SELECT" select) + ("SHOW" show) + + ;; Explicit transaction commands + ("ROLLBACK WORK TO" rollback-savepoint) + ("ROLLBACK TO" rollback-savepoint) + ("RELEASE SAVEPOINT" release-savepoint) + ("SAVEPOINT" savepoint) + ("START TRANSACTION" start) + ("BEGIN" start) + ("COMMIT" commit) + ("ROLLBACK" rollback) ;; Note: after ROLLBACK TO, etc + ("SET autocommit" set-autocommit) ;; trouble + ;; Note: commit/rollback may immediately start new transaction + + ;; Implicit commit + ("ALTER" implicit-commit) + ("CREATE" implicit-commit) + ("DROP" implicit-commit) + ("RENAME" implicit-commit) + ("TRUNCATE" implicit-commit) + ("LOAD" implicit-commit) + ("LOCK TABLES" implicit-commit) + ("UNLOCK TABLES" implicit-commit)))) + +;; ======================================== + (define-type-table (supported-types type-alias->type typeid->type diff --git a/collects/db/private/odbc/connection.rkt b/collects/db/private/odbc/connection.rkt index 486022f8f0..7e53cff2a7 100644 --- a/collects/db/private/odbc/connection.rkt +++ b/collects/db/private/odbc/connection.rkt @@ -42,7 +42,8 @@ (inherit call-with-lock call-with-lock* add-delayed-call! - check-valid-tx-status) + check-valid-tx-status + check-statement/tx) (inherit-field tx-status) (define/public (get-db fsym) @@ -58,12 +59,12 @@ (call-with-lock fsym (lambda () (check-valid-tx-status fsym) - (query1 fsym stmt)))]) + (query1 fsym stmt #t)))]) (statement:after-exec stmt*) (cond [(pair? dvecs) (rows-result (map field-dvec->field-info dvecs) rows)] [else (simple-result '())]))) - (define/private (query1 fsym stmt) + (define/private (query1 fsym stmt check-tx?) (let* ([stmt (cond [(string? stmt) (let* ([pst (prepare1 fsym stmt #t)]) (send pst bind fsym null))] @@ -72,6 +73,7 @@ [pst (statement-binding-pst stmt)] [params (statement-binding-params stmt)]) (send pst check-owner fsym this stmt) + (when check-tx? (check-statement/tx fsym (send pst get-stmt-type))) (let ([result-dvecs (send pst get-result-dvecs)]) (for ([dvec (in-list result-dvecs)]) (let ([typeid (field-dvec->typeid dvec)]) @@ -409,9 +411,10 @@ (let ([pst (new prepared-statement% (handle stmt) (close-on-exec? close-on-exec?) - (owner this) (param-typeids param-typeids) - (result-dvecs result-dvecs))]) + (result-dvecs result-dvecs) + (stmt-type (classify-odbc-sql sql)) + (owner this))]) (hash-set! statement-table pst #t) pst))) @@ -473,59 +476,50 @@ ;; Transactions - (define/public (transaction-status fsym) - (call-with-lock fsym - (lambda () (let ([db (get-db fsym)]) tx-status)))) + (define/override (start-transaction* fsym isolation) + (when (eq? isolation 'nested) + (uerror fsym "already in transaction (nested transactions not supported for ODBC)")) + (let* ([db (get-db fsym)] + [ok-levels + (let-values ([(status value) + (SQLGetInfo db SQL_TXN_ISOLATION_OPTION)]) + (begin0 value (handle-status fsym status db)))] + [default-level + (let-values ([(status value) + (SQLGetInfo db SQL_DEFAULT_TXN_ISOLATION)]) + (begin0 value (handle-status fsym status db)))] + [requested-level + (case isolation + ((serializable) SQL_TXN_SERIALIZABLE) + ((repeatable-read) SQL_TXN_REPEATABLE_READ) + ((read-committed) SQL_TXN_READ_COMMITTED) + ((read-uncommitted) SQL_TXN_READ_UNCOMMITTED) + (else + ;; MySQL ODBC returns 0 for default level, seems no good. + ;; So if 0, use serializable. + (if (zero? default-level) SQL_TXN_SERIALIZABLE default-level)))]) + (when (zero? (bitwise-and requested-level ok-levels)) + (uerror fsym "requested isolation level ~a is not available" isolation)) + (let ([status (SQLSetConnectAttr db SQL_ATTR_TXN_ISOLATION requested-level)]) + (handle-status fsym status db))) + (let ([status (SQLSetConnectAttr db SQL_ATTR_AUTOCOMMIT SQL_AUTOCOMMIT_OFF)]) + (handle-status fsym status db) + (set! tx-status #t) + (void))) - (define/public (start-transaction fsym isolation) - (call-with-lock fsym - (lambda () - (let* ([db (get-db fsym)]) - (when tx-status - (error/already-in-tx fsym)) - (let* ([ok-levels - (let-values ([(status value) - (SQLGetInfo db SQL_TXN_ISOLATION_OPTION)]) - (begin0 value (handle-status fsym status db)))] - [default-level - (let-values ([(status value) - (SQLGetInfo db SQL_DEFAULT_TXN_ISOLATION)]) - (begin0 value (handle-status fsym status db)))] - [requested-level - (case isolation - ((serializable) SQL_TXN_SERIALIZABLE) - ((repeatable-read) SQL_TXN_REPEATABLE_READ) - ((read-committed) SQL_TXN_READ_COMMITTED) - ((read-uncommitted) SQL_TXN_READ_UNCOMMITTED) - (else - ;; MySQL ODBC returns 0 for default level, seems no good. - ;; So if 0, use serializable. - (if (zero? default-level) SQL_TXN_SERIALIZABLE default-level)))]) - (when (zero? (bitwise-and requested-level ok-levels)) - (uerror fsym "requested isolation level ~a is not available" isolation)) - (let ([status (SQLSetConnectAttr db SQL_ATTR_TXN_ISOLATION requested-level)]) - (handle-status fsym status db))) - (let ([status (SQLSetConnectAttr db SQL_ATTR_AUTOCOMMIT SQL_AUTOCOMMIT_OFF)]) - (handle-status fsym status db) - (set! tx-status #t) - (void)))))) - - (define/public (end-transaction fsym mode) - (call-with-lock fsym - (lambda () - (unless (eq? mode 'rollback) - (check-valid-tx-status fsym)) - (let ([db (get-db fsym)] - [completion-type - (case mode - ((commit) SQL_COMMIT) - ((rollback) SQL_ROLLBACK))]) - (handle-status fsym (SQLEndTran db completion-type) db) - (let ([status (SQLSetConnectAttr db SQL_ATTR_AUTOCOMMIT SQL_AUTOCOMMIT_ON)]) - (handle-status fsym status db) - ;; commit/rollback can fail; don't change status until possible error handled - (set! tx-status #f) - (void)))))) + (define/override (end-transaction* fsym mode _savepoint) + ;; _savepoint = #f, because nested transactions not supported on ODBC + (let ([db (get-db fsym)] + [completion-type + (case mode + ((commit) SQL_COMMIT) + ((rollback) SQL_ROLLBACK))]) + (handle-status fsym (SQLEndTran db completion-type) db) + (let ([status (SQLSetConnectAttr db SQL_ATTR_AUTOCOMMIT SQL_AUTOCOMMIT_ON)]) + (handle-status fsym status db) + ;; commit/rollback can fail; don't change status until possible error handled + (set! tx-status #f) + (void)))) ;; GetTables @@ -669,7 +663,7 @@ all Racket threads for a long time. 1) The postgresql, mysql, and oracle drivers don't even support async execution. Only DB2 (and probably SQL Server, but I didn't try it). -2) Tests using the DB2 driver gave bafflind HY010 (function sequence +2) Tests using the DB2 driver gave baffling HY010 (function sequence error). My best theory so far is that DB2 (or maybe unixodbc) requires poll call arguments to be identical to original call arguments, which means that I would have to replace all uses of (_ptr o X) with diff --git a/collects/db/private/odbc/dbsystem.rkt b/collects/db/private/odbc/dbsystem.rkt index bbef44b51d..55cef323f4 100644 --- a/collects/db/private/odbc/dbsystem.rkt +++ b/collects/db/private/odbc/dbsystem.rkt @@ -4,7 +4,8 @@ "../generic/sql-data.rkt" "../generic/sql-convert.rkt") (provide dbsystem - supported-typeid?) + supported-typeid? + classify-odbc-sql) (define odbc-dbsystem% (class* object% (dbsystem<%>) @@ -28,6 +29,37 @@ ;; ---- +;; SQL "parsing" +;; We just care about detecting commands that affect transaction status. + +;; Since we have no idea what the actual database system is, just cover +;; standard commands and assume DDL is not transactional. + +;; classify-odbc-sql : string [nat] -> symbol/#f +(define classify-odbc-sql + (make-sql-classifier #:hash-comments? #t + '(;; Explicit transaction commands + ("ROLLBACK TRANSACTION TO" rollback-savepoint) + ("ROLLBACK WORK TO" rollback-savepoint) + ("ROLLBACK TO" rollback-savepoint) + ("RELEASE" release-savepoint) + ("SAVEPOINT" savepoint) + ("START" start) + ("BEGIN" start) + ("COMMIT" commit) + ("END" commit) + ("ROLLBACK" rollback) ;; Note: after ROLLBACK TO, etc + + ;; Implicit commit + ("ALTER" implicit-commit) + ("CREATE" implicit-commit) + ("DROP" implicit-commit) + ("GRANT" implicit-commit) + ("RENAME" implicit-commit) + ("TRUNCATE" implicit-commit)))) + +;; ---- + (define-syntax-rule (defchecks get-check [(typeid name pred ...) ...] [(*typeid *name *fun) ...]) (define get-check diff --git a/collects/db/private/postgresql/connection.rkt b/collects/db/private/postgresql/connection.rkt index dbdc8ea1e6..c3877cc908 100644 --- a/collects/db/private/postgresql/connection.rkt +++ b/collects/db/private/postgresql/connection.rkt @@ -33,7 +33,10 @@ (inherit call-with-lock call-with-lock* add-delayed-call! - check-valid-tx-status) + check-valid-tx-status + check-statement/tx + transaction-nesting + tx-state->string) (inherit-field tx-status) (super-new) @@ -48,12 +51,10 @@ ;; == Debugging ;; Debugging - (define DEBUG-RESPONSES #f) - (define DEBUG-SENT-MESSAGES #f) + (define DEBUG? #f) - (define/public (debug incoming? [outgoing? incoming?]) - (set! DEBUG-RESPONSES incoming?) - (set! DEBUG-SENT-MESSAGES outgoing?)) + (define/public (debug debug?) + (set! DEBUG? debug?)) ;; ======================================== @@ -64,7 +65,7 @@ (define/private (raw-recv) (with-disconnect-on-error (let ([r (parse-server-message inport)]) - (when DEBUG-RESPONSES + (when DEBUG? (fprintf (current-error-port) " << ~s\n" r)) r))) @@ -88,7 +89,7 @@ ;; buffer-message : message -> void (define/private (buffer-message msg) - (when DEBUG-SENT-MESSAGES + (when DEBUG? (fprintf (current-error-port) " >> ~s\n" msg)) (with-disconnect-on-error (write-message msg outport))) @@ -141,7 +142,7 @@ ;; disconnect* : boolean -> void (define/private (disconnect* no-lock-held?) (define (go politely?) - (when DEBUG-SENT-MESSAGES + (when DEBUG? (fprintf (current-error-port) " ** Disconnecting\n")) (let ([outport* outport] [inport* inport]) @@ -243,43 +244,55 @@ (call-with-lock fsym (lambda () (check-valid-tx-status fsym) - (query1 fsym stmt0)))]) + (let* ([stmt (check-statement fsym stmt0)] + [stmt-type (send (statement-binding-pst stmt) get-stmt-type)]) + (check-statement/tx fsym stmt-type) + (values stmt (query1 fsym stmt #f)))))]) (statement:after-exec stmt) (query1:process-result fsym result))) - (define/private (query1 fsym stmt) - (let ([stmt (check-statement fsym stmt)]) - (query1:enqueue stmt) - (send-message (make-Sync)) - (begin0 (values stmt (query1:collect fsym stmt)) - (check-ready-for-query fsym #f)))) + (define/private (query1 fsym stmt simple?) + ;; if simple?: stmt must be string, no params, & results must be binary-readable + (query1:enqueue stmt) + (send-message (make-Sync)) + (begin0 (query1:collect fsym simple?) + (check-ready-for-query fsym #f) + (when DEBUG? + (fprintf (current-error-port) " ** ~a\n" (tx-state->string))))) ;; check-statement : symbol statement -> statement-binding - ;; Always prepare, so we can have type information to choose result formats. + ;; Convert to statement-binding; need to prepare to get type information, used to + ;; choose result formats. + ;; FIXME: if text format eliminated, can skip prepare + ;; FIXME: can use classify-pg-sql to avoid preparing stmts with no results (define/private (check-statement fsym stmt) (cond [(statement-binding? stmt) (let ([pst (statement-binding-pst stmt)]) - (send pst check-owner fsym this stmt)) - stmt] + (send pst check-owner fsym this stmt) + stmt)] [(string? stmt) (let ([pst (prepare1 fsym stmt #t)]) (send pst bind fsym null))])) ;; query1:enqueue : Statement -> void (define/private (query1:enqueue stmt) - (let* ([pst (statement-binding-pst stmt)] - [pst-name (send pst get-handle)] - [params (statement-binding-params stmt)]) - (buffer-message (make-Bind "" pst-name - (map typeid->format (send pst get-param-typeids)) - params - (map typeid->format (send pst get-result-typeids))))) + (cond [(statement-binding? stmt) + (let* ([pst (statement-binding-pst stmt)] + [pst-name (send pst get-handle)] + [params (statement-binding-params stmt)]) + (buffer-message (make-Bind "" pst-name + (map typeid->format (send pst get-param-typeids)) + params + (map typeid->format (send pst get-result-typeids)))))] + [(string? stmt) + (buffer-message (make-Parse "" stmt '())) + (buffer-message (make-Bind "" "" '() '() '(1)))]) (buffer-message (make-Describe 'portal "")) (buffer-message (make-Execute "" 0)) (buffer-message (make-Close 'portal ""))) - (define/private (query1:collect fsym stmt) - (when (string? stmt) + (define/private (query1:collect fsym simple?) + (when simple? (match (recv-message fsym) [(struct ParseComplete ()) (void)] [other-r (query1:error fsym other-r)])) @@ -360,14 +373,14 @@ (let ([name (generate-name)]) (prepare1:enqueue name stmt) (send-message (make-Sync)) - (begin0 (prepare1:collect fsym name close-on-exec?) + (begin0 (prepare1:collect fsym name close-on-exec? (classify-pg-sql stmt)) (check-ready-for-query fsym #f)))) (define/private (prepare1:enqueue name stmt) (buffer-message (make-Parse name stmt null)) (buffer-message (make-Describe 'statement name))) - (define/private (prepare1:collect fsym name close-on-exec?) + (define/private (prepare1:collect fsym name close-on-exec? stmt-type) (match (recv-message fsym) [(struct ParseComplete ()) (void)] [other-r (prepare1:error fsym other-r)]) @@ -378,6 +391,7 @@ (close-on-exec? close-on-exec?) (param-typeids param-typeids) (result-dvecs field-dvecs) + (stmt-type stmt-type) (owner this)))) (define/private (prepare1:describe-params fsym) @@ -423,57 +437,52 @@ ;; == Transactions - (define/public (transaction-status fsym) - (call-with-lock fsym (lambda () tx-status))) + (define/override (start-transaction* fsym isolation) + (cond [(eq? isolation 'nested) + (let ([savepoint (generate-name)]) + (query1 fsym (format "SAVEPOINT ~a" savepoint) #t) + savepoint)] + [else + (let* ([isolation-level (isolation-symbol->string isolation)] + [stmt (if isolation-level + (string-append "BEGIN WORK ISOLATION LEVEL " isolation-level) + "BEGIN WORK")]) + ;; FIXME: also support + ;; 'read-only => "READ ONLY" + ;; 'read-write => "READ WRITE" + (query1 fsym stmt #t) + #f)])) - (define/public (start-transaction fsym isolation) - (internal-query fsym - (lambda () - (when tx-status - (error/already-in-tx fsym))) - (let ([isolation-level (isolation-symbol->string isolation)]) - ;; 'read-only => "READ ONLY" - ;; 'read-write => "READ WRITE" - (if isolation-level - (string-append "BEGIN WORK ISOLATION LEVEL " isolation-level) - "BEGIN WORK"))) - (void)) - - (define/public (end-transaction fsym mode) - (internal-query fsym - (lambda () - (unless (eq? mode 'rollback) - ;; otherwise, COMMIT statement would cause silent ROLLBACK !!! - (check-valid-tx-status fsym))) - (case mode - ((commit) "COMMIT WORK") - ((rollback) "ROLLBACK WORK"))) + (define/override (end-transaction* fsym mode savepoint) + (case mode + ((commit) + (cond [savepoint + (query1 fsym (format "RELEASE SAVEPOINT ~a" savepoint) #t)] + [else + (query1 fsym "COMMIT WORK" #t)])) + ((rollback) + (cond [savepoint + (query1 fsym (format "ROLLBACK TO SAVEPOINT ~a" savepoint) #t) + (query1 fsym (format "RELEASE SAVEPOINT ~a" savepoint) #t)] + [else + (query1 fsym "ROLLBACK WORK" #t)]))) (void)) ;; == Reflection (define/public (list-tables fsym schema) - (let* ([where-cond - (case schema - ((search search-or-current) - "table_schema = SOME (current_schemas(false))") - ((current) - "table_schema = current_schema"))] - [stmt - (string-append "SELECT table_name FROM information_schema.tables WHERE " - where-cond)] - [rows (vector-ref (internal-query fsym void stmt) 2)]) + (let* ([stmt + (string-append + "SELECT table_name FROM information_schema.tables WHERE " + (case schema + ((search search-or-current) + "table_schema = SOME (current_schemas(false))") + ((current) + "table_schema = current_schema")))] + [result (call-with-lock fsym (lambda () (query1 fsym stmt #t)))] + [rows (vector-ref result 2)]) (for/list ([row (in-list rows)]) (bytes->string/utf-8 (vector-ref row 0))))) - - (define/private (internal-query fsym pre-thunk stmt) - (let-values ([(stmt result) - (call-with-lock fsym - (lambda () - (pre-thunk) - (query1 fsym stmt)))]) - (statement:after-exec stmt) - result)) )) ;; ======================================== diff --git a/collects/db/private/postgresql/dbsystem.rkt b/collects/db/private/postgresql/dbsystem.rkt index 5692c65c7e..34015ed5d9 100644 --- a/collects/db/private/postgresql/dbsystem.rkt +++ b/collects/db/private/postgresql/dbsystem.rkt @@ -13,7 +13,8 @@ (only-in "message.rkt" field-dvec->typeid)) (provide dbsystem typeid->type-reader - typeid->format) + typeid->format + classify-pg-sql) (define postgresql-dbsystem% (class* object% (dbsystem<%>) @@ -45,6 +46,38 @@ ;; ======================================== +;; SQL "parsing" +;; We just care about detecting commands that affect transaction status. + +;; classify-pg-sql : string [nat] -> symbol/#f +(define classify-pg-sql + ;; Source: http://www.postgresql.org/docs/current/static/sql-commands.html + (make-sql-classifier + `(("ABORT" rollback) + ("BEGIN" start) + ;; COMMIT PREPARED itself is harmless. + ("COMMIT PREPARED" #f) ;; Note: before COMMIT + ("COMMIT" commit) + ("DO" *do) ;; can do anything + ("END" commit) + ("EXECUTE" *execute) ;; can do anything + ;; PREPARE TRANSACTION is like shift: it saves and aborts current transaction. + ;; Perhaps all we care about is that it ends transaction, treat like commit/rollback. + ("PREPARE TRANSACTION" prepare-transaction) ;; Note: before PREPARE + ("RELEASE SAVEPOINT" release-savepoint) + ;; For ROLLBACK variants, ordered carefully and expanded optional words + ;; ROLLBACK PREPARED just deletes saved transaction + ("ROLLBACK PREPARED" #f) + ("ROLLBACK WORK TO" rollback-savepoint) + ("ROLLBACK TRANSACTION TO" rollback-savepoint) + ("ROLLBACK TO" rollback-savepoint) + ("ROLLBACK" rollback) + ("SAVEPOINT" savepoint) + ("START TRANSACTION" start) + ))) + +;; ======================================== + ;; Derived from ;; http://www.us.postgresql.org/users-lounge/docs/7.2/postgres/datatype.html ;; and diff --git a/collects/db/private/sqlite3/connection.rkt b/collects/db/private/sqlite3/connection.rkt index c181dd5d3b..007ddc1300 100644 --- a/collects/db/private/sqlite3/connection.rkt +++ b/collects/db/private/sqlite3/connection.rkt @@ -24,11 +24,12 @@ (inherit call-with-lock* add-delayed-call! - check-valid-tx-status) - (inherit-field tx-status) ;; only #f or 'invalid for compat w/ check-valid-tx-status + check-valid-tx-status + check-statement/tx) + (inherit-field tx-status) (define/override (call-with-lock fsym proc) - (call-with-lock* fsym (lambda () (set! saved-tx-status (get-tx-status)) (proc)) #f #t)) + (call-with-lock* fsym (lambda () (set! saved-tx-status tx-status) (proc)) #f #t)) (define/private (get-db fsym) (or -db (error/not-connected fsym))) @@ -41,11 +42,11 @@ (call-with-lock fsym (lambda () (check-valid-tx-status fsym) - (query1 fsym stmt)))]) + (query1 fsym stmt #t)))]) (statement:after-exec stmt) result)) - (define/private (query1 fsym stmt) + (define/private (query1 fsym stmt check-tx?) (let* ([stmt (cond [(string? stmt) (let* ([pst (prepare1 fsym stmt #t)]) (send pst bind fsym null))] @@ -54,6 +55,7 @@ [pst (statement-binding-pst stmt)] [params (statement-binding-params stmt)]) (send pst check-owner fsym this stmt) + (when check-tx? (check-statement/tx fsym (send pst get-stmt-type))) (let ([db (get-db fsym)] [stmt (send pst get-handle)]) (HANDLE fsym (sqlite3_reset stmt)) @@ -68,18 +70,13 @@ [rows (step* fsym db stmt)]) (HANDLE fsym (sqlite3_reset stmt)) (HANDLE fsym (sqlite3_clear_bindings stmt)) + (unless (eq? tx-status 'invalid) + (set! tx-status (get-tx-status))) (values stmt (cond [(pair? info) (rows-result info rows)] [else - (let ([changes (sqlite3_changes db)]) - (cond [(and (positive? changes) - #f ;; Note: currently disabled - #| FIXME: statement was INSERT stmt |#) - (simple-result - (list (cons 'last-insert-rowid - (sqlite3_last_insert_rowid db))))] - [else (simple-result '())]))])))))) + (simple-result '())])))))) (define/private (load-param fsym db stmt i param) (HANDLE fsym @@ -155,6 +152,7 @@ (close-on-exec? close-on-exec?) (param-typeids param-typeids) (result-dvecs result-dvecs) + (stmt-type (classify-sl-sql sql)) (owner this))]) (hash-set! statement-table pst #t) pst))) @@ -194,49 +192,46 @@ ;; http://www.sqlite.org/lang_transaction.html - (define/public (transaction-status fsym) - (call-with-lock fsym - (lambda () - (let ([db (get-db fsym)]) - (or tx-status (get-tx-status db)))))) + (define/private (get-tx-status) + (not (sqlite3_get_autocommit -db))) - (define/private (get-tx-status [db -db]) - (and db (not (sqlite3_get_autocommit db)))) - - (define/public (start-transaction fsym isolation) + (define/override (start-transaction* fsym isolation) ;; Isolation level can be set to READ UNCOMMITTED via pragma, but ;; ignored in all but a few cases, don't bother. ;; FIXME: modes are DEFERRED | IMMEDIATE | EXCLUSIVE - (let ([stmt - (call-with-lock fsym - (lambda () - (let ([db (get-db fsym)]) - (when (get-tx-status db) - (error/already-in-tx fsym)) - (let-values ([(stmt* _result) - (query1 fsym "BEGIN TRANSACTION")]) - stmt*))))]) - (statement:after-exec stmt) - (void))) + (cond [(eq? isolation 'nested) + (let ([savepoint (generate-name)]) + (query1 fsym (format "SAVEPOINT ~a" savepoint) #f) + savepoint)] + [else + (query1 fsym "BEGIN TRANSACTION" #f) + #f])) - (define/public (end-transaction fsym mode) - (let ([stmt - (call-with-lock fsym - (lambda () - (let ([db (get-db fsym)]) - (unless (eq? mode 'rollback) - (check-valid-tx-status fsym)) - (when (get-tx-status db) - (let-values ([(stmt* _result) - (case mode - ((commit) - (query1 fsym "COMMIT TRANSACTION")) - ((rollback) - (query1 fsym "ROLLBACK TRANSACTION")))]) - (set! tx-status #f) - stmt*)))))]) - (statement:after-exec stmt) - (void))) + (define/override (end-transaction* fsym mode savepoint) + (case mode + ((commit) + (cond [savepoint + (query1 fsym (format "RELEASE SAVEPOINT ~a" savepoint) #f)] + [else + (query1 fsym "COMMIT TRANSACTION" #f)])) + ((rollback) + (cond [savepoint + (query1 fsym (format "ROLLBACK TO SAVEPOINT ~a" savepoint) #f) + (query1 fsym (format "RELEASE SAVEPOINT ~a" savepoint) #f)] + [else + (query1 fsym "ROLLBACK TRANSACTION" #f)]) + ;; remove 'invalid status, if necessary + (set! tx-status (get-tx-status)))) + (void)) + + ;; name-counter : number + (define name-counter 0) + + ;; generate-name : -> string + (define/private (generate-name) + (let ([n name-counter]) + (set! name-counter (add1 name-counter)) + (format "λmz_~a" n))) ;; Reflection @@ -247,7 +242,7 @@ "WHERE type = 'table' or type = 'view'")]) (let-values ([(stmt result) (call-with-lock fsym - (lambda () (query1 fsym stmt)))]) + (lambda () (query1 fsym stmt #f)))]) (statement:after-exec stmt) (for/list ([row (in-list (rows-result-rows result))]) (vector-ref row 0))))) @@ -272,7 +267,7 @@ ;; Can't figure out how to test... (define/private (handle-status who s) (when (memv s maybe-rollback-status-list) - (when (and saved-tx-status -db (not (get-tx-status -db))) ;; was in trans, now not + (when (and saved-tx-status -db (not (get-tx-status))) ;; was in trans, now not (set! tx-status 'invalid))) (handle-status* who s -db)) diff --git a/collects/db/private/sqlite3/dbsystem.rkt b/collects/db/private/sqlite3/dbsystem.rkt index 86de61b153..0fec4f6209 100644 --- a/collects/db/private/sqlite3/dbsystem.rkt +++ b/collects/db/private/sqlite3/dbsystem.rkt @@ -1,7 +1,8 @@ #lang racket/base (require racket/class "../generic/interfaces.rkt") -(provide dbsystem) +(provide dbsystem + classify-sl-sql) (define sqlite3-dbsystem% (class* object% (dbsystem<%>) @@ -34,3 +35,25 @@ (bytes? param)) (error/no-convert fsym "SQLite" "parameter" param)) param) + +;; ======================================== + + +;; SQL "parsing" +;; We just care about detecting commands that affect transaction status. + +;; classify-sl-sql : string [nat] -> symbol/#f +(define classify-sl-sql + (make-sql-classifier + '(;; Explicit transaction commands + ("ROLLBACK TRANSACTION TO" rollback-savepoint) + ("ROLLBACK TO" rollback-savepoint) + ("RELEASE" release-savepoint) + ("SAVEPOINT" savepoint) + ;; Note: SAVEPOINT allowed outside of transaction! (but that's okay) + + ("BEGIN" start) + ("COMMIT" commit) + ("END" commit) + ("ROLLBACK" rollback) ;; Note: after ROLLBACK TO, etc + ))) diff --git a/collects/db/scribblings/connect.scrbl b/collects/db/scribblings/connect.scrbl index 5f37c84440..47e5996ea6 100644 --- a/collects/db/scribblings/connect.scrbl +++ b/collects/db/scribblings/connect.scrbl @@ -22,15 +22,15 @@ connections}. PostgreSQL and MySQL connections are wire-based, and SQLite and ODBC connections are FFI-based. Wire-based connections communicate using @tech/reference{ports}, which -do not cause other Racket threads to block. In contrast, all Racket -threads are blocked during an FFI call, so FFI-based connections can -seriously degrade the interactivity of a Racket program, particularly -if long-running queries are performed using the connection. This -problem can be avoided by creating the FFI-based connection in a -separate @tech/reference{place} using the @racket[#:use-place] -keyword argument. Such a connection will not block all Racket threads -during queries; the disadvantage is the cost of creating and -communicating with a separate @tech/reference{place}. +do not cause other Racket threads to block. In contrast, an FFI call +causes all Racket threads to block until it completes, so FFI-based +connections can degrade the interactivity of a Racket program, +particularly if long-running queries are performed using the +connection. This problem can be avoided by creating the FFI-based +connection in a separate @tech/reference{place} using the +@racket[#:use-place] keyword argument. Such a connection will not +block all Racket threads during queries; the disadvantage is the cost +of creating and communicating with a separate @tech/reference{place}. Base connections are made using the following functions. @@ -567,14 +567,14 @@ ODBC's DSNs. @racket[data-source], then @racket[dsn-file] is ignored. @examples/results[ -[(put-dsn 'mydb +[(put-dsn 'pg (postgresql-data-source #:user "me" #:database "mydb" #:password "icecream")) (void)] -[(dsn-connect 'mydb) +[(dsn-connect 'pg) (new connection%)] -[(dsn-connect 'mydb #:notice-handler (lambda (code msg) ....)) +[(dsn-connect 'pg #:notice-handler (lambda (code msg) ....)) (new connection%)] ] } diff --git a/collects/db/scribblings/query.scrbl b/collects/db/scribblings/query.scrbl index 20970d5b23..a1257ffeb2 100644 --- a/collects/db/scribblings/query.scrbl +++ b/collects/db/scribblings/query.scrbl @@ -492,19 +492,34 @@ closed. The functions described in this section provide a consistent interface to transactions. -ODBC connections should use these functions exclusively instead of -transaction-changing SQL statements such as @tt{START TRANSACTION} and -@tt{COMMIT}. Using transaction-changing SQL may cause these functions -to behave incorrectly and may cause additional problems in the ODBC -driver. +A @deftech{managed transaction} is one created via either +@racket[start-transaction] or @racket[call-with-transaction]. In +contrast, an @deftech{unmanaged transaction} is one created by +evaluating a SQL statement such as @tt{START TRANSACTION}. A +@deftech{nested transaction} is a transaction created within the +extent of an existing transaction. If a nested transaction is +committed, its changes are promoted to the enclosing transaction, +which may itself be committed or rolled back. If a nested transaction +is rolled back, its changes are discarded, but the enclosing +transaction remains open. Nested transactions are implemented via SQL +@tt{SAVEPOINT}, @tt{RELEASE SAVEPOINT}, and @tt{ROLLBACK TO +SAVEPOINT}. -PostgreSQL, MySQL, and SQLite connections are discouraged from using -transaction-changing SQL statements, but the consequences are less -dire. The functions below will behave correctly, but the syntax and -behavior of the SQL statements is idiosyncratic. For example, in MySQL -@tt{START TRANSACTION} commits the current transaction, if one is -active; in PostgreSQL @tt{COMMIT} silently rolls back the current -transaction if an error occurred in a previous statement. +ODBC connections must use @tech{managed transactions} exclusively; +using transaction-changing SQL may cause these functions to behave +incorrectly and may cause additional problems in the ODBC driver. ODBC +connections do not support @tech{nested transactions}. + +PostgreSQL, MySQL, and SQLite connections must not mix @tech[#:key +"managed transaction"]{managed} and @tech[#:key "unmanaged +transaction"]{unmanaged} transactions. For example, calling +@racket[start-transaction] and then executing a @tt{ROLLBACK} +statement is not allowed. Note that in MySQL, some SQL statements have +@hyperlink["http://dev.mysql.com/doc/refman/5.0/en/implicit-commit.html"]{implicit +transaction effects}. For example, in MySQL a @tt{CREATE TABLE} +statement implicitly commits the current transaction. These statements +also must not be used within @tech{managed transactions}. (In +contrast, PostgreSQL and SQLite both support transactional DDL.) @bold{Errors} Query errors may affect an open transaction in one of three ways: @@ -512,8 +527,7 @@ three ways: @item{the transaction remains open and unchanged} @item{the transaction is automatically rolled back} @item{the transaction becomes an @deftech{invalid transaction}; all -subsequent queries will fail until the transaction is explicitly -rolled back} +subsequent queries will fail until the transaction is rolled back} ] To avoid the silent loss of information, this library attempts to avoid behavior (2) completely by marking transactions as invalid @@ -525,31 +539,37 @@ to what errors cause which behaviors: parameter arity and type errors, leave the transaction open and unchanged (1).} @item{All errors originating from PostgreSQL cause the transaction to - become invalid (3).} + become @tech[#:key "invalid transaction"]{invalid} (3).} @item{Most errors originating from MySQL leave the transaction open - and unchanged (1), but a few cause the transaction to become invalid - (3). In the latter cases, the underlying behavior - of MySQL is to roll back the transaction but @emph{leave it open} - (see @hyperlink["http://dev.mysql.com/doc/refman/5.1/en/innodb-error-handling.html"]{the + and unchanged (1), but a few cause the transaction to become + @tech[#:key "invalid transaction"]{invalid} (3). In the latter + cases, the underlying behavior of MySQL is to roll back the + transaction but @emph{leave it open} (see + @hyperlink["http://dev.mysql.com/doc/refman/5.1/en/innodb-error-handling.html"]{the MySQL documentation}). This library detects those cases and marks - the transaction invalid instead.} + the transaction @tech[#:key "invalid transaction"]{invalid} + instead.} @item{Most errors originating from SQLite leave the transaction open and unchanged (1), but a few cause the transaction to become - invalid (3). In the latter cases, the underlying behavior of SQLite - is to roll back the transaction (see + @tech[#:key "invalid transaction"]{invalid} (3). In the latter + cases, the underlying behavior of SQLite is to roll back the + transaction (see @hyperlink["http://www.sqlite.org/lang_transaction.html"]{the SQLite documentation}). This library detects those cases and marks the - transaction invalid instead.} + transaction @tech[#:key "invalid transaction"]{invalid} instead.} @item{All errors originating from an ODBC driver cause the transaction - to become invalid (3). The underlying behavior of ODBC drivers - varies widely, and ODBC provides no mechanism to detect when an - existing transaction has been rolled back, so this library - intercepts all errors and marks the transaction invalid instead.} + to become @tech[#:key "invalid transaction"]{invalid} (3). The + underlying behavior of ODBC drivers varies widely, and ODBC provides + no mechanism to detect when an existing transaction has been rolled + back, so this library intercepts all errors and marks the + transaction @tech[#:key "invalid transaction"]{invalid} instead.} ] -Future versions of this library may refine the set of errors that -invalidate a transaction (for example, by identifying innocuous ODBC -errors by SQLSTATE) and may provide an option to automatically -rollback invalid transactions. +If a nested transaction marked @tech[#:key "invalid +transaction"]{invalid} is rolled back, the enclosing transaction is +typically still valid. + +If a transaction is open when a connection is disconnected, it is +implicitly rolled back. @defproc[(start-transaction [c connection?] [#:isolation isolation-level @@ -566,37 +586,50 @@ rollback invalid transactions. database-dependent; it may be a default isolation level or it may be the isolation level of the previous transaction. - If @racket[c] is already in a transaction, an exception is raised. + If @racket[c] is already in a transaction, @racket[isolation-level] + must be @racket[#f], and a @tech{nested transaction} is opened. } @defproc[(commit-transaction [c connection?]) void?]{ - Attempts to commit the current transaction, if one is active. If the - transaction cannot be commited, an exception is raised. + Attempts to commit the current transaction, if one is open. If the + transaction cannot be commited (for example, if it is @tech[#:key + "invalid transaction"]{invalid}), an exception is raised. - If no transaction is active, this function has no effect. + If the current transaction is a @tech{nested transaction}, the + nested transaction is closed, its changes are incorporated into the + enclosing transaction, and the enclosing transaction is resumed. + + If no transaction is open, this function has no effect. } @defproc[(rollback-transaction [c connection?]) void?]{ - Rolls back the current transaction, if one is active. + Rolls back the current transaction, if one is open. - If no transaction is active, this function has no effect. + If the current transaction is a @tech{nested transaction}, the + nested transaction is closed, its changes are abandoned, and the + enclosing transaction is resumed. + + If no transaction is open, this function has no effect. } @defproc[(in-transaction? [c connection?]) boolean?]{ - Returns @racket[#t] if @racket[c] has a transaction is active, - @racket[#f] otherwise. + Returns @racket[#t] if @racket[c] has an open transaction + (@tech[#:key "managed transaction"]{managed} or @tech[#:key + "unmanaged transaction"]{unmanaged}), @racket[#f] otherwise. } @defproc[(needs-rollback? [c connection?]) boolean?]{ Returns @racket[#t] if @racket[c] is in an @tech{invalid transaction}. All queries executed using @racket[c] will fail until - the transaction is explicitly rolled back using - @racket[rollback-transaction]. + the transaction is rolled back (either using + @racket[rollback-transaction], if the transaction was created with + @racket[start-transaction], or when the procedure passed to + @racket[call-with-transaction] returns). } @defproc[(call-with-transaction [c connection?] @@ -613,8 +646,26 @@ rollback invalid transactions. Calls @racket[proc] in the context of a new transaction with isolation level @racket[isolation-level]. If @racket[proc] completes normally, the transaction is committed and @racket[proc]'s results - are returned. If @racket[proc] raises an exception, the transaction - is rolled back. + are returned. If @racket[proc] raises an exception (or if the + implicit commit at the end raises an exception), the transaction is + rolled back and the exception is re-raised. + + If @racket[call-with-transaction] is called within a transaction, + @racket[isolation-level] must be @racket[#f], and it creates a + @tech{nested transaction}. Within the extent of a call to + @racket[call-with-transaction], transactions must be properly + nested. In particular: + @itemlist[ + @item{Calling either @racket[commit-transaction] or + @racket[rollback-transaction] when the open transaction was + created by @racket[call-with-transaction] causes an exception to be + raised.} + @item{If a further nested transaction is open when @racket[proc] + completes (that is, created by an unmatched + @racket[start-transaction] call), an exception is raised and the + nested transaction created by @racket[call-with-transaction] is + rolled back.} + ] } @section{SQL Errors} @@ -651,7 +702,7 @@ type. provide SQLSTATE error codes. } -@section{Database Information} +@section{Database Catalog Information} @defproc[(list-tables [c connection?] [#:schema schema diff --git a/collects/tests/db/all-tests.rkt b/collects/tests/db/all-tests.rkt index 66b7307206..6c6d7aa034 100644 --- a/collects/tests/db/all-tests.rkt +++ b/collects/tests/db/all-tests.rkt @@ -13,7 +13,8 @@ "db/sql-types.rkt" "db/concurrent.rkt")) (prefix-in gen- - (combine-in "gen/sql-types.rkt" + (combine-in "gen/misc.rkt" + "gen/sql-types.rkt" "gen/query.rkt"))) (provide (all-defined-out)) @@ -193,7 +194,8 @@ Testing profiles are flattened, not hierarchical. (define generic-test (make-test-suite "Generic tests (no db)" - (list gen-sql-types:test + (list gen-misc:test + gen-sql-types:test gen-query:test))) ;; ---- diff --git a/collects/tests/db/db/query.rkt b/collects/tests/db/db/query.rkt index 50ac048e16..432a46be4d 100644 --- a/collects/tests/db/db/query.rkt +++ b/collects/tests/db/db/query.rkt @@ -266,12 +266,196 @@ (check-equal? (in-transaction? c) #t) (check-pred void? (rollback-transaction c)) (check-equal? (in-transaction? c) #f))) - (test-case "error on repeated start" + (test-case "error on managed st, unmanaged end" (with-connection c (start-transaction c) - (check-exn #rx"already in transaction" - (lambda () (start-transaction c))))) - (test-case "call-with-tx" + (check-exn #rx"ROLLBACK not allowed within managed transaction" + (lambda () (query-exec c "ROLLBACK"))) + (check-equal? (in-transaction? c) #t) + ;; SQLite-ODBC is unhappy with open tx on disconnect + (rollback-transaction c))) + (unless (ANYFLAGS 'odbc) + (test-case "unmanaged st, managed end ok" + (with-connection c + (query-exec c (cond [(ANYFLAGS 'ispg 'ismy) "START TRANSACTION"] + [(ANYFLAGS 'issl) "BEGIN TRANSACTION"])) + (check-equal? (in-transaction? c) #t) + (rollback-transaction c) + (check-equal? (in-transaction? c) #f)))) + (test-case "error on cwt, unmanaged end" + (with-connection c + (check-exn #rx"ROLLBACK not allowed within managed transaction" + (lambda () + (call-with-transaction c + (lambda () (query-exec c "ROLLBACK"))))) + (check-equal? (in-transaction? c) #f))) + (when (and (ANYFLAGS 'ispg 'issl) (not (ANYFLAGS 'odbc))) + (test-case "transactional ddl" + (with-connection c + (start-transaction c) + (query-exec c "create table foo (n integer)") + (define exists1 (table-exists? c "foo")) + (rollback-transaction c) + (define exists2 (table-exists? c "foo")) + (when exists2 (query-exec c "drop table foo")) ;; shouldn't happen + (check-equal? exists1 #t) + (check-equal? exists2 #f)))) + (when (ANYFLAGS 'ismy 'odbc) + (test-case "error on implicit-commit stmt" + (with-connection c + (start-transaction c) + (check-exn #rx"statement with implicit commit not allowed" + (lambda () (query-exec c "create table foo (n integer)"))) + ;; SQLite-ODBC is unhappy with open tx on disconnect + (rollback-transaction c)))) + (when (ANYFLAGS 'odbc) + (test-case "error on repeated start" + (with-connection c + (start-transaction c) + (check-exn #rx"already in transaction" + (lambda () (start-transaction c)))))) + (unless (ANYFLAGS 'odbc) + (test-case "start, start" + (with-connection c + (check-pred void? (start-transaction c)) + (check-pred void? (start-transaction c)) + (check-equal? (in-transaction? c) #t) + (check-pred void? (commit-transaction c)) + (check-equal? (in-transaction? c) #t) + (check-pred void? (commit-transaction c)) + (check-equal? (in-transaction? c) #f)))) + (when (ANYFLAGS 'odbc) + (test-case "start, start fails" + (with-connection c + (start-transaction c) + (check-exn #rx"already in transaction" + (lambda () (start-transaction c))))) + (test-case "cwt, start fails" + (with-connection c + (start-transaction c) + (check-exn #rx"already in transaction" + (lambda () (call-with-transaction c void)))))) + (test-case "commit w/o start is no-op" + (with-connection c + (check-pred void? (commit-transaction c)))) + (test-case "rollback w/o start is no-op" + (with-connection c + (check-pred void? (rollback-transaction c)))) + (test-case "cwt normal" + (with-connection c + (check-equal? (call-with-transaction c + (lambda () (query-value c (select-val "'abc'")))) + "abc"))) + (test-case "cwt w/ error" + (with-connection c + (check-exn exn:fail? + (lambda () + (call-with-transaction c + (lambda () (query-value c (select-val "foo")))))) + (check-equal? (in-transaction? c) #f))) + (test-case "cwt w/ caught error" + (with-connection c + (define (check-pg-exn proc) + (if (ANYFLAGS 'ispg 'odbc) (check-exn exn:fail? proc) (proc))) + (let ([ok? #f]) + (check-pg-exn + (lambda () + (call-with-transaction c + (lambda () + (with-handlers ([exn:fail? void?]) + (query-value c (select-val "foo"))) + (set! ok? (in-transaction? c)))))) + (check-equal? ok? #t "still in tx after caught error") + (check-equal? (in-transaction? c) #f)))) + + (unless (ANYFLAGS 'odbc) + (test-case "cwt w/ unclosed tx" + (with-connection c + (check-exn #rx"unclosed nested tr.* .within .* call-with-transaction" + (lambda () + (call-with-transaction c + (lambda () + (start-transaction c) + (query-value c (select-val "17")))))) + (check-equal? (in-transaction? c) #f))) + (test-case "cwt w/ unbalanced commit" + (with-connection c + (check-exn #rx"commit-tr.* start-tr.* .within .* call-with-transaction" + (lambda () + (call-with-transaction c + (lambda () + (commit-transaction c))))) + (check-equal? (in-transaction? c) #f))) + (test-case "cwt w/ unbalanced rollback" + (with-connection c + (check-exn #rx"rollback-tr.* start-tr.* .within .* call-with-transaction" + (lambda () + (call-with-transaction c + (lambda () + (rollback-transaction c))))) + (check-equal? (in-transaction? c) #f))) + + ;; start-tx, then call-with-tx + (test-case "st, cwt normal" + (with-connection c + (start-transaction c) + (check-equal? (call-with-transaction c + (lambda () (query-value c (select-val "17")))) + 17) + (check-equal? (in-transaction? c) #t))) + (test-case "st, cwt w/ error" + (with-connection c + (start-transaction c) + (check-exn exn:fail? + (lambda () + (call-with-transaction c + (lambda () (query-value c (select-val "foo")))))) + (check-equal? (in-transaction? c) #t))) + (test-case "st, cwt w/ caught error" + (with-connection c + (define (check-pg-exn proc) + (if (ANYFLAGS 'ispg) (check-exn exn:fail? proc) (proc))) + (let ([ok? #f]) + (start-transaction c) + (check-pg-exn + (lambda () + (call-with-transaction c + (lambda () + (with-handlers ([exn:fail? void?]) + (query-value c (select-val "foo"))) + (set! ok? (in-transaction? c)))))) + (check-equal? ok? #t "still in tx after caught error") + (check-equal? (in-transaction? c) #t)))) + (test-case "st, cwt w/ unclosed tx" + (with-connection c + (start-transaction c) + (check-exn #rx"unclosed nested tr.* .within .* call-with-transaction" + (lambda () + (call-with-transaction c + (lambda () + (start-transaction c) + (query-value c (select-val "17")))))) + (check-equal? (in-transaction? c) #t))) + (test-case "st, cwt w/ unbalanced commit" + (with-connection c + (start-transaction c) + (check-exn #rx"commit-tr.* start-tr.* .within .* call-with-transaction" + (lambda () + (call-with-transaction c + (lambda () + (commit-transaction c))))) + (check-equal? (in-transaction? c) #t))) + (test-case "cwt w/ unbalanced rollback" + (with-connection c + (start-transaction c) + (check-exn #rx"rollback-tr.* start-tr.* .within .* call-with-transaction" + (lambda () + (call-with-transaction c + (lambda () + (rollback-transaction c))))) + (check-equal? (in-transaction? c) #t)))) + + (test-case "cwt misc" (with-connection c (check-equal? (call-with-transaction c (lambda () diff --git a/collects/tests/db/gen/misc.rkt b/collects/tests/db/gen/misc.rkt new file mode 100644 index 0000000000..36ef881989 --- /dev/null +++ b/collects/tests/db/gen/misc.rkt @@ -0,0 +1,19 @@ +#lang racket/base +(require rackunit + racket/class + "../config.rkt") + +(provide misc:test) + +(require db/private/generic/interfaces) + +(define misc:test + (test-suite "Misc internal function tests" + (test-case "sql-skip-comments" + (define (eat s [hash? #f]) (substring s (sql-skip-comments s 0 #:hash-comments? hash?))) + (check-equal? (eat "/* blah ** blah */ insert") + " insert") + (check-equal? (eat "-- blah\n -- /* \nok") + "ok") + (check-equal? (eat "#a\n# b c d\nok" #t) + "ok"))))