#lang scheme/base
(require (planet bzlib/base)
)
(define-struct driver (connect disconnect query prepare begin commit rollback))
(define-struct handle (driver conn query (trans #:mutable)))
(define-struct prepared (query inner))
(define-struct phq (query converted args) #:prefab)
(define-struct active-record (handle id))
(define-struct effect (rows insert-id status warning-count message error))
(define (result-set-or-effect->result-set rs)
(define (helper v)
(if (not v)
null
v))
(cond ((effect? rs)
(list (list "affected rows" "insert id" "status"
"warning count" "message" "error")
(map helper (list (effect-rows rs)
(effect-insert-id rs)
(effect-status rs)
(effect-warning-count rs)
(effect-message rs)
(effect-error rs)))))
(else rs)))
(define (false-driver . args)
(error 'false-driver! "this is not a true DBI driver - please instantiate one"))
(define current-handle (make-parameter
(make-handle (make-driver false-driver
false-driver
false-driver
false-driver
false-driver
false-driver
false-driver)
#f
#f
0)))
(define drivers (make-immutable-hash-registry))
(define (connect key . args)
(if-it (registry-ref drivers key)
(apply (driver-connect it) it args)
(error 'connect "Unknown driver ~a" key)))
(define (disconnect handle)
((driver-disconnect (handle-driver handle)) handle))
(define (query handle stmt (args '()))
((driver-query (handle-driver handle)) handle stmt args))
(define (prepare handle key stmt)
((driver-prepare (handle-driver handle)) handle key stmt))
(define (begin-trans handle)
((driver-begin (handle-driver handle)) handle))
(define (commit handle)
((driver-commit (handle-driver handle)) handle))
(define (rollback handle)
((driver-rollback (handle-driver handle)) handle))
(define (default-begin handle)
(when (= (handle-trans handle) 0)
(query handle "begin"))
(set-handle-trans! handle (add1 (handle-trans handle))))
(define (default-commit handle)
(when (> (handle-trans handle) 0)
(set-handle-trans! handle (sub1 (handle-trans handle))))
(when (= (handle-trans handle) 0)
(query handle "commit")))
(define (default-rollback handle)
(when (> (handle-trans handle) 0)
(set-handle-trans! handle (sub1 (handle-trans handle))))
(when (= (handle-trans handle) 0)
(query handle "rollback")))
(define dbi-statement/c path-string?)
(define dbi-key/statement/c (or/c symbol? dbi-statement/c))
(provide/contract
(struct driver ((connect procedure?)
(disconnect procedure?)
(query procedure?)
(prepare procedure?)
(begin procedure?)
(commit procedure?)
(rollback procedure?)))
(drivers registry?)
(struct handle ((driver driver?)
(conn any/c)
(query (or/c false/c registry?))
(trans exact-nonnegative-integer?)))
(struct phq ((query string?) (converted string?) (args (listof symbol?))))
(struct prepared ((query phq?)
(inner any/c)))
(struct active-record ((handle (or/c false/c handle?))
(id any/c)
))
(struct effect ((rows (or/c false/c exact-nonnegative-integer?))
(insert-id (or/c false/c exact-nonnegative-integer?))
(status any/c)
(warning-count any/c)
(message any/c)
(error any/c)))
(result-set-or-effect->result-set (-> any/c any))
(current-handle (parameter/c handle?))
(connect (->* (symbol?)
()
#:rest (listof any/c)
handle?))
(disconnect (-> handle? any))
(prepare (-> handle? dbi-key/statement/c dbi-statement/c any))
(query (->* (handle? dbi-key/statement/c)
((listof any/c))
any))
(begin-trans (-> handle? any))
(commit (-> handle? any))
(rollback (-> handle? any))
(default-begin (-> handle? any))
(default-commit (-> handle? any))
(default-rollback (-> handle? any))
)
(provide dbi-statement/c dbi-key/statement/c)