scsh-0.5/scsh/odbc/odbc2.scm

713 lines
28 KiB
Scheme
Raw Normal View History

;;; Sam Thibault
;;; ODBC/SQL interface for scsh
;;; Spring 1999
;;; This is file: odbc2.scm
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; General Comments
;;; ----------------
;;; This file contains the functions used by scsh-sql.scm. These functions
;;; are the original define-foreigns for the ODBC functions (from odbc0.scm)
;;; enclosed in the scsh-sql error system (in odbc1.scm). These functions also
;;; handling all the neccesary memory allocation the ODBC functions require.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Values defined by ODBC
(define sql-param-input 1)
(define sql-c-default 99)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Scheme Names
;;; ------------
;;; The define-foreigns for ODBC library functions (in odbc0.scm) rename the
;;; functions by replacing the beginning "SQL" with "%" and hyphenating the
;;; function name. For example "SQLAllocConnect" becomes "%alloc-connect".
;;; The function used by scsh-sql.scm is the name without the "%". These
;;; functions are created below by encapsulating the %-name within a translate-
;;; return and doing neccesary memory allocation within the function. This
;;; provides a clean Scheme-like interface for scsh-sql.scm
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; alloc-connect allocates memory for a connection handle within the
;;; environment returned from server-env.
(define (alloc-connect)
(let ((con (make-connection))
(env (de-ref-env (server-env))))
(translate-return (%alloc-connect env con)
'alloc-connect
*environment*
con
#f)
con))
;;; server-env checks if an environment handle has been created. If there is
;;; a current henv it returns it; otherwise, server-env allocates a new henv
;;; sets it as the current henv, and returns the henv.
;;;
;;; server-env was renamed from alloc-env because this function only allocates
;;; a new environment handle if none exists.
(define (server-env)
(if (not *environment*)
(let ((env (make-environment)))
(translate-return (%alloc-env env)
'server-env
env
#f
#f)
(set! *environment* env)))
*environment*)
;;; alloc-stmt allocates memory for a statement handle and associates the
;;; statement handle with the specified connection. alloc-stmt must be called
;;; before executing any SQL statements.
(define (alloc-stmt con)
(let ((stmt (make-statement)))
(translate-return (%alloc-stmt (de-ref-con con)
stmt)
'alloc-stmt
#f ; env handle ignored by sql-error
con
stmt)
stmt))
;;; bind-col assigns storage and data type for a column in a result set. The
;;; newly created storage, "target" is returned.
(define (bind-col cmd icol type precision)
(let ((p (make-SDWORD))
(stmt (sql-command:statement cmd)))
(assign-SDWORD p precision)
(let* ((target-size p)
(target (make-storage target-size)))
(translate-return (%bind-col (de-ref-stmt stmt)
icol
(if (or (= type sql/integer)
(= type sql/smallint))
type
sql/char)
target
(if (or (= type sql/integer)
(= type sql/smallint))
(extract-SDWORD target-size)
(+ 1 (extract-SDWORD target-size)))
target-size)
'bind-col
#f ; env handle ignored by sql-error
#f ; con handle ignored by sql-error
stmt)
target)))
;;; bind-parameter binds a buffer to a parameter marker in an SQL statement.
(define (bind-parameter cmd coln data-type precision scale param)
;; create buffers
(receive (target-size)
(cond ((= data-type sql/char)
(assign-SDWORD (make-SDWORD) (+ 1 precision)))
((or (= data-type sql/numeric)
(= data-type sql/decimal)
(= data-type sql/float)
(= data-type sql/real)
(= data-type sql/double))
(assign-SDWORD (make-SDWORD)
(+ 1 (string-length (number->string param)))))
((or (= data-type sql/integer)
(= data-type sql/smallint))
(assign-SDWORD (make-SDWORD) precision))
((= data-type sql/varchar)
(assign-SDWORD (make-SDWORD) (string-length param)))
(else (error "unsupported parameter type: "
(type-val->string data-type))))
(receive (target)
(cond ((= data-type sql/char)
(fixed-string->void* param precision
(make-storage target-size)))
((or (= data-type sql/numeric)
(= data-type sql/decimal)
(= data-type sql/float)
(= data-type sql/real)
(= data-type sql/double))
(number->void* param (make-storage target-size)))
((or (= data-type sql/integer)
(= data-type sql/smallint))
(integer->void* param (make-storage target-size)))
((= data-type sql/varchar)
(string->void* param (make-storage target-size)))
(else (error "unsupported parameter type: "
(type-val->string data-type))))
;; do it
(let ((stmt (sql-command:statement cmd)))
(translate-return (%bind-parameter (de-ref-stmt stmt)
coln
sql-param-input
sql-c-default
data-type
precision
scale
target ;storage-pointer
(extract-SDWORD target-size) ;buf-lng
target-size ;available-bytes
'bind-parameter
#f ; env handle ignored by sql-error
#f ; con handle ignored by sql-error
stmt))))))
;;; cancel cancels the processing on a statement.
(define (cancel cmd)
(let ((stmt (sql-command:statement cmd)))
(translate-return (%cancel (de-ref-stmt stmt))
'cancel
#f ; env handle ignored by sql-error
#f ; con handle ignored by sql-error
stmt)))
;;; col-attributes returns descriptor information for a cloumn in a result set.
;;; col-attributes descriptor types:
(define column-auto-increment 11) ; pfDesc (int return in desriptor-pointer)
(define column-case-sensitive 12) ; pfDesc
(define column-count 0) ; pfDesc
(define column-display-size 6) ; pfDesc
(define column-length 3) ; pfDesc
(define column-money 9) ; pfDesc
(define column-name 1) ; rgbDesc (string return in storage-pointer)
(define column-nullable 7) ; pfDesc
(define column-precision 4) ; pfDesc
(define column-scale 5) ; pfDesc
(define column-searchable 13) ; pfDesc
(define column-data-type 2) ; pfDesc
(define column-type-name 14) ; pfDesc
(define column-unsigned 8) ; pfDesc
(define column-updatable 10) ; pfDesc
(define (col-attributes stmt column-number descriptor-type storage-pointer
buffer-length available-bytes descriptor-pointer)
(translate-return (%col-attributes stmt column-number descriptor-type
storage-pointer buffer-length
available-bytes descriptor-pointer)
'col-attributes
#f ; env handle ignored by sql-error
#f ; con handle ignored by sql-error
stmt))
;;; connect creates a new connection, loads a driver, and establishes a
;;; connection to the data source using the new connection.
(define (connect source-name user-name password)
(let ((con (alloc-connect)))
(translate-return (%connect con
source-name (string-length source-name)
user-name (string-length user-name)
password (string-length password))
'connect
#f
con
#f)
con))
;;; connect! loads a driver, and establishes a connection to the data source
;;; using the supplied connection.
(define (connect! con source-name user-name password)
(translate-return (%connect (de-ref-con con)
source-name (string-length source-name)
user-name (string-length user-name)
password (string-length password))
'connect
*environment*
con
#f))
;;; describe-col returns the result descriptor for one column in a result set.
(define (describe-col cmd icol)
(let ((stmt (sql-command:statement cmd))
(name (make-string 1))
(name-byte-size (make-SWORD))
(data-type (make-SWORD))
(precision (make-UDWORD))
(scale (make-SWORD))
(nullable (make-SWORD)))
(with-sql-info-handler*
(lambda (func code mess henv hdbc hstmt) #t)
(lambda ()
(translate-return (%describe-col (de-ref-stmt stmt) icol name
(+ 1 (string-length name))
name-byte-size data-type precision
scale nullable)
'describe-col
#f ; env handle ignored by sql-error
#f ; con handle ignored by sql-error
stmt)))
(set! name (make-string (extract-SWORD name-byte-size)))
(translate-return (%describe-col (de-ref-stmt stmt) icol name
(+ 1 (string-length name))
name-byte-size data-type precision
scale nullable)
'describe-col
#f ; env handle ignored by sql-error
#f ; con handle ignored by sql-error
stmt)
(values name (extract-SWORD name-byte-size) (extract-SWORD data-type)
(extract-UDWORD precision) (extract-SWORD scale)
(extract-SWORD nullable))))
;;; describe-param returns the description of a parameter marker associated
;;; with a prepared SQL statement.
(define (describe-param cmd coln)
(let ((stmt (sql-command:statement cmd))
(data-type (make-SWORD))
(precision (make-UDWORD))
(scale (make-SWORD))
(nullable (make-SWORD)))
(translate-return (%describe-param (de-ref-stmt stmt) coln data-type
precision scale nullable)
'describe-param
#f ; env handle ignored by sql-error
#f ; con handle ignored by sql-error
stmt)
(values (extract-SWORD data-type)
(extract-UDWORD precision)
(extract-SWORD scale)
(extract-SWORD nullable))))
;;; disconnect closes the connection associated with a specific connection
;;; handle.
(define (disconnect con)
(translate-return (%disconnect (de-ref-con con))
'disconnect
#f
con
#f))
;;; sql-error: see error-system in file odbc1.scm
;;; execdirect executes a preparable statement.
(define (exec-direct stmt sql-string)
(translate-return (%exec-direct stmt sql-string (string-length sql-string))
'exec-direct
#f ; env handle ignored by sql-error
#f ; con handle ignored by sql-error
stmt))
;;; execute executes a prepared statement.
(define (execute stmt)
(translate-return (%execute (de-ref-stmt stmt))
'execute
#f ; env handle ignored by sql-error
#f ; con handle ignored by sql-error
stmt))
;;; fetch fetches a row of data from a result set. The driver returns data
;;; for all columns that were bound to storage locations with bind-col.
(define (fetch cursor)
(if (not (translate-return (%fetch (de-ref-stmt (cursor:stmt cursor)))
'fetch
#f ; env handle ignored by sql-error
#f ; con handle ignored by sql-error
(cursor:stmt cursor)))
;; close the cursor if no more rows
(begin (close-cursor cursor)
#f) ; #f for multi-fetch operations
;; otherwise build the row
(let* ((ncols (cursor:ncols cursor))
(row (make-vector ncols))
(cd (cursor:col-data cursor)))
(let get-cols ((i 0))
(cond ((< i ncols)
(vector-set!
row i ((cond
((or (= (column-type cd i) sql/char)
(= (column-type cd i) sql/varchar))
void*->string)
((or (= (column-type cd i) sql/numeric)
(= (column-type cd i) sql/decimal)
(= (column-type cd i) sql/float)
(= (column-type cd i) sql/real)
(= (column-type cd i) sql/double))
void*->number)
((or (= (column-type cd i) sql/integer)
(= (column-type cd i) sql/smallint))
void*->integer)
((= (column-type cd i) sql/date)
void*->date)
((= (column-type cd i) sql/time)
void*->time)
((= (column-type cd i) sql/timestamp)
void*->timestamp)
(else (error "can't convert type: fetch-rows")))
(column-target cd i)))
(get-cols (+ i 1)))))
row)))
;;; free-connect releases a connection handle and frees all memory associated
;;; with the handle.
(define (free-connect con)
(translate-return (%free-connect (de-ref-con con))
'free-connect
#f
con
#f)
(free-connection con))
;;; free-env frees the environment handle and frees all memory associated
;;; with the environment handle and sets the *environment* variable to #f.
(define (free-env)
(let ((env (if *environment*
*environment*
(error "no current environment"))))
(translate-return (%free-env (de-ref-env env))
'free-env
env
#f
#f)
(free-environment env)
(set! *environment* #f)
#t))
;;; free-stmt stops processing associated with a specific statement handle,
;;; closes any open cursors, discards pending results, and, optionally, frees
;;; all resources associated with the statement handle.
;;;
;;; SQLFreeStmt Flags:
;;;
;;; flag = means this
;;; -----=-----------------
;;; 0 = SQL_CLOSE
;;; 1 = SQL_DROP
;;; 2 = SQL_UNBIND
;;; 3 = SQL_RESET_PARAMS
(define (free-stmt/close stmt)
(translate-return (%free-stmt (de-ref-stmt stmt) 0)
'free-stmt
#f
#f
stmt)
(free-statement stmt)
#t)
(define free-stmt free-stmt/close)
(define (free-stmt/drop stmt)
(translate-return (%free-stmt (de-ref-stmt stmt) 1)
'free-stmt
#f
#f
stmt)
(free-statement stmt)
#t)
(define (free-stmt/unbind stmt)
(translate-return (%free-stmt (de-ref-stmt stmt) 2)
'free-stmt
#f
#f
stmt))
(define (free-stmt/reset stmt)
(translate-return (%free-stmt (de-ref-stmt stmt) 3)
'free-stmt
#f
#f
stmt))
;;; get-cursor-name returns the cursor name associated with a specified
;;; statement handle.
(define (get-cursor-name statement cursor-name name-length bytes-available)
(translate-return (%get-cursor-name statement cursor-name name-length
bytes-available)
'get-cursor-name
#f ; env handle ignored by sql-error
#f ; con handle ignored by sql-error
statement))
(define (cursor-name? cursor)
(let ((c-name (make-string 65))
(c-avail (make-SWORD)))
(assign-SWORD c-avail 64)
(get-cursor-name (de-ref-stmt (cursor:stmt cursor)) c-name 64 c-avail)
c-name))
;;; num-result-cols returns the number of columns in a result set.
(define (num-result-cols cmd)
(let ((stmt (sql-command:statement cmd))
(ncols (make-SWORD)))
(translate-return (%num-result-cols (de-ref-stmt stmt) ncols)
'num-result-cols
#f ; env handle ignored by sql-error
#f ; con handle ignored by sql-error
stmt)
(extract-SWORD ncols)))
;;; prepare allocates a new connection and statement handle and prepares an
;;; SQL string for execution with that hstmt. The new hstmt is returned.
(define (prepare sql-str db)
(let* ((con (db:con db))
(stmt (alloc-stmt con)))
(translate-return (%prepare (de-ref-stmt stmt) sql-str
(string-length sql-str))
'prepare
#f ; env handle ignored by sql-error
#f ; con handle ignored by sql-error
stmt)
stmt))
;;; prepare! prepares an SQL string for execution with the provided hstmt.
(define (prepare! stmt sql-str)
(translate-return (%prepare (de-ref-stmt stmt) sql-str
(string-length sql-str))
'prepare
#f ; env handle ignored by sql-error
#f ; con handle ignored by sql-error
stmt))
;;; row-count returns the number of rows affected by an UPDATE, INSERT, or
;;; DELETE statement.
(define (row-count cmd)
(let ((stmt (sql-command:statement cmd))
(rows (make-SDWORD)))
(translate-return (%row-count (de-ref-stmt stmt) rows)
'row-count
#f ; env handle ignored by sql-error
#f ; con handle ignored by sql-error
stmt)
(extract-SDWORD rows)))
;;; set-cursor-name associates a cursor name with an active statement handle.
;;; If an application does not call set-cursor-name, the driver generates
;;; cursor names as needed for SQL statement processing.
(define (set-cursor-name! cursor cursor-name)
(translate-return (%set-cursor-name (de-ref-stmt (cursor:stmt cursor))
cursor-name
(string-length cursor-name))
'set-cursor-name!
#f ; env handle ignored by sql-error
#f ; con handle ignored by sql-error
(cursor:stmt cursor)))
;;; transact requests a commit or rollback operation for all active operations
;;; on all statement handles associated with a connection.
(define (transact con option)
(let ((env (de-ref-env (server-env))))
(translate-return (%transact env (de-ref-con con) option)
'transact
*environment*
con
#f)))
;;; transact OPTION must be one of these:
(define sql-commit 0)
(define sql-rollback 1)
(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 (call/db host user password proc)
(let ((db (open-db host user password)))
(dynamic-wind (lambda () #t)
(lambda () (proc db))
(lambda () (close-db db)))))
(define (with-open-db* host user password thunk)
(call/db host user password (lambda (db) (let-fluid *current-db* db thunk))))
(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-record sql-command
sql-string ;actual string of sql query, e.g. "select * from ..."
statement ;ODBC statement handle
prep) ;#t if statement has been prepared by odbc command PREPARE
(define (string->sql-command sql-string)
(make-sql-command sql-string
#f
#f))
(define-record db
con) ; ODBC connection handle
(define (open-db host user password)
(let ((con (alloc-connect)))
(connect! con host user password)
(make-db con)))
(define (set-current-db! d)
(if (not (db? d))
(error "Error: set-current-db! must be called with a db as argument.")
(set-fluid! *current-db* d))
d)
(define (close-db . maybe-d)
(let* ((db (:optional maybe-d (current-db)))
(con (db:con db)))
(disconnect con)
(free-connect con)
#t))
(define (execute-sql command . args)
(receive (db params) (if (null? args)
(values (current-db) '())
(values (car args) (cdr args)))
(let* ((con (db:con db))
(cmd (if (sql-command? command)
(begin (if (not (sql-command:statement command))
(set-sql-command:statement
command (alloc-stmt con)))
command)
(make-sql-command command (alloc-stmt con) #f)))
(stmt (sql-command:statement cmd)))
;; Prepare the statement if it's not already prepared.
(if (not (sql-command:prep cmd))
(begin (prepare! stmt (sql-command:sql-string cmd))
(set-sql-command:prep cmd #t)))
;; Do it.
(let ((ncols (num-result-cols cmd)))
(if (not (null? params))
(bind-params cmd params))
(execute stmt)
(let* ((nrows (row-count cmd))
(answer (cond ((> nrows 0) nrows) ;delete,insert,update
((= ncols 0) #t) ;make table
(else ;select
(let ((cursor (prepare-cursor cmd ncols)))
(set-sql-command:prep cmd #f)
(set-sql-command:statement cmd #f)
cursor)))))
;;(if (not (cursor? answer)) ;different free-stmts
;; (free-stmt stmt))
answer)))))
(define (bind-params cmd params)
(let iter ((coln 1) (prms params))
(if (null? prms)
cmd
;; get info for each column
(let ((val (car prms)))
(receive (data-type precision scale nullable)
(describe-param cmd coln)
;; bind it
(bind-parameter cmd
coln
data-type
precision
scale
(cond ((date? val)
(sql-date->string (date->sql-date val)))
((and (= data-type
(or sql/date
sql/time
sql/timestamp))
(integer? val))
(sql-date->string
(date->sql-date (date val))))
(else val)))
;; bind next parameter
(iter (+ 1 coln) (cdr prms)))))))
;; prepare to fetch rows of data
(define (prepare-cursor cmd ncols)
(let ((col-data (make-table-desc (sql-command:statement cmd)
(make-vector ncols))))
(let iter ((icol 1))
(if (<= icol ncols)
;; get info for column
(receive (name name-size data-type precision scale nullable)
(describe-col cmd icol)
;; bind it
(vector-set! (table-desc:cols col-data)
(- icol 1)
(make-column-desc
name name-size data-type precision scale nullable
(bind-col cmd icol data-type precision)))
;; bind the next column
(iter (+ icol 1)))))
(make-cursor col-data ncols (sql-command:statement cmd) cmd)))
;; fetching rows of data
(define fetch-row fetch)
(define (fetch-rows cursor nrows)
(let recur ((nrows nrows))
(if (zero? nrows) '()
(let ((row (fetch-row cursor)))
(if row
(cons row (recur (- nrows 1)))
'())))))
(define (fetch-all cursor)
(let ((row (fetch-row cursor)))
(if row
(cons row (fetch-all cursor))
'())))
;; closing a cursor to recycle statement handle
(define (cursor-closed? cursor)
(not (cursor:cmd cursor)))
(define (close-cursor cursor)
(or (cursor-closed? cursor) ;check if already closed
(let ((stmt (cursor:stmt cursor))
(cmd (cursor:cmd cursor)))
(set-cursor:cmd cursor #f)
(if (sql-command:statement cmd)
(free-stmt/drop stmt)
(set-sql-command:statement cmd (free-stmt/close stmt)))))
#t)
;; commit or rollback
(define (commit db)
(transact (db:con db) sql-commit))
(define (rollback db)
(transact (db:con db) sql-rollback))