680 lines
31 KiB
Racket
680 lines
31 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
racket/list
|
|
racket/math
|
|
ffi/unsafe
|
|
ffi/unsafe/atomic
|
|
"../generic/interfaces.rkt"
|
|
"../generic/prepared.rkt"
|
|
"../generic/sql-data.rkt"
|
|
"../generic/sql-convert.rkt"
|
|
"ffi.rkt"
|
|
"ffi-constants.rkt"
|
|
"dbsystem.rkt")
|
|
(provide connection%
|
|
handle-status*
|
|
dbsystem)
|
|
|
|
;; == Connection
|
|
|
|
(define connection%
|
|
(class* transactions% (connection<%>)
|
|
(init-private db
|
|
env
|
|
notice-handler
|
|
char-mode)
|
|
(init strict-parameter-types?)
|
|
|
|
(define statement-table (make-hasheq))
|
|
(define lock (make-semaphore 1))
|
|
|
|
(define use-describe-param?
|
|
(and strict-parameter-types?
|
|
(let-values ([(status supported?) (SQLGetFunctions db SQL_API_SQLDESCRIBEPARAM)])
|
|
(handle-status 'odbc-connect status db)
|
|
supported?)))
|
|
|
|
(define dbms
|
|
(let-values ([(status result) (SQLGetInfo-string db SQL_DBMS_NAME)])
|
|
(handle-status 'odbc-connect status db)
|
|
result))
|
|
|
|
(inherit call-with-lock
|
|
call-with-lock*
|
|
add-delayed-call!
|
|
check-valid-tx-status)
|
|
(inherit-field tx-status)
|
|
|
|
(define/public (get-db fsym)
|
|
(unless db
|
|
(error/not-connected fsym))
|
|
db)
|
|
|
|
(define/public (get-dbsystem) dbsystem)
|
|
(define/override (connected?) (and db #t))
|
|
|
|
(define/public (query fsym stmt)
|
|
(let-values ([(stmt* dvecs rows)
|
|
(call-with-lock fsym
|
|
(lambda ()
|
|
(check-valid-tx-status fsym)
|
|
(query1 fsym stmt)))])
|
|
(statement:after-exec stmt*)
|
|
(cond [(pair? dvecs) (rows-result (map field-dvec->field-info dvecs) rows)]
|
|
[else (simple-result '())])))
|
|
|
|
(define/private (query1 fsym stmt)
|
|
(let* ([stmt (cond [(string? stmt)
|
|
(let* ([pst (prepare1 fsym stmt #t)])
|
|
(send pst bind fsym null))]
|
|
[(statement-binding? stmt)
|
|
stmt])]
|
|
[pst (statement-binding-pst stmt)]
|
|
[params (statement-binding-params stmt)])
|
|
(send pst check-owner fsym this stmt)
|
|
(let ([result-dvecs (send pst get-result-dvecs)])
|
|
(for ([dvec (in-list result-dvecs)])
|
|
(let ([typeid (field-dvec->typeid dvec)])
|
|
(unless (supported-typeid? typeid)
|
|
(error/unsupported-type fsym typeid)))))
|
|
(let-values ([(dvecs rows) (query1:inner fsym pst params)])
|
|
(values stmt dvecs rows))))
|
|
|
|
(define/private (query1:inner fsym pst params)
|
|
(let* ([db (get-db fsym)]
|
|
[stmt (send pst get-handle)])
|
|
(let* ([param-bufs
|
|
;; Need to keep references to all bufs until after SQLExecute.
|
|
(for/list ([i (in-naturals 1)]
|
|
[param (in-list params)]
|
|
[param-typeid (in-list (send pst get-param-typeids))])
|
|
(load-param fsym db stmt i param param-typeid))])
|
|
(handle-status fsym (SQLExecute stmt) stmt)
|
|
(strong-void param-bufs))
|
|
(let* ([result-dvecs (send pst get-result-dvecs)]
|
|
[rows
|
|
(and (pair? result-dvecs)
|
|
(fetch* fsym stmt (map field-dvec->typeid result-dvecs)))])
|
|
(handle-status fsym (SQLFreeStmt stmt SQL_CLOSE) stmt)
|
|
(handle-status fsym (SQLFreeStmt stmt SQL_RESET_PARAMS) stmt)
|
|
(values result-dvecs rows))))
|
|
|
|
(define/private (load-param fsym db stmt i param typeid)
|
|
;; NOTE: param buffers must not move between bind and execute
|
|
;; So use buffer utils from ffi.rkt (copy-buffer, etc)
|
|
(define (bind ctype sqltype buf)
|
|
(let* ([lenbuf
|
|
(int->buffer (if buf (bytes-length buf) SQL_NULL_DATA))]
|
|
[status
|
|
(SQLBindParameter stmt i SQL_PARAM_INPUT ctype sqltype 0 0 buf lenbuf)])
|
|
(handle-status fsym status stmt)
|
|
(if buf (cons buf lenbuf) lenbuf)))
|
|
;; If the typeid is UNKNOWN, then choose appropriate type based on data,
|
|
;; but respect typeid if known.
|
|
(define unknown-type? (= typeid SQL_UNKNOWN_TYPE))
|
|
(cond [(string? param)
|
|
(case char-mode
|
|
((wchar)
|
|
(bind SQL_C_WCHAR (if unknown-type? SQL_WVARCHAR typeid)
|
|
(case WCHAR-SIZE
|
|
((2) (cpstr2 param))
|
|
((4) (cpstr4 param)))))
|
|
((utf-8)
|
|
(bind SQL_C_CHAR (if unknown-type? SQL_VARCHAR typeid)
|
|
(copy-buffer (string->bytes/utf-8 param))))
|
|
((latin-1)
|
|
(bind SQL_C_CHAR (if unknown-type? SQL_VARCHAR typeid)
|
|
(copy-buffer (string->bytes/latin-1 param (char->integer #\?))))))]
|
|
[(bytes? param)
|
|
(bind SQL_C_BINARY (if unknown-type? SQL_BINARY typeid)
|
|
(copy-buffer param))]
|
|
[(pair? param) ;; Represents numeric/decimal decomposed as scaled integer
|
|
(bind SQL_C_NUMERIC typeid
|
|
(copy-buffer
|
|
(let ([ma (car param)]
|
|
[ex (cdr param)])
|
|
(apply bytes-append
|
|
;; ODBC docs claim max precision is 15 ...
|
|
(bytes (if (zero? ma) 1 (+ 1 (order-of-magnitude (abs ma))))
|
|
ex
|
|
(if (negative? ma) 0 1))
|
|
;; 16 bytes of unsigned little-endian data (4 chunks of 4 bytes)
|
|
(let loop ([i 0] [ma (abs ma)])
|
|
(if (< i 4)
|
|
(let-values ([(q r) (quotient/remainder ma (expt 2 32))])
|
|
(cons (integer->integer-bytes r 4 #f #f)
|
|
(loop (add1 i) q)))
|
|
null))))))]
|
|
[(real? param)
|
|
(cond [(or (= typeid SQL_NUMERIC) (= typeid SQL_DECIMAL))
|
|
(bind SQL_C_CHAR typeid
|
|
(copy-buffer (marshal-decimal fsym i param)))]
|
|
[(or (and unknown-type? (int32? param))
|
|
(= typeid SQL_INTEGER)
|
|
(= typeid SQL_SMALLINT)
|
|
(= typeid SQL_BIGINT)
|
|
(= typeid SQL_TINYINT))
|
|
;; Oracle errors without diagnostic record (!!) on BIGINT param
|
|
;; -> http://stackoverflow.com/questions/338609
|
|
;; FIXME: find a better solution, eg check driver for BIGINT support (?)
|
|
(if (= typeid SQL_BIGINT)
|
|
(bind SQL_C_SBIGINT SQL_BIGINT
|
|
(copy-buffer (integer->integer-bytes param 8 #t)))
|
|
(bind SQL_C_LONG (if unknown-type? SQL_INTEGER typeid)
|
|
(copy-buffer (integer->integer-bytes param 4 #t))))]
|
|
[else
|
|
(bind SQL_C_DOUBLE (if unknown-type? SQL_DOUBLE typeid)
|
|
(copy-buffer
|
|
(real->floating-point-bytes (exact->inexact param) 8)))])]
|
|
[(boolean? param)
|
|
(bind SQL_C_LONG SQL_BIT
|
|
(copy-buffer (int->buffer (if param 1 0))))]
|
|
[(sql-date? param)
|
|
(bind SQL_C_TYPE_DATE SQL_TYPE_DATE
|
|
(copy-buffer
|
|
(let* ([x param]
|
|
[y (sql-date-year x)]
|
|
[m (sql-date-month x)]
|
|
[d (sql-date-day x)])
|
|
(bytes-append (integer->integer-bytes y 2 #t)
|
|
(integer->integer-bytes m 2 #f)
|
|
(integer->integer-bytes d 2 #f)))))]
|
|
[(sql-time? param)
|
|
(bind SQL_C_TYPE_TIME SQL_TYPE_TIME
|
|
(copy-buffer
|
|
(let* ([x param]
|
|
[h (sql-time-hour x)]
|
|
[m (sql-time-minute x)]
|
|
[s (sql-time-second x)])
|
|
(bytes-append (integer->integer-bytes h 2 #f)
|
|
(integer->integer-bytes m 2 #f)
|
|
(integer->integer-bytes s 2 #f)))))]
|
|
[(sql-timestamp? param)
|
|
(bind SQL_C_TYPE_TIMESTAMP
|
|
(if unknown-type? SQL_TYPE_TIMESTAMP typeid)
|
|
(copy-buffer
|
|
(let ([x param])
|
|
(bytes-append
|
|
(integer->integer-bytes (sql-timestamp-year x) 2 #f)
|
|
(integer->integer-bytes (sql-timestamp-month x) 2 #f)
|
|
(integer->integer-bytes (sql-timestamp-day x) 2 #f)
|
|
(integer->integer-bytes (sql-timestamp-hour x) 2 #f)
|
|
(integer->integer-bytes (sql-timestamp-minute x) 2 #f)
|
|
(integer->integer-bytes (sql-timestamp-second x) 2 #f)
|
|
(integer->integer-bytes (sql-timestamp-nanosecond x) 4 #f)))))]
|
|
[(sql-null? param)
|
|
(bind SQL_C_CHAR SQL_VARCHAR #f)]
|
|
[else (error/internal fsym "cannot convert to typeid ~a: ~e" typeid param)]))
|
|
|
|
(define/private (fetch* fsym stmt result-typeids)
|
|
;; scratchbuf: create a single buffer here to try to reduce garbage
|
|
;; Don't make too big; otherwise bad for queries with only small data.
|
|
;; Doesn't need to be large, since get-varbuf already smart for long data.
|
|
;; MUST be at least as large as any int/float type (see get-num)
|
|
;; SHOULD be at least as large as any structures (see uses of get-int-list)
|
|
(let ([scratchbuf (make-bytes 50)])
|
|
(let loop ()
|
|
(let ([c (fetch fsym stmt result-typeids scratchbuf)])
|
|
(if c (cons c (loop)) null)))))
|
|
|
|
(define/private (fetch fsym stmt result-typeids scratchbuf)
|
|
(let ([s (SQLFetch stmt)])
|
|
(cond [(= s SQL_NO_DATA) #f]
|
|
[(= s SQL_SUCCESS)
|
|
(let* ([column-count (length result-typeids)]
|
|
[vec (make-vector column-count)])
|
|
(for ([i (in-range column-count)]
|
|
[typeid (in-list result-typeids)])
|
|
(vector-set! vec i (get-column fsym stmt (add1 i) typeid scratchbuf)))
|
|
vec)]
|
|
[else (handle-status fsym s stmt)])))
|
|
|
|
(define/private (get-column fsym stmt i typeid scratchbuf)
|
|
(define-syntax-rule (get-num size ctype convert convert-arg ...)
|
|
(let-values ([(status ind) (SQLGetData stmt i ctype scratchbuf 0)])
|
|
(handle-status fsym status stmt)
|
|
(cond [(= ind SQL_NULL_DATA) sql-null]
|
|
[else (convert scratchbuf convert-arg ... 0 size)])))
|
|
(define (get-int size ctype)
|
|
(get-num size ctype integer-bytes->integer #t (system-big-endian?)))
|
|
(define (get-real ctype)
|
|
(get-num 8 ctype floating-point-bytes->real (system-big-endian?)))
|
|
(define (get-int-list sizes ctype)
|
|
(let* ([buflen (apply + sizes)]
|
|
[buf (if (<= buflen (bytes-length scratchbuf)) scratchbuf (make-bytes buflen))])
|
|
(let-values ([(status ind) (SQLGetData stmt i ctype buf 0)])
|
|
(handle-status fsym status stmt)
|
|
(cond [(= ind SQL_NULL_DATA) sql-null]
|
|
[else (let ([in (open-input-bytes buf)])
|
|
(for/list ([size (in-list sizes)])
|
|
(case size
|
|
((1) (read-byte in))
|
|
((2) (integer-bytes->integer (read-bytes 2 in) #f))
|
|
((4) (integer-bytes->integer (read-bytes 4 in) #f))
|
|
(else (error/internal
|
|
'get-int-list "bad size: ~e" size)))))]))))
|
|
|
|
(define (get-varbuf ctype ntlen convert)
|
|
;; ntlen is null-terminator length (1 for char data, 0 for binary, ??? for wchar)
|
|
|
|
;; null-terminator, there are 3 modes: binary, wchar=2, wchar=4
|
|
;; - binary: all done in racket, no worries
|
|
;; - wchar=4: passed to make_sized_char_string, so must explicitly leave ntlen \0 bytes
|
|
;; - wchar=2: passed to utf16_to_ucs4 (which must add \0 space, see ffi.rkt)
|
|
;; So for simplicity, add ntlen \0 bytes to buf (but do *not* add to data len)
|
|
|
|
;; ODBC docs say len-or-ind is character count for char data, but wrong:
|
|
;; always a byte count.
|
|
|
|
;; It would be nice if we could call w/ empty buffer, get total length, then
|
|
;; call again with appropriate buffer. But can't use NULL (works on unixodbc, but
|
|
;; ODBC spec says illegal and Win32 ODBC rejects). Seems unsafe to use 0-length
|
|
;; buffer (spec is unclear, DB2 docs say len>0...???).
|
|
|
|
;; loop : bytes nat (listof bytes) -> any
|
|
;; start is next place to write, but data starts at 0
|
|
;; rchunks is reversed list of previous chunks (for data longer than scratchbuf)
|
|
;; Small data done in one iteration; most long data done in two. Only long data
|
|
;; without known size (???) should take more than two iterations.
|
|
(define (loop buf start rchunks)
|
|
(let-values ([(status len-or-ind) (SQLGetData stmt i ctype buf start)])
|
|
(handle-status fsym status stmt #:ignore-ok/info? #t)
|
|
(cond [(= len-or-ind SQL_NULL_DATA) sql-null]
|
|
[(= len-or-ind SQL_NO_TOTAL)
|
|
;; didn't fit in buf, and we have no idea how much more there is
|
|
;; start = 0
|
|
(let* ([data-end (- (bytes-length buf) ntlen)])
|
|
(loop buf 0 (cons (subbytes buf 0 data-end) rchunks)))]
|
|
[else
|
|
(let ([len (+ start len-or-ind)])
|
|
(cond [(<= 0 len (- (bytes-length buf) ntlen))
|
|
;; fit in buf
|
|
(cond [(pair? rchunks)
|
|
;; add ntlen bytes for null-terminator...
|
|
(let* ([chunk (subbytes buf 0 (+ len ntlen))]
|
|
[chunks (append (reverse rchunks) (list chunk))]
|
|
[complete (apply bytes-append chunks)])
|
|
;; ... but compensate so len is correct
|
|
(convert complete (- (bytes-length complete) ntlen) #t))]
|
|
[else
|
|
;; buf already null-terminated, len correct
|
|
(convert buf len #f)])]
|
|
[else
|
|
;; didn't fit in buf, but we know how much more there is
|
|
(let* ([len-got (- (bytes-length buf) ntlen)]
|
|
[newbuf (make-bytes (+ len ntlen))])
|
|
(bytes-copy! newbuf 0 buf start len-got)
|
|
(loop newbuf len-got rchunks))]))])))
|
|
(loop scratchbuf 0 null))
|
|
|
|
(define (get-string/latin-1)
|
|
(get-varbuf SQL_C_CHAR 1
|
|
(lambda (buf len _fresh?)
|
|
(bytes->string/latin-1 buf #f 0 len))))
|
|
(define (get-string/utf-8)
|
|
(get-varbuf SQL_C_CHAR 1
|
|
(lambda (buf len _fresh?)
|
|
(bytes->string/utf-8 buf #f 0 len))))
|
|
(define (get-string)
|
|
(case char-mode
|
|
((wchar)
|
|
(get-varbuf SQL_C_WCHAR WCHAR-SIZE (case WCHAR-SIZE ((2) mkstr2) ((4) mkstr4))))
|
|
((utf-8)
|
|
(get-string/utf-8))
|
|
((latin-1)
|
|
(get-string/latin-1))))
|
|
(define (get-bytes)
|
|
(get-varbuf SQL_C_BINARY 0
|
|
(lambda (buf len fresh?)
|
|
;; avoid copying long data twice:
|
|
(if (and fresh? (= len (bytes-length buf)))
|
|
buf
|
|
(subbytes buf 0 len)))))
|
|
|
|
(cond [(or (= typeid SQL_CHAR)
|
|
(= typeid SQL_VARCHAR)
|
|
(= typeid SQL_LONGVARCHAR)
|
|
(= typeid SQL_WCHAR)
|
|
(= typeid SQL_WVARCHAR)
|
|
(= typeid SQL_WLONGVARCHAR))
|
|
(get-string)]
|
|
[(or (= typeid SQL_DECIMAL)
|
|
(= typeid SQL_NUMERIC))
|
|
(let ([fields (get-int-list '(1 1 1 4 4 4 4) SQL_C_NUMERIC)])
|
|
(cond [(list? fields)
|
|
(let* ([precision (first fields)]
|
|
[scale (second fields)]
|
|
[sign (case (third fields) ((0) -1) ((1) 1))]
|
|
[ma (let loop ([lst (cdddr fields)])
|
|
(if (pair? lst)
|
|
(+ (* (loop (cdr lst)) (expt 2 32))
|
|
(car lst))
|
|
0))])
|
|
;; (eprintf "numeric: ~s\n" fields)
|
|
(* sign ma (expt 10 (- scale))))]
|
|
[(sql-null? fields) sql-null]))]
|
|
[(or (= typeid SQL_SMALLINT)
|
|
(= typeid SQL_INTEGER)
|
|
(= typeid SQL_TINYINT))
|
|
(get-int 4 SQL_C_LONG)]
|
|
[(or (= typeid SQL_BIGINT))
|
|
(get-int 8 SQL_C_SBIGINT)]
|
|
[(or (= typeid SQL_REAL)
|
|
(= typeid SQL_FLOAT)
|
|
(= typeid SQL_DOUBLE))
|
|
(get-real SQL_C_DOUBLE)]
|
|
[(or (= typeid SQL_BIT))
|
|
(case (get-int 4 SQL_C_LONG)
|
|
((0) #f)
|
|
((1) #t)
|
|
(else 'get-column "internal error: SQL_BIT"))]
|
|
[(or (= typeid SQL_BINARY)
|
|
(= typeid SQL_VARBINARY))
|
|
(get-bytes)]
|
|
[(= typeid SQL_TYPE_DATE)
|
|
(let ([fields (get-int-list '(2 2 2) SQL_C_TYPE_DATE)])
|
|
(cond [(list? fields) (apply sql-date fields)]
|
|
[(sql-null? fields) sql-null]))]
|
|
[(= typeid SQL_TYPE_TIME)
|
|
(let ([fields (get-int-list '(2 2 2) SQL_C_TYPE_TIME)])
|
|
(cond [(list? fields) (apply sql-time (append fields (list 0 #f)))]
|
|
[(sql-null? fields) sql-null]))]
|
|
[(= typeid SQL_TYPE_TIMESTAMP)
|
|
(let ([fields (get-int-list '(2 2 2 2 2 2 4) SQL_C_TYPE_TIMESTAMP)])
|
|
(cond [(list? fields) (apply sql-timestamp (append fields (list #f)))]
|
|
[(sql-null? fields) sql-null]))]
|
|
[else (get-string)]))
|
|
|
|
(define/public (prepare fsym stmt close-on-exec?)
|
|
(call-with-lock fsym
|
|
(lambda ()
|
|
(check-valid-tx-status fsym)
|
|
(prepare1 fsym stmt close-on-exec?))))
|
|
|
|
(define/private (prepare1 fsym sql close-on-exec?)
|
|
;; no time between prepare and table entry
|
|
(let* ([stmt
|
|
(let*-values ([(db) (get-db fsym)]
|
|
[(status stmt) (SQLAllocHandle SQL_HANDLE_STMT db)])
|
|
(handle-status fsym status db)
|
|
(with-handlers ([(lambda (e) #t)
|
|
(lambda (e)
|
|
(SQLFreeHandle SQL_HANDLE_STMT stmt)
|
|
(raise e))])
|
|
(let ([status (SQLPrepare stmt sql)])
|
|
(handle-status fsym status stmt)
|
|
stmt)))]
|
|
[param-typeids (describe-params fsym stmt)]
|
|
[result-dvecs (describe-result-columns fsym stmt)])
|
|
(let ([pst (new prepared-statement%
|
|
(handle stmt)
|
|
(close-on-exec? close-on-exec?)
|
|
(owner this)
|
|
(param-typeids param-typeids)
|
|
(result-dvecs result-dvecs))])
|
|
(hash-set! statement-table pst #t)
|
|
pst)))
|
|
|
|
(define/private (describe-params fsym stmt)
|
|
(let-values ([(status param-count) (SQLNumParams stmt)])
|
|
(handle-status fsym status stmt)
|
|
(for/list ([i (in-range 1 (add1 param-count))])
|
|
(cond [use-describe-param?
|
|
(let-values ([(status type size digits nullable)
|
|
(SQLDescribeParam stmt i)])
|
|
(handle-status fsym status stmt)
|
|
type)]
|
|
[else SQL_UNKNOWN_TYPE]))))
|
|
|
|
(define/private (describe-result-columns fsym stmt)
|
|
(let-values ([(status result-count) (SQLNumResultCols stmt)]
|
|
[(scratchbuf) (make-bytes 200)])
|
|
(handle-status fsym status stmt)
|
|
(for/list ([i (in-range 1 (add1 result-count))])
|
|
(let-values ([(status name type size digits nullable)
|
|
(SQLDescribeCol stmt i scratchbuf)])
|
|
(handle-status fsym status stmt)
|
|
(vector name type size digits)))))
|
|
|
|
(define/public (disconnect)
|
|
(define (go)
|
|
(start-atomic)
|
|
(let ([db* db]
|
|
[env* env])
|
|
(set! db #f)
|
|
(set! env #f)
|
|
(end-atomic)
|
|
(when db*
|
|
(let ([statements (hash-map statement-table (lambda (k v) k))])
|
|
(for ([pst (in-list statements)])
|
|
(free-statement* 'disconnect pst))
|
|
(handle-status 'disconnect (SQLDisconnect db*) db*)
|
|
(handle-status 'disconnect (SQLFreeHandle SQL_HANDLE_DBC db*))
|
|
(handle-status 'disconnect (SQLFreeHandle SQL_HANDLE_ENV env*))
|
|
(void)))))
|
|
(call-with-lock* 'disconnect go go #f))
|
|
|
|
(define/public (get-base) this)
|
|
|
|
(define/public (free-statement pst)
|
|
(define (go) (free-statement* 'free-statement pst))
|
|
(call-with-lock* 'free-statement go go #f))
|
|
|
|
(define/private (free-statement* fsym pst)
|
|
(start-atomic)
|
|
(let ([stmt (send pst get-handle)])
|
|
(send pst set-handle #f)
|
|
(end-atomic)
|
|
(when stmt
|
|
(handle-status 'free-statement (SQLFreeStmt stmt SQL_CLOSE) stmt)
|
|
(handle-status 'free-statement (SQLFreeHandle SQL_HANDLE_STMT stmt) stmt)
|
|
(hash-remove! statement-table pst)
|
|
(void))))
|
|
|
|
;; Transactions
|
|
|
|
(define/public (transaction-status fsym)
|
|
(call-with-lock fsym
|
|
(lambda () (let ([db (get-db fsym)]) tx-status))))
|
|
|
|
(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))))))
|
|
|
|
;; GetTables
|
|
|
|
(define/public (list-tables fsym schema)
|
|
(define (no-search)
|
|
(uerror fsym "schema search path cannot be determined for this DBMS"))
|
|
(let ([stmt
|
|
(cond
|
|
[(regexp-match? #rx"^DB2" dbms)
|
|
(let* ([schema-cond
|
|
(case schema
|
|
((search-or-current current)
|
|
"tabschema = CURRENT_SCHEMA")
|
|
((search)
|
|
(no-search)))]
|
|
[type-cond
|
|
;; FIXME: what table types to include? see docs for SYSCAT.TABLES
|
|
"(type = 'T' OR type = 'V')"])
|
|
(string-append "SELECT tabname FROM syscat.tables "
|
|
"WHERE " type-cond " AND " schema-cond))]
|
|
[(equal? dbms "Oracle")
|
|
(let* ([schema-cond
|
|
(case schema
|
|
((search-or-current current)
|
|
"owner = sys_context('userenv', 'current_schema')")
|
|
((search)
|
|
(no-search)))])
|
|
(string-append "SELECT table_name AS name FROM sys.all_tables "
|
|
"WHERE " schema-cond
|
|
"UNION "
|
|
"SELECT view_name AS name FROM sys.all_views "
|
|
"WHERE " schema-cond))]
|
|
[else
|
|
(uerror fsym "not supported for this DBMS")])])
|
|
(let* ([result (query fsym stmt)]
|
|
[rows (rows-result-rows result)])
|
|
(for/list ([row (in-list rows)])
|
|
(vector-ref row 0)))))
|
|
|
|
#|
|
|
(define/public (get-tables fsym catalog schema table)
|
|
(define-values (dvecs rows)
|
|
(call-with-lock fsym
|
|
(lambda ()
|
|
(let* ([db (get-db fsym)]
|
|
[stmt (let-values ([(status stmt) (SQLAllocHandle SQL_HANDLE_STMT db)])
|
|
(handle-status fsym status db)
|
|
stmt)]
|
|
[_ (handle-status fsym (SQLTables stmt catalog schema table))]
|
|
[result-dvecs (describe-result-columns fsym stmt)]
|
|
[rows (fetch* fsym stmt (map field-dvec->typeid result-dvecs))])
|
|
(handle-status fsym (SQLFreeStmt stmt SQL_CLOSE) stmt)
|
|
(handle-status fsym (SQLFreeHandle SQL_HANDLE_STMT stmt) stmt)
|
|
(values result-dvecs rows)))))
|
|
;; Layout is: #(catalog schema table table-type remark)
|
|
(rows-result (map field-dvec->field-info dvecs)
|
|
rows))
|
|
|#
|
|
|
|
;; Handler
|
|
|
|
(define add-notice! ;; field, not method; allocate only once
|
|
(lambda (sqlstate message)
|
|
(add-delayed-call! (lambda () (notice-handler sqlstate message)))))
|
|
|
|
(define/private (handle-status who s [handle #f]
|
|
#:ignore-ok/info? [ignore-ok/info? #f])
|
|
(define (handle-error e)
|
|
;; On error, driver may rollback whole transaction, last statement, etc.
|
|
;; Options:
|
|
;; 1) if transaction was rolled back, set autocommit=true
|
|
;; 2) automatically rollback on error
|
|
;; 3) create flag: "transaction had error, please call rollback" (like pg)
|
|
;; Option 1 would be nice, but as far as I can tell, there's
|
|
;; no way to find out if the transaction was rolled back. And
|
|
;; it would be very bad to leave autocommit=false, because
|
|
;; that would be interpreted as "still in same transaction".
|
|
;; Go with (3) for now, maybe support (2) as option later.
|
|
;; FIXME: I worry about multi-statements like "<cause error>; commit"
|
|
;; if the driver does one-statement rollback.
|
|
(let ([db db])
|
|
(when db
|
|
(when tx-status
|
|
(set! tx-status 'invalid))))
|
|
(raise e))
|
|
;; Be careful: shouldn't do rollback before we call handle-status*
|
|
;; just in case rollback destroys statement with diagnostic records.
|
|
(with-handlers ([exn:fail? handle-error])
|
|
(handle-status* who s handle
|
|
#:ignore-ok/info? ignore-ok/info?
|
|
#:on-notice add-notice!)))
|
|
|
|
(super-new)
|
|
(register-finalizer this (lambda (obj) (send obj disconnect)))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define (handle-status* who s [handle #f]
|
|
#:ignore-ok/info? [ignore-ok/info? #f]
|
|
#:on-notice [on-notice void])
|
|
(cond [(= s SQL_SUCCESS_WITH_INFO)
|
|
(when (and handle (not ignore-ok/info?))
|
|
(diag-info who handle 'notice on-notice))
|
|
s]
|
|
[(= s SQL_ERROR)
|
|
(when handle (diag-info who handle 'error #f))
|
|
(uerror who "unknown error (no diagnostic returned)")]
|
|
[else s]))
|
|
|
|
(define (diag-info who handle mode on-notice)
|
|
(let ([handle-type
|
|
(cond [(sqlhenv? handle) SQL_HANDLE_ENV]
|
|
[(sqlhdbc? handle) SQL_HANDLE_DBC]
|
|
[(sqlhstmt? handle) SQL_HANDLE_STMT]
|
|
[else
|
|
(error/internal 'diag-info "unknown handle type: ~e" handle)])])
|
|
(let-values ([(status sqlstate native-errcode message)
|
|
(SQLGetDiagRec handle-type handle 1)])
|
|
(case mode
|
|
((error)
|
|
(raise-sql-error who sqlstate message
|
|
`((code . ,sqlstate)
|
|
(message . ,message)
|
|
(native-errcode . ,native-errcode))))
|
|
((notice)
|
|
(on-notice sqlstate message))))))
|
|
|
|
(define (field-dvec->field-info dvec)
|
|
`((name . ,(vector-ref dvec 0))
|
|
(typeid . ,(vector-ref dvec 1))
|
|
(size . ,(vector-ref dvec 2))
|
|
(digits . ,(vector-ref dvec 3))))
|
|
|
|
(define (field-dvec->typeid dvec)
|
|
(vector-ref dvec 1))
|
|
|
|
#|
|
|
Historical note: I tried using ODBC async execution to avoid blocking
|
|
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
|
|
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
|
|
something stable across invocations.
|
|
|
|
All in all, not worth it, especially given #:use-place solution.
|
|
|#
|