db: added nested transactions

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

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

@@ -67,8 +67,8 @@
       (get-base)
       (free-statement stmt)
       (transaction-status fsym)
-      (start-transaction fsym isolation)
+      (start-transaction fsym isolation cwt?)
-      (end-transaction fsym mode)
+      (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))
+      (#t '_     (start-transaction fsym isolation cwt?))
-      (#f (void) (end-transaction fsym mode))
+      (#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)
+      (start-transaction fsym isolation cwt?)
-      (end-transaction fsym mode)
+      (end-transaction fsym mode cwt?)
       (list-tables fsym schema))
 
     ;; (define-forward define/override (connected?))

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)

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

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)
+    (define/public (start-transaction fsym iso cwt?)
-      (call 'start-transaction fsym iso))
+      (call 'start-transaction fsym iso cwt?))
-    (define/public (end-transaction fsym mode)
+    (define/public (end-transaction fsym mode cwt?)
-      (call 'end-transaction fsym mode))
+      (call 'end-transaction fsym mode cwt?))
     (define/public (list-tables fsym schema)
       (call 'list-tables fsym schema))
 

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)
+                                  (start-transaction w m c)
-                                  (end-transaction w m)
+                                  (end-transaction w m c)
                                   (transaction-status w))]))
           (lambda results
             (let ([results (for/list ([result (in-list results)]) (result->sexpr result))])

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
+                result-dvecs      ;; (listof vector), layout depends on dbsys
-    (init ([-owner owner]))
+                [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)

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? #f)
-    (define DEBUG-SENT-MESSAGES #f)
 
-    (define/public (debug incoming? [outgoing? incoming?])
+    (define/public (debug debug?)
-      (set! DEBUG-RESPONSES incoming?)
+      (set! DEBUG? debug?))
-      (set! DEBUG-SENT-MESSAGES outgoing?))
 
     ;; ========================================
 
@@ -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)
+    (define/override (start-transaction* fsym isolation)
-      (call-with-lock fsym (lambda () tx-status)))
+      (cond [(eq? isolation 'nested)
-
+             (let ([savepoint (generate-name)])
-    (define/public (start-transaction fsym isolation)
+               (query1 fsym (format "SAVEPOINT ~a" savepoint) #t)
-      (call-with-lock fsym
+               savepoint)]
-        (lambda ()
+            [else
-          (when tx-status
+             (let ([isolation-level (isolation-symbol->string isolation)])
-            (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 (format "SET TRANSACTION ISOLATION LEVEL ~a" isolation-level) #t))
                (query1 fsym "START TRANSACTION" #t)
-          (void))))
+               #f)]))
 
-    (define/public (end-transaction fsym mode)
+    (define/override (end-transaction* fsym mode savepoint)
-      (call-with-lock fsym
+      (case mode
-        (lambda ()
+        ((commit)
-          (unless (eq? mode 'rollback)
+         (cond [savepoint
-            (check-valid-tx-status fsym))
+                (query1 fsym (format "RELEASE SAVEPOINT ~a" savepoint) #t)]
-          (let ([stmt (case mode
+               [else
-                        ((commit) "COMMIT")
+                (query1 fsym "COMMIT" #t)]))
-                        ((rollback) "ROLLBACK"))])
+        ((rollback)
-            (query1 fsym stmt #t)
+         (cond [savepoint
-            (void)))))
+                (query1 fsym (format "ROLLBACK TO SAVEPOINT ~a" savepoint) #t)
+                (query1 fsym (format "RELEASE SAVEPOINT ~a" savepoint) #t)]
+               [else
+                (query1 fsym "ROLLBACK" #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
+              (vector-ref (call-with-lock fsym (lambda () (query1 fsym stmt #t))) 2)])
-               (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
+  SELECT and SHOW
-
-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.
 |#
 
 (define (force-prepare-sql? fsym stmt)
-  (let ([kw (get-sql-keyword stmt)])
+  (memq (classify-my-sql stmt) '(select show)))
-    (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))))

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

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,17 +476,11 @@
 
     ;; Transactions
 
-    (define/public (transaction-status fsym)
+    (define/override (start-transaction* fsym isolation)
-      (call-with-lock fsym
+      (when (eq? isolation 'nested)
-        (lambda () (let ([db (get-db fsym)]) tx-status))))
+        (uerror fsym "already in transaction (nested transactions not supported for ODBC)"))
-
+      (let* ([db (get-db fsym)]
-    (define/public (start-transaction fsym isolation)
+             [ok-levels
-      (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)))]
@@ -508,13 +505,10 @@
       (let ([status (SQLSetConnectAttr db SQL_ATTR_AUTOCOMMIT SQL_AUTOCOMMIT_OFF)])
         (handle-status fsym status db)
         (set! tx-status #t)
-              (void))))))
+        (void)))
 
-    (define/public (end-transaction fsym mode)
+    (define/override (end-transaction* fsym mode _savepoint)
-      (call-with-lock fsym
+      ;; _savepoint = #f, because nested transactions not supported on ODBC
-        (lambda () 
-          (unless (eq? mode 'rollback)
-            (check-valid-tx-status fsym))
       (let ([db (get-db fsym)]
             [completion-type
              (case mode
@@ -525,7 +519,7 @@
           (handle-status fsym status db)
           ;; commit/rollback can fail; don't change status until possible error handled
           (set! tx-status #f)
-              (void))))))
+          (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

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

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? #f)
-    (define DEBUG-SENT-MESSAGES #f)
 
-    (define/public (debug incoming? [outgoing? incoming?])
+    (define/public (debug debug?)
-      (set! DEBUG-RESPONSES incoming?)
+      (set! DEBUG? debug?))
-      (set! DEBUG-SENT-MESSAGES outgoing?))
 
     ;; ========================================
 
@@ -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)
+    (define/private (query1 fsym stmt simple?)
-      (let ([stmt (check-statement fsym stmt)])
+      ;; if simple?: stmt must be string, no params, & results must be binary-readable
       (query1:enqueue stmt)
       (send-message (make-Sync))
-        (begin0 (values stmt (query1:collect fsym stmt))
+      (begin0 (query1:collect fsym simple?)
-          (check-ready-for-query fsym #f))))
+        (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))
+               (send pst check-owner fsym this stmt)
-             stmt]
+               stmt)]
             [(string? stmt)
              (let ([pst (prepare1 fsym stmt #t)])
                (send pst bind fsym null))]))
 
     ;; query1:enqueue : Statement -> void
     (define/private (query1:enqueue stmt)
+      (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)))))
+                                          (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)
+    (define/private (query1:collect fsym simple?)
-      (when (string? stmt)
+      (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)
+    (define/override (start-transaction* fsym isolation)
-      (call-with-lock fsym (lambda () tx-status)))
+      (cond [(eq? isolation 'nested)
-
+             (let ([savepoint (generate-name)])
-    (define/public (start-transaction fsym isolation)
+               (query1 fsym (format "SAVEPOINT ~a" savepoint) #t)
-      (internal-query fsym
+               savepoint)]
-                      (lambda ()
+            [else
-                        (when tx-status
+             (let* ([isolation-level (isolation-symbol->string isolation)]
-                          (error/already-in-tx fsym)))
+                    [stmt (if isolation-level
-                      (let ([isolation-level (isolation-symbol->string isolation)])
+                              (string-append "BEGIN WORK ISOLATION LEVEL " isolation-level)
+                              "BEGIN WORK")])
+               ;; FIXME: also support
                ;;   'read-only  => "READ ONLY"
                ;;   'read-write => "READ WRITE"
-                        (if isolation-level
+               (query1 fsym stmt #t)
-                            (string-append "BEGIN WORK ISOLATION LEVEL " isolation-level)
+               #f)]))
-                            "BEGIN WORK")))
-      (void))
 
-    (define/public (end-transaction fsym mode)
+    (define/override (end-transaction* fsym mode savepoint)
-      (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")
+        ((commit)
-                        ((rollback) "ROLLBACK WORK")))
+         (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
+      (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"))]
+                  "table_schema = current_schema")))]
-             [stmt
+             [result (call-with-lock fsym (lambda () (query1 fsym stmt #t)))]
-              (string-append "SELECT table_name FROM information_schema.tables WHERE "
+             [rows (vector-ref result 2)])
-                             where-cond)]
-             [rows (vector-ref (internal-query fsym void stmt) 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))
     ))
 
 ;; ========================================

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

collects/db/private/sqlite3/connection.rkt

@@ -24,11 +24,12 @@
 
     (inherit call-with-lock*
              add-delayed-call!
-             check-valid-tx-status)
+             check-valid-tx-status
-    (inherit-field tx-status)  ;; only #f or 'invalid for compat w/ 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)])
+                           (simple-result '())]))))))
-                             (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 '())]))]))))))
 
     (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)
+    (define/private (get-tx-status)
-      (call-with-lock fsym
+      (not (sqlite3_get_autocommit -db)))
-        (lambda ()
-          (let ([db (get-db fsym)])
-            (or tx-status (get-tx-status db))))))
 
-    (define/private (get-tx-status [db -db])
+    (define/override (start-transaction* fsym isolation)
-      (and db (not (sqlite3_get_autocommit db))))
-
-    (define/public (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
+      (cond [(eq? isolation 'nested)
-             (call-with-lock fsym
+             (let ([savepoint (generate-name)])
-               (lambda ()
+               (query1 fsym (format "SAVEPOINT ~a" savepoint) #f)
-                 (let ([db (get-db fsym)])
+               savepoint)]
-                   (when (get-tx-status db)
+            [else
-                     (error/already-in-tx fsym))
+             (query1 fsym "BEGIN TRANSACTION" #f)
-                   (let-values ([(stmt* _result)
+             #f]))
-                                 (query1 fsym "BEGIN TRANSACTION")])
-                     stmt*))))])
-        (statement:after-exec stmt)
-        (void)))
 
-    (define/public (end-transaction fsym mode)
+    (define/override (end-transaction* fsym mode savepoint)
-      (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"))
+         (cond [savepoint
+                (query1 fsym (format "RELEASE SAVEPOINT ~a" savepoint) #f)]
+               [else
+                (query1 fsym "COMMIT TRANSACTION" #f)]))
         ((rollback)
-                                      (query1 fsym "ROLLBACK TRANSACTION")))])
+         (cond [savepoint
-                       (set! tx-status #f)
+                (query1 fsym (format "ROLLBACK TO SAVEPOINT ~a" savepoint) #f)
-                       stmt*)))))])
+                (query1 fsym (format "RELEASE SAVEPOINT ~a" savepoint) #f)]
-        (statement:after-exec stmt)
+               [else
-        (void)))
+                (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))
 

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

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
+do not cause other Racket threads to block. In contrast, an FFI call
-threads are blocked during an FFI call, so FFI-based connections can
+causes all Racket threads to block until it completes, so FFI-based
-seriously degrade the interactivity of a Racket program, particularly
+connections can degrade the interactivity of a Racket program,
-if long-running queries are performed using the connection. This
+particularly if long-running queries are performed using the
-problem can be avoided by creating the FFI-based connection in a
+connection. This problem can be avoided by creating the FFI-based
-separate @tech/reference{place} using the @racket[#:use-place]
+connection in a separate @tech/reference{place} using the
-keyword argument. Such a connection will not block all Racket threads
+@racket[#:use-place] keyword argument. Such a connection will not
-during queries; the disadvantage is the cost of creating and
+block all Racket threads during queries; the disadvantage is the cost
-communicating with a separate @tech/reference{place}.
+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%)]
 ]
 }

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
+A @deftech{managed transaction} is one created via either
-transaction-changing SQL statements such as @tt{START TRANSACTION} and
+@racket[start-transaction] or @racket[call-with-transaction]. In
-@tt{COMMIT}. Using transaction-changing SQL may cause these functions
+contrast, an @deftech{unmanaged transaction} is one created by
-to behave incorrectly and may cause additional problems in the ODBC
+evaluating a SQL statement such as @tt{START TRANSACTION}. A
-driver.
+@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
+ODBC connections must use @tech{managed transactions} exclusively;
-transaction-changing SQL statements, but the consequences are less
+using transaction-changing SQL may cause these functions to behave
-dire. The functions below will behave correctly, but the syntax and
+incorrectly and may cause additional problems in the ODBC driver. ODBC
-behavior of the SQL statements is idiosyncratic. For example, in MySQL
+connections do not support @tech{nested transactions}.
-@tt{START TRANSACTION} commits the current transaction, if one is
+
-active; in PostgreSQL @tt{COMMIT} silently rolls back the current
+PostgreSQL, MySQL, and SQLite connections must not mix @tech[#:key
-transaction if an error occurred in a previous statement.
+"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
+subsequent queries will fail until the transaction is rolled back}
-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
+  and unchanged (1), but a few cause the transaction to become
-  (3). In the latter cases, the underlying behavior
+  @tech[#:key "invalid transaction"]{invalid} (3). In the latter
-  of MySQL is to roll back the transaction but @emph{leave it open}
+  cases, the underlying behavior of MySQL is to roll back the
-  (see @hyperlink["http://dev.mysql.com/doc/refman/5.1/en/innodb-error-handling.html"]{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
+  @tech[#:key "invalid transaction"]{invalid} (3). In the latter
-  is to roll back the transaction (see
+  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
+  to become @tech[#:key "invalid transaction"]{invalid} (3). The
-  varies widely, and ODBC provides no mechanism to detect when an
+  underlying behavior of ODBC drivers varies widely, and ODBC provides
-  existing transaction has been rolled back, so this library
+  no mechanism to detect when an existing transaction has been rolled
-  intercepts all errors and marks the transaction invalid instead.}
+  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
+If a nested transaction marked @tech[#:key "invalid
-invalidate a transaction (for example, by identifying innocuous ODBC
+transaction"]{invalid} is rolled back, the enclosing transaction is
-errors by SQLSTATE) and may provide an option to automatically
+typically still valid.
-rollback invalid transactions.
+
+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
+  Attempts to commit the current transaction, if one is open. If the
-  transaction cannot be commited, an exception is raised.
+  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,
+  Returns @racket[#t] if @racket[c] has an open transaction
-  @racket[#f] otherwise.
+  (@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
+  the transaction is rolled back (either using
-  @racket[rollback-transaction].
+  @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
+  are returned. If @racket[proc] raises an exception (or if the
-  is rolled back.
+  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

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

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 managed st, unmanaged end"
+      (with-connection c
+        (start-transaction c)
+        (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 "call-with-tx"
+      (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 ()

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