713 lines
28 KiB
Scheme
713 lines
28 KiB
Scheme
|
;;; 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))
|