Initial version of scshql: The original scsh ODBC API for 0.5.x

written with the new ODBC bindings. Missing: All FETCH functions

scsh/odbc/scshql.scm

@@ -0,0 +1,149 @@
+;;; 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"))
+
+	    
+