415 lines
14 KiB
Scheme
415 lines
14 KiB
Scheme
|
;;; Sam Thibault
|
||
|
|
;;; ODBC/SQL interface for scsh
|
||
|
|
;;; Spring 1999
|
||
|
|
|
||
|
|
;;; This is file: odbc1.scm
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;;
|
||
|
|
;;; General Comments
|
||
|
|
;;; ----------------
|
||
|
|
;;; This file contains several items:
|
||
|
|
;;;
|
||
|
|
;;; 1. Mappings of sql/odbc/c datatypes to integer values used by ODBC.
|
||
|
|
;;;
|
||
|
|
;;; 2. Definitions of records used by the scsh-sql interface and some
|
||
|
|
;;; additional tools for accessing the records/vector structures.
|
||
|
|
;;;
|
||
|
|
;;; 3. Error handling tools for scsh-sql.
|
||
|
|
;;;
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
|
||
|
|
;;; The headers below will be included in C file the generated by cig
|
||
|
|
|
||
|
|
(foreign-source
|
||
|
|
"#if 0"
|
||
|
|
"#include \"cli0cli.h\""
|
||
|
|
"#include \"cli0defs.h\""
|
||
|
|
"#include \"cli0env.h\""
|
||
|
|
"#else"
|
||
|
|
"#include <windows.h>"
|
||
|
|
"#include <sql.h>"
|
||
|
|
"#include <sqlext.h>"
|
||
|
|
"#endif"
|
||
|
|
"")
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;;
|
||
|
|
;;; Datatypes
|
||
|
|
;;; ---------
|
||
|
|
;;; These value assign sql/odbc/c datatypes to the values used by odbc. There
|
||
|
|
;;; is also a function to decode the integer values so error messages can b
|
||
|
|
;;; more useful.
|
||
|
|
;;;
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
|
||
|
|
(define sql/char 1)
|
||
|
|
(define sql/numeric 2)
|
||
|
|
(define sql/decimal 3)
|
||
|
|
(define sql/integer 4)
|
||
|
|
(define sql/smallint 5)
|
||
|
|
(define sql/float 6)
|
||
|
|
(define sql/real 7)
|
||
|
|
(define sql/double 8)
|
||
|
|
(define sql/varchar 12)
|
||
|
|
(define sql/date 9)
|
||
|
|
(define sql/time 10)
|
||
|
|
(define sql/timestamp 11)
|
||
|
|
(define sql/longvarchar -1)
|
||
|
|
(define sql/binary -2)
|
||
|
|
(define sql/varbinary -3)
|
||
|
|
(define sql/longvarbinary -4)
|
||
|
|
(define sql/bigint -5)
|
||
|
|
(define sql/tinyint -6)
|
||
|
|
(define sql/bit -7)
|
||
|
|
|
||
|
|
(define (type-val->string type)
|
||
|
|
(cond
|
||
|
|
((= type sql/char) "sql/char")
|
||
|
|
((= type sql/numeric) "sql/numeric")
|
||
|
|
((= type sql/decimal) "sql/decimal")
|
||
|
|
((= type sql/integer) "sql/integer")
|
||
|
|
((= type sql/smallint) "sql/smallint")
|
||
|
|
((= type sql/float) "sql/float")
|
||
|
|
((= type sql/real) "sql/real")
|
||
|
|
((= type sql/double) "sql/double")
|
||
|
|
((= type sql/varchar) "sql/varchar")
|
||
|
|
((= type sql/date) "sql/date")
|
||
|
|
((= type sql/time) "sql/time")
|
||
|
|
((= type sql/timestamp) "sql/timestamp")
|
||
|
|
((= type sql/longvarchar) "sql/longvarchar")
|
||
|
|
((= type sql/binary) "sql/binary")
|
||
|
|
((= type sql/varbinary) "sql/varbinary")
|
||
|
|
((= type sql/longvarbinary) "sql/longvarbinary")
|
||
|
|
((= type sql/bigint) "sql/bigint")
|
||
|
|
((= type sql/tinyint) "sql/tinyint")
|
||
|
|
((= type sql/bit) "sql/bit")
|
||
|
|
(else "unknown data type")))
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;;
|
||
|
|
;;; Records
|
||
|
|
;;; -------
|
||
|
|
;;; Here are definitions of records/vectors for storing table-descriptions and
|
||
|
|
;;; cursor information.
|
||
|
|
;;;
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
|
||
|
|
;;;
|
||
|
|
;;; making a reference chart
|
||
|
|
;;;
|
||
|
|
;;; +-------+
|
||
|
|
;;; cursor -> | hstmt |
|
||
|
|
;;; +-------+ +---+---+---+---+---+---+ - - - - - - +---+
|
||
|
|
;;; | cols -+-----> | 0 | 1 | 2 | 3 | 4 | 5 | | N |
|
||
|
|
;;; +-------+ +---+---+-+-+---+---+---+ - - - - - - +---+
|
||
|
|
;;; |
|
||
|
|
;;; | +-------------+
|
||
|
|
;;; +--> | column name |
|
||
|
|
;;; +-------------+
|
||
|
|
;;; | name size |
|
||
|
|
;;; +-------------+
|
||
|
|
;;; | data type |
|
||
|
|
;;; +-------------+
|
||
|
|
;;; | precision |
|
||
|
|
;;; +-------------+
|
||
|
|
;;; | scale |
|
||
|
|
;;; +-------------+
|
||
|
|
;;; | nullable | (alien)
|
||
|
|
;;; +-------------+ +-------+
|
||
|
|
;;; | <target>----+---> | data |
|
||
|
|
;;; +-------------+ +-------+
|
||
|
|
;;;
|
||
|
|
|
||
|
|
(define-record column-desc
|
||
|
|
name
|
||
|
|
size
|
||
|
|
type
|
||
|
|
precision
|
||
|
|
scale
|
||
|
|
nullable
|
||
|
|
target)
|
||
|
|
|
||
|
|
(define-record table-desc
|
||
|
|
hstmt ; ODBC statment handle
|
||
|
|
cols) ; vector of column-desc records (see above)
|
||
|
|
|
||
|
|
;;; These functions reference items in the cursor.
|
||
|
|
|
||
|
|
(define (column-name table-desc column-number)
|
||
|
|
(column-desc:name (vector-ref (table-desc:cols table-desc)
|
||
|
|
column-number)))
|
||
|
|
|
||
|
|
(define (column-size table-desc column-number)
|
||
|
|
(column-desc:size (vector-ref (table-desc:cols table-desc)
|
||
|
|
column-number)))
|
||
|
|
|
||
|
|
(define (column-type table-desc column-number)
|
||
|
|
(column-desc:type (vector-ref (table-desc:cols table-desc)
|
||
|
|
column-number)))
|
||
|
|
|
||
|
|
(define (column-precision table-desc column-number)
|
||
|
|
(column-desc:precision (vector-ref (table-desc:cols table-desc)
|
||
|
|
column-number)))
|
||
|
|
|
||
|
|
(define (column-scale table-desc column-number)
|
||
|
|
(column-desc:scale (vector-ref (table-desc:cols table-desc)
|
||
|
|
column-number)))
|
||
|
|
|
||
|
|
(define (column-nullable table-desc column-number)
|
||
|
|
(column-desc:nullable (vector-ref (table-desc:cols table-desc)
|
||
|
|
column-number)))
|
||
|
|
|
||
|
|
(define (column-target table-desc column-number)
|
||
|
|
(column-desc:target (vector-ref (table-desc:cols table-desc)
|
||
|
|
column-number)))
|
||
|
|
|
||
|
|
;;; These functions are for changing items in a cursor.
|
||
|
|
|
||
|
|
(define (set-column-name! table-desc column-number val)
|
||
|
|
(set-column-desc:name (vector-ref (table-desc:cols table-desc)
|
||
|
|
column-number)
|
||
|
|
val))
|
||
|
|
|
||
|
|
(define (set-column-size! table-desc column-number val)
|
||
|
|
(set-column-desc:size (vector-ref (table-desc:cols table-desc)
|
||
|
|
column-number)
|
||
|
|
val))
|
||
|
|
|
||
|
|
(define (set-column-type! table-desc column-number val)
|
||
|
|
(set-column-desc:type (vector-ref (table-desc:cols table-desc)
|
||
|
|
column-number)
|
||
|
|
val))
|
||
|
|
|
||
|
|
(define (set-column-precision! table-desc column-number val)
|
||
|
|
(set-column-desc:precision (vector-ref (table-desc:cols table-desc)
|
||
|
|
column-number)
|
||
|
|
val))
|
||
|
|
|
||
|
|
(define (set-column-scale! table-desc column-number val)
|
||
|
|
(set-column-desc:scale (vector-ref (table-desc:cols table-desc)
|
||
|
|
column-number)
|
||
|
|
val))
|
||
|
|
|
||
|
|
(define (set-column-nullable! table-desc column-number val)
|
||
|
|
(set-column-desc:nullable (vector-ref (table-desc:cols table-desc)
|
||
|
|
column-number)
|
||
|
|
val))
|
||
|
|
|
||
|
|
(define (set-column-target! table-desc column-number val)
|
||
|
|
(set-column-desc:target (vector-ref (table-desc:cols table-desc)
|
||
|
|
column-number)
|
||
|
|
val))
|
||
|
|
|
||
|
|
(define-record cursor
|
||
|
|
col-data ; a table-desc
|
||
|
|
ncols ; number of cols in desc
|
||
|
|
stmt ; statement handle
|
||
|
|
cmd) ; command that created this cursor (to recycle stmt handle)
|
||
|
|
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
;;;
|
||
|
|
;;; Error system
|
||
|
|
;;; ------------
|
||
|
|
;;; The functions defined here signal and handle errors in the scsh-sql
|
||
|
|
;;; interface. The define-foreigns link to C functions defined in scsh-sql.c.
|
||
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||
|
|
|
||
|
|
;;; These functions get the error message from ODBC
|
||
|
|
|
||
|
|
(define-foreign get-henv-error-state
|
||
|
|
("GetHenvErrorState" ((C "SQLHENV ~a") environment))
|
||
|
|
static-string
|
||
|
|
static-string)
|
||
|
|
|
||
|
|
(define-foreign get-hdbc-error-state
|
||
|
|
("GetHdbcErrorState" ((C "SQLHENV ~a") environment)
|
||
|
|
((C "SQLHDBC ~a") connection))
|
||
|
|
static-string
|
||
|
|
static-string)
|
||
|
|
|
||
|
|
(define-foreign get-hstmt-error-state
|
||
|
|
("GetHstmtErrorState" ((C "SQLHENV ~a") environment)
|
||
|
|
((C "SQLHSTMT ~a") statement))
|
||
|
|
static-string
|
||
|
|
static-string)
|
||
|
|
|
||
|
|
(define (sql-error environment connection statement)
|
||
|
|
(cond (statement (get-hstmt-error-state (de-ref-env (server-env))
|
||
|
|
(de-ref-stmt statement)))
|
||
|
|
(connection (get-hdbc-error-state (de-ref-env (server-env))
|
||
|
|
(de-ref-con connection)))
|
||
|
|
(else (get-henv-error-state (de-ref-env environment)))))
|
||
|
|
|
||
|
|
;;; In order to deal with odbc errors, we will wrap the define-foreigns for
|
||
|
|
;;; the ODBC functions in Scheme functions that can raise an appropriate error.
|
||
|
|
;;; First, we define conditions for 5 of the 7 possible odbc error types. For
|
||
|
|
;;; two of the ODBC functions we will return a boolean value.
|
||
|
|
;;;
|
||
|
|
;;; code = odbc return type = scheme condition
|
||
|
|
;;;------=-----------------------=-----------------
|
||
|
|
;;; (-2) = SQL_INVALID_HANDLE = sql-invalid-error
|
||
|
|
;;; (-1) = SQL_ERROR = sql-error
|
||
|
|
;;; 0 = SQL_SUCCESS = #t
|
||
|
|
;;; 1 = SQL_SUCCESS_WITH_INFO = sql-info-warning
|
||
|
|
;;; 2 = SQL_STILL_EXECUTING = sql-busy-exception
|
||
|
|
;;; 99 = SQL_NEED_DATA = sql-param-exception
|
||
|
|
;;; 100 = SQL_NO_DATA_FOUND = #f
|
||
|
|
|
||
|
|
;;; SQL_INVALID_HANDLE
|
||
|
|
(define-condition-type 'sql-invalid-error '(error))
|
||
|
|
(define sql-invalid-error? (condition-predicate 'sql-invalid-error))
|
||
|
|
|
||
|
|
(define (raise-sql-invalid-error function code message henv hdbc hstmt)
|
||
|
|
(signal 'sql-invalid-error function code message henv hdbc hstmt))
|
||
|
|
|
||
|
|
;;; SQL_ERROR
|
||
|
|
(define-condition-type 'sql-error '(error))
|
||
|
|
(define sql-error? (condition-predicate 'sql-error))
|
||
|
|
|
||
|
|
(define (raise-sql-error function code message henv hdbc hstmt)
|
||
|
|
(signal 'sql-error function code message henv hdbc hstmt))
|
||
|
|
|
||
|
|
;;; SQL_SUCCESS
|
||
|
|
;;; #t
|
||
|
|
|
||
|
|
;;; SQL_SUCCESS_WITH_INFO
|
||
|
|
(define-condition-type 'sql-info-warning '())
|
||
|
|
(define sql-info-warning? (condition-predicate 'sql-info-warning))
|
||
|
|
|
||
|
|
(define (raise-sql-info-warning function code message henv hdbc hstmt)
|
||
|
|
(signal 'sql-info-warning function code message henv hdbc hstmt))
|
||
|
|
|
||
|
|
;;; SQL_STILL_EXECUTING
|
||
|
|
(define-condition-type 'sql-busy-exception '(error))
|
||
|
|
(define sql-busy-exception? (condition-predicate 'sql-busy-exception))
|
||
|
|
|
||
|
|
(define (raise-sql-busy-exception function code message henv hdbc hstmt)
|
||
|
|
(signal 'sql-busy-exception function code message henv hdbc hstmt))
|
||
|
|
|
||
|
|
;;; SQL_NEED_DATA
|
||
|
|
(define-condition-type 'sql-param-exception '(error))
|
||
|
|
(define sql-param-exception? (condition-predicate 'sql-param-exception))
|
||
|
|
|
||
|
|
(define (raise-sql-param-exception function code message henv hdbc hstmt)
|
||
|
|
(signal 'sql-param-exception function code message henv hdbc hstmt))
|
||
|
|
|
||
|
|
;;; SQL_NO_DATA_FOUND
|
||
|
|
;;; #f
|
||
|
|
|
||
|
|
;;; translate-return is the function which will enclose the define-foreigns of
|
||
|
|
;;; the ODBC functions. For the errors/exceptions/warnings which can be
|
||
|
|
;;; raised there is a handler defined below.
|
||
|
|
|
||
|
|
(define (translate-return return-code function henv hdbc hstmt)
|
||
|
|
(receive (code message) (sql-error henv hdbc hstmt)
|
||
|
|
(case return-code
|
||
|
|
((-2) (raise-sql-invalid-error function code message
|
||
|
|
henv hdbc hstmt)) ;; INVALID_HANDLE
|
||
|
|
((-1) (raise-sql-error function code message
|
||
|
|
henv hdbc hstmt)) ;; SQL_ERROR
|
||
|
|
((0) #t) ;; SQL_SUCCESS
|
||
|
|
((1) (raise-sql-info-warning function code message
|
||
|
|
henv hdbc hstmt)
|
||
|
|
#t) ;; SQL_SUCCESS_WITH_INFO
|
||
|
|
((2) (raise-sql-busy-exception function code message
|
||
|
|
henv hdbc hstmt)) ;; STILL_EXECUTING
|
||
|
|
((99) (raise-sql-param-exception function code message
|
||
|
|
henv hdbc hstmt)) ;;SQL_NEED_DATA
|
||
|
|
((100) #f) ;; SQL_NO_DATA_FOUND
|
||
|
|
(else (error function
|
||
|
|
"impossible return code: contact samt@ai.mit.edu")))))
|
||
|
|
|
||
|
|
;;; Tools for handlers.
|
||
|
|
|
||
|
|
(define (with-sql-invalid-handler* handler thunk)
|
||
|
|
(with-handler
|
||
|
|
(lambda (condition more)
|
||
|
|
(if (sql-invalid-error? condition)
|
||
|
|
(let ((stuff (cdr condition))) ; (function code message)
|
||
|
|
(handler (car stuff) ; function
|
||
|
|
(cadr stuff) ; error code
|
||
|
|
(caddr stuff) ; error message
|
||
|
|
(list-ref stuff 3) ; henv
|
||
|
|
(list-ref stuff 4) ; hdbc
|
||
|
|
(list-ref stuff 5)))) ; hstmt
|
||
|
|
(more))
|
||
|
|
thunk))
|
||
|
|
|
||
|
|
(define (with-sql-error-handler* handler thunk)
|
||
|
|
(with-handler
|
||
|
|
(lambda (condition more)
|
||
|
|
(if (sql-error? condition)
|
||
|
|
(let ((stuff (cdr condition))) ; (function code message)
|
||
|
|
(handler (car stuff) ; function
|
||
|
|
(cadr stuff) ; error code
|
||
|
|
(caddr stuff) ; error message
|
||
|
|
(list-ref stuff 3) ; henv
|
||
|
|
(list-ref stuff 4) ; hdbc
|
||
|
|
(list-ref stuff 5)))) ; hstmt
|
||
|
|
(more))
|
||
|
|
thunk))
|
||
|
|
|
||
|
|
(define (with-sql-info-handler* handler thunk)
|
||
|
|
(with-handler
|
||
|
|
(lambda (condition more)
|
||
|
|
(if (sql-info-warning? condition)
|
||
|
|
(let ((stuff (cdr condition))) ; (function code message)
|
||
|
|
(handler (car stuff) ; function
|
||
|
|
(cadr stuff) ; error code
|
||
|
|
(caddr stuff) ; error message
|
||
|
|
(list-ref stuff 3) ; henv
|
||
|
|
(list-ref stuff 4) ; hdbc
|
||
|
|
(list-ref stuff 5)))) ; hstmt
|
||
|
|
(more))
|
||
|
|
thunk))
|
||
|
|
|
||
|
|
(define (with-sql-busy-handler* handler thunk)
|
||
|
|
(with-handler
|
||
|
|
(lambda (condition more)
|
||
|
|
(if (sql-busy-exception? condition)
|
||
|
|
(let ((stuff (cdr condition))) ; (function code message)
|
||
|
|
(handler (car stuff) ; function
|
||
|
|
(cadr stuff) ; error code
|
||
|
|
(caddr stuff) ; error message
|
||
|
|
(list-ref stuff 3) ; henv
|
||
|
|
(list-ref stuff 4) ; hdbc
|
||
|
|
(list-ref stuff 5)))) ; hstmt
|
||
|
|
(more))
|
||
|
|
thunk))
|
||
|
|
|
||
|
|
(define (with-sql-param-handler* handler thunk)
|
||
|
|
(with-handler
|
||
|
|
(lambda (condition more)
|
||
|
|
(if (sql-param-exception? condition)
|
||
|
|
(let ((stuff (cdr condition))) ; (function code message)
|
||
|
|
(handler (car stuff) ; function
|
||
|
|
(cadr stuff) ; error code
|
||
|
|
(caddr stuff) ; error message
|
||
|
|
(list-ref stuff 3) ; henv
|
||
|
|
(list-ref stuff 4) ; hdbc
|
||
|
|
(list-ref stuff 5)))) ; hstmt
|
||
|
|
(more))
|
||
|
|
thunk))
|
||
|
|
|
||
|
|
;;; Catch all sql errors/exceptions/warnings.
|
||
|
|
|
||
|
|
(define (with-sql-handler* handler thunk)
|
||
|
|
(with-handler
|
||
|
|
(lambda (condition more)
|
||
|
|
(if (or (sql-invalid-error? condition)
|
||
|
|
(sql-error? condition)
|
||
|
|
(sql-info-warning? condition)
|
||
|
|
(sql-busy-exception? condition)
|
||
|
|
(sql-param-exception? condition))
|
||
|
|
(let ((stuff (cdr condition))) ; (function code message)
|
||
|
|
(handler (car stuff) ; function
|
||
|
|
(cadr stuff) ; error code
|
||
|
|
(caddr stuff) ; error message
|
||
|
|
(list-ref stuff 3) ; henv
|
||
|
|
(list-ref stuff 4) ; hdbc
|
||
|
|
(list-ref stuff 5)))) ; hstmt
|
||
|
|
(more))
|
||
|
|
thunk))
|
||
|
|
|