138 lines
5.6 KiB
Racket
138 lines
5.6 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
"../generic/interfaces.rkt"
|
|
"../generic/common.rkt"
|
|
"../generic/place-client.rkt"
|
|
"connection.rkt"
|
|
"dbsystem.rkt"
|
|
"ffi.rkt")
|
|
(provide odbc-connect
|
|
odbc-driver-connect
|
|
odbc-data-sources
|
|
odbc-drivers)
|
|
|
|
(define (odbc-connect #:dsn dsn
|
|
#:user [user #f]
|
|
#:password [auth #f]
|
|
#:notice-handler [notice-handler void]
|
|
#:strict-parameter-types? [strict-parameter-types? #f]
|
|
#:character-mode [char-mode 'wchar]
|
|
#:use-place [use-place #f])
|
|
(cond [use-place
|
|
(place-connect (list 'odbc dsn user auth strict-parameter-types? char-mode)
|
|
odbc-proxy%)]
|
|
[else
|
|
(let ([notice-handler (make-handler notice-handler "notice")])
|
|
(call-with-env 'odbc-connect
|
|
(lambda (env)
|
|
(call-with-db 'odbc-connect env
|
|
(lambda (db)
|
|
(let ([status (SQLConnect db dsn user auth)])
|
|
(handle-status* 'odbc-connect status db)
|
|
(new connection%
|
|
(env env)
|
|
(db db)
|
|
(notice-handler notice-handler)
|
|
(strict-parameter-types? strict-parameter-types?)
|
|
(char-mode char-mode))))))))]))
|
|
|
|
(define (odbc-driver-connect connection-string
|
|
#:notice-handler [notice-handler void]
|
|
#:strict-parameter-types? [strict-parameter-types? #f]
|
|
#:character-mode [char-mode 'wchar]
|
|
#:use-place [use-place #f])
|
|
(cond [use-place
|
|
(place-connect (list 'odbc-driver connection-string strict-parameter-types? char-mode)
|
|
odbc-proxy%)]
|
|
[else
|
|
(let ([notice-handler (make-handler notice-handler "notice")])
|
|
(call-with-env 'odbc-driver-connect
|
|
(lambda (env)
|
|
(call-with-db 'odbc-driver-connect env
|
|
(lambda (db)
|
|
(let ([status (SQLDriverConnect db connection-string SQL_DRIVER_NOPROMPT)])
|
|
(handle-status* 'odbc-driver-connect status db)
|
|
(new connection%
|
|
(env env)
|
|
(db db)
|
|
(notice-handler notice-handler)
|
|
(strict-parameter-types? strict-parameter-types?)
|
|
(char-mode char-mode))))))))]))
|
|
|
|
(define (odbc-data-sources)
|
|
(define server-buf (make-bytes 1024))
|
|
(define descr-buf (make-bytes 1024))
|
|
(call-with-env 'odbc-data-sources
|
|
(lambda (env)
|
|
(begin0
|
|
(let loop ()
|
|
(let-values ([(status name description)
|
|
(SQLDataSources env SQL_FETCH_NEXT server-buf descr-buf)])
|
|
(cond [(or (= status SQL_SUCCESS) (= status SQL_SUCCESS_WITH_INFO))
|
|
(cons (list name description) (loop))]
|
|
[else ;; SQL_NO_DATA
|
|
null])))
|
|
(handle-status* 'odbc-data-sources (SQLFreeHandle SQL_HANDLE_ENV env))))))
|
|
|
|
(define (odbc-drivers)
|
|
(define driver-buf (make-bytes 1024))
|
|
(call-with-env 'odbc-drivers
|
|
(lambda (env)
|
|
(let* ([attrlens
|
|
(let loop ()
|
|
(let-values ([(status name attrlen)
|
|
(SQLDrivers env SQL_FETCH_NEXT driver-buf #f)])
|
|
(cond [(or (= status SQL_SUCCESS) (= status SQL_SUCCESS_WITH_INFO))
|
|
(cons attrlen (loop))]
|
|
[else null])))] ;; SQL_NO_DATA
|
|
[attr-buf (make-bytes (+ 1 (apply max 0 attrlens)))] ;; +1 for null terminator
|
|
[result
|
|
(let loop ()
|
|
(let-values ([(status name attrlen) ;; & writes to attr-buf
|
|
(SQLDrivers env SQL_FETCH_NEXT driver-buf attr-buf)])
|
|
(cond [(or (= status SQL_SUCCESS) (= status SQL_SUCCESS_WITH_INFO))
|
|
(cons (list name (parse-driver-attrs attr-buf attrlen))
|
|
(loop))]
|
|
[else null])))]) ;; SQL_NO_DATA
|
|
(handle-status* 'odbc-drivers (SQLFreeHandle SQL_HANDLE_ENV env))
|
|
result))))
|
|
|
|
(define (parse-driver-attrs buf len)
|
|
(let* ([attrs (regexp-split #rx#"\0" buf 0 len)])
|
|
(for/list ([p (in-list attrs)]
|
|
#:when (positive? (bytes-length p)))
|
|
(let* ([s (bytes->string/utf-8 p)]
|
|
[m (regexp-match-positions #rx"=" s)])
|
|
(unless m (error/internal 'odbc-drivers "bad attribute syntax: ~e" s))
|
|
(let ([=-pos (caar m)])
|
|
(cons (substring s 0 =-pos) (substring s (+ 1 =-pos))))))))
|
|
|
|
|
|
(define odbc-proxy%
|
|
(class place-proxy-connection%
|
|
(super-new)
|
|
(define/override (get-dbsystem) dbsystem)))
|
|
|
|
;; ----
|
|
|
|
;; Aux functions to free handles on error.
|
|
|
|
(define (call-with-env fsym proc)
|
|
(let-values ([(status env) (SQLAllocHandle SQL_HANDLE_ENV #f)])
|
|
(with-handlers ([(lambda (e) #t)
|
|
(lambda (e)
|
|
(SQLFreeHandle SQL_HANDLE_ENV env)
|
|
(raise e))])
|
|
(handle-status* fsym status env)
|
|
(handle-status* fsym (SQLSetEnvAttr env SQL_ATTR_ODBC_VERSION SQL_OV_ODBC3))
|
|
(proc env))))
|
|
|
|
(define (call-with-db fsym env proc)
|
|
(let-values ([(status db) (SQLAllocHandle SQL_HANDLE_DBC env)])
|
|
(with-handlers ([(lambda (e) #t)
|
|
(lambda (e)
|
|
(SQLFreeHandle SQL_HANDLE_DBC db)
|
|
(raise e))])
|
|
(handle-status* fsym status db)
|
|
(proc db))))
|