scsh-0.6/scsh/odbc/scshql.scm

150 lines
5.2 KiB
Scheme
Raw Normal View History

;;; An implemenation of ScshQL (or Scsh-SQL ?) with the new ODBC bindings
;;;
;;; Eric Knauel <knauel@informatik.uni-tuebingen.de>
;;;
;;; The original API was designed by Sam Thibault (and maybe Olin Shivers) and
;;; can be found at http://web.mit.edu/samt/www/compsci/Scsh-SQL/scsh-sql.tar.gz
(define *current-db* (make-fluid #f))
(define (current-db) (fluid *current-db*))
(define (with-current-db* db thunk)
(let-fluid *current-db* db
thunk))
(define-syntax with-current-db
(syntax-rules ()
((with-current-db db body1 body2 ...)
(with-current-db* db (lambda () body1 body2 ...)))))
(define (with-open-db* dbname user pwd thunk)
(let* ((conn-handle (open-db dbname user pwd)))
(dynamic-wind
(lambda () #t)
(lambda ()
(let-fluid *current-db* db thunk))
(lambda ()
(odbc-sql-disconnect conn-handle)))))
(define-syntax with-open-db
(syntax-rules ()
((with-open-db dbname user pwd body1 body2 ...)
(with-open-db* dbname user pwd (lambda () body1 body2 ...)))))
(define (open-db database user password)
(let* ((env-handle (odbc-alloc-environment-handle))
(conn-handle (odbc-alloc-connection-handle env-handle)))
(begin
(db-handle (odbc-sql-connect conn-handle database user password))
conn-handle)))
(define (set-current-db! thing)
(if (connection-handle? thing)
(set-fluid! *current-db* thing)
(error "Error: set-current-db! must be called with a db as argument."))
thing)
(define (close-db . maybe-db)
(let ((conn-handle (:optional maybe-db (current-db))))
(if (connection-handle-connected? conn-handle)
(odbc-sql-disconnect conn-handle))
#t))
(define (call/db database user password proc)
(let ((conn-handle (open-db database user password)))
(proc conn-handle)
(close-db conn-handle)))
;;; what a useless function
(define (string->sql-command sql-query)
(if (current-db)
(odbc-alloc-statement-handle conn-handle)
(error "Error: You need to connect to a database first (don't ask why)")))
(define (prepare-execute-sql-args excute-sql-optionals)
(if (null? excute-sql-optionals)
(values (current-db) '())
(values (car args) (cdr args))))
(define (maybe-make-statement-handle string-or-stmt-handle)
(if (string? string-or-stmt-handle)
(string->sql-command string->sql-command)
string-or-stmt-handle))
(define (execute-sql command . args)
(let-values (((conn-handle params) (prepare-execute-sql-args args))
((stmt-handle) (maybe-make-statement-handle command)))
;;; maybe prepare stmt
(if (string? command)
(odbc-sql-prepare stmt-handle command))
;;; execute stmt
(let ((ncols (odbc-sql-num-result-cols stmt-handle)))
(if (not (null? params))
(bind-params stmt-handle params))
;;; execute
(odbc-sql-execute stmt-handle)
;;; process answer
(let ((rows-affected (odbc-sql-row-count stmt-handle)))
(cond ((> rows-affected 0)
rows-affected) ;;; must have been a DELETE, INSERT or UPDATE statement
((zero? rows-affected) #t) ;;; is this really correct?!?!?!
(else
(prepare-cursor stmt-handle ncols)))))))
;;; convert execute-sql params list to a parameter vector that is
;;; suitable for odbc-sql-bind-parameter-exec-out
;;; Well, acutally it's only an approximation
(define (make-parameter-vector stmt-handle params)
(let ((param-descriptions (get-parameter-descriptions stmt-handle)))
(list->vector (make-parameter-value-cell-list params param-descriptions))))
(define (make-parameter-value-cell-list params param-descriptions)
(let ((param-descriptions-count (length param-descriptions)))
(let loop ((params params) (index 1) (res '()))
(if (null? params)
(reverse res)
(if (> index param-descriptions-count)
(loop (cdr params) (+ index 1)
(make-parameter-value-cell value (list-ref index param-descriptions)))
;;; more parameters given than needed => error
;;; don't catch error, let ODBC raise the error
(loop (cdr params) (+ index 1)
(cons value (cons sql-type-c-binary sql-type-unknown))))))))
;;; takes the value for parameter and the parameter-description
;;; (a record of type odbc-parameter) and returns a cell that is
;;; suitable to put in a parameter vector for odbc-sql-bind-parameter-exec-out
(define (make-parameter-value-cell value param-description)
(let ((parameter-type (odbc-parameter-type param-description)))
(cons value
(cons (odbc-type-identifier->c-type-identifier parameter-type)
parameter-type))))
;;; returns a list of odbc-parameter records for all parameters
;;; of stmt-handle
(define (get-parameter-descriptions stmt-handle)
(let ((param-count (odbc-sql-num-params stmt-handle)))
(let loop ((param-no param-count) (res '()))
(if (zero? param-no)
res
(loop (- param-no 1)
(cons (odbc-sql-describe-param stmt-handle param-no)))))))
(define (bind-params stmt params)
(let ((parameter-vector (make-parameter-vector stmt-handle params)))
(odbc-sql-bind-parameter-exec-out stmt-handle parameter-vector)))
(define (prepare-cursor stmt ncols)
(error "Not implemented"))
(define fetch-row fetch)
(define (fetch-rows cursor nrows)
(error "Not implemented"))
(define (fetch-all cursor)
(error "Not implemented"))