+ fixed a bug in bindcol example (README)
+ export bindcol, removed odbc-bindcol.scm
This commit is contained in:
eknauel
parent
5f9eb17fed
commit
576420fd48
|
|
@ -258,29 +258,57 @@ with four columns a through d, where a,b,c are integer columns and d
|
|||
is text. Using the fancy odbc-sql-bindcol functions that's pretty
|
||||
easy:
|
||||
|
||||
(define env-handle
|
||||
(odbc-alloc-environment-handle))
|
||||
,open low-odbc
|
||||
,open low-odbc-constants
|
||||
|
||||
(define conn-handle
|
||||
(odbc-alloc-connection-handle env-handle))
|
||||
(define (get-env-handle)
|
||||
(call-with-values
|
||||
odbc-alloc-environment-handle
|
||||
(lambda (status-code env-handle)
|
||||
(if (odbc-call-successful? status-code)
|
||||
env-handle
|
||||
(error "error allocating environment handle")))))
|
||||
|
||||
(odbc-sql-connect conn-handle "test" "odbc" "geheim")
|
||||
(define (get-conn-handle env-handle)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(odbc-alloc-connection-handle env-handle))
|
||||
(lambda (status-code conn-handle)
|
||||
(if (odbc-call-successful? status-code)
|
||||
conn-handle
|
||||
(error "error allocating connection handle")))))
|
||||
|
||||
(define stmt-handle (odbc-alloc-statement-handle conn-handle))
|
||||
(define (get-stmt-handle conn-handle)
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(odbc-alloc-statement-handle conn-handle))
|
||||
(lambda (status-code stmt-handle)
|
||||
(if (odbc-call-successful? status-code)
|
||||
stmt-handle
|
||||
(error "error allocating statement handle")))))
|
||||
|
||||
(odbc-sql-execute-direct stmt-handle "select * from abc")
|
||||
(define env-handle (get-env-handle))
|
||||
(define conn-handle (get-conn-handle env-handle))
|
||||
|
||||
(define col-a (odbc-sql-bindcol stmt-handle 1 sql-type-c-long 1))
|
||||
(define col-b (odbc-sql-bindcol stmt-handle 2 sql-type-c-long 1))
|
||||
(define col-c (odbc-sql-bindcol stmt-handle 3 sql-type-c-long 1))
|
||||
(define col-d (odbc-sql-bindcol stmt-handle 4 sql-type-c-char 400))
|
||||
(odbc-sql-connect conn-handle "pgfbsd" "test" "geheim")
|
||||
|
||||
(define stmt-handle (get-stmt-handle conn-handle))
|
||||
|
||||
(odbc-sql-execute-direct stmt-handle "select * from abcd")
|
||||
|
||||
(define col-a (odbc-sql-bindcol stmt-handle 1 sql-c-long 1))
|
||||
(define col-b (odbc-sql-bindcol stmt-handle 2 sql-c-long 1))
|
||||
(define col-c (odbc-sql-bindcol stmt-handle 3 sql-c-long 1))
|
||||
(define col-d (odbc-sql-bindcol stmt-handle 4 sql-c-char 400))
|
||||
|
||||
(let lp ((retcode (odbc-sql-fetch stmt-handle))
|
||||
(result '()))
|
||||
(if (equal? retcode sql-no-data)
|
||||
result
|
||||
(lp (odbc-sql-fetch stmt-handle)
|
||||
(cons (list (col-a) (col-b) (col-c) (col-d)) result))))
|
||||
(if (or (odbc-call-successful? retcode) (equal? retcode sql-no-data))
|
||||
(if (equal? retcode sql-no-data)
|
||||
result
|
||||
(lp (odbc-sql-fetch stmt-handle)
|
||||
(cons (list (col-a) (col-b) (col-c) (col-d)) result)))
|
||||
(error "Could not SQLFetch()")))
|
||||
|
||||
Please let me know, if you find some bugs. I hereby promise to
|
||||
complete the documentation as soon as possible!
|
||||
|
|
|
|||
|
|
@ -1,37 +0,0 @@
|
|||
|
||||
;;; condition to signal that the buffer was too small
|
||||
(define-condition-type 'odbc-buffer-exceeded '(error))
|
||||
(define odbc-buffer-exceeded?
|
||||
(condition-predicate 'odbc-buffer-exceeded))
|
||||
|
||||
(define (signal-buffer-exceeded buffer-needed buffer-contents)
|
||||
(signal 'odbc-buffer-exceeded buffer-needed buffer-contents))
|
||||
|
||||
(define-exported-binding "signal-buffer-exceeded" signal-buffer-exceeded)
|
||||
|
||||
;;; tried lookup for a column that is not bound
|
||||
(define-condition-type 'odbc-unbound-column '(error))
|
||||
(define odbc-unbound-column?
|
||||
(condition-predicate 'odbc-unbound-column))
|
||||
|
||||
(define (signal-unbound-column stmt-handle column-no)
|
||||
(signal 'odbc-unbound-column stmt-handle column-no))
|
||||
|
||||
(define-exported-binding "signal-unbound-column" signal-unbound-column)
|
||||
|
||||
(define (odbc-sql-bindcol stmt-handle column-no target-type buffer-len)
|
||||
(check-arg statement-handle? stmt-handle odbc-sql-bindcol)
|
||||
(let ((handle (statement-handle-handle stmt-handle)))
|
||||
(odbc-sql-bindcol-internal handle column-no target-type buffer-len)
|
||||
(lambda ()
|
||||
(bindcol-lookup-binding-scheme handle column-no))))
|
||||
|
||||
(import-lambda-definition odbc-sql-bindcol-internal
|
||||
(stmt-handle column-no target-type buffer-len)
|
||||
"odbc_sql_bindcol")
|
||||
|
||||
(import-lambda-definition bindcol-lookup-binding-scheme
|
||||
(stmt-handle column-no)
|
||||
"bindcol_lookup_binding_scheme")
|
||||
|
||||
|
||||
|
|
@ -84,6 +84,7 @@
|
|||
odbc-sql-bulk-operations
|
||||
odbc-sql-more-results
|
||||
odbc-sql-fetch
|
||||
odbc-sql-bindcol
|
||||
|
||||
odbc-sql-column-privileges
|
||||
odbc-sql-columns
|
||||
|
|
|
|||
|
|
@ -3,8 +3,7 @@
|
|||
scheme external-calls scsh-utilities
|
||||
define-record-types
|
||||
conditions signals)
|
||||
(files
|
||||
odbc))
|
||||
(files odbc))
|
||||
|
||||
(define-structure low-odbc-constants low-odbc-constants-interface
|
||||
(open scheme)
|
||||
|
|
|
|||
|
|
@ -1826,7 +1826,7 @@ s48_value odbc_sql_get_diag_recs(s48_value handle_type, s48_value handle)
|
|||
S48_GC_PROTECT_3(res, rec_list, diag_rec);
|
||||
ht = (SQLSMALLINT) s48_extract_integer(handle_type);
|
||||
h = (SQLHANDLE) s48_extract_integer(handle);
|
||||
ODBC_DEBUG_PRINTF_1("odbc_sql_get_diag_recs\n");
|
||||
ODBC_DEBUG_PRINTF_4("SQLGetDiagRec(%d, %x, %i)\n", ht, h, i);
|
||||
|
||||
i = more_recs = 1;
|
||||
buffer_len = odbc_initial_retval_buffer_size;
|
||||
|
|
@ -1844,7 +1844,7 @@ s48_value odbc_sql_get_diag_recs(s48_value handle_type, s48_value handle)
|
|||
if (SQL_SUCCEEDED(retval) && (buffer_needed > buffer_len))
|
||||
{
|
||||
ODBC_DEBUG_PRINTF_3("buffer_needed %d buffer_len %d\n", buffer_needed, buffer_len);
|
||||
buffer_len = buffer_needed+1;
|
||||
buffer_len = buffer_needed+1;
|
||||
}
|
||||
else
|
||||
break;
|
||||
|
|
|
|||
|
|
@ -911,6 +911,20 @@
|
|||
(stmt-handle)
|
||||
"odbc_sql_fetch")
|
||||
|
||||
(define (odbc-sql-bindcol stmt-handle column-no target-type buffer-len)
|
||||
(let ((handle (statement-handle-handle stmt-handle)))
|
||||
(odbc-sql-bindcol-internal handle column-no target-type buffer-len)
|
||||
(lambda ()
|
||||
(bindcol-lookup-binding-scheme handle column-no))))
|
||||
|
||||
(import-lambda-definition odbc-sql-bindcol-internal
|
||||
(stmt-handle column-no target-type buffer-len)
|
||||
"odbc_sql_bindcol")
|
||||
|
||||
(import-lambda-definition bindcol-lookup-binding-scheme
|
||||
(stmt-handle column-no)
|
||||
"bindcol_lookup_binding_scheme")
|
||||
|
||||
;;; PART 8
|
||||
|
||||
(define (odbc-sql-column-privileges stmt-handle catalog-name schema-name
|
||||
|
|
@ -1096,9 +1110,9 @@
|
|||
"odbc_sql_free_handle")
|
||||
|
||||
(define (odbc-sql-get-diag-recs handle)
|
||||
(check-arg odbc-handle? handle odbc-sql-get-diag-recs)
|
||||
(odbc-sql-get-diag-recs-internal (handle-record-type->c-handle-identifier handle)
|
||||
(odbc-handle handle)))
|
||||
(apply values
|
||||
(odbc-sql-get-diag-recs-internal
|
||||
(handle-record-type->c-handle-identifier handle) (odbc-handle handle))))
|
||||
|
||||
(import-lambda-definition odbc-sql-get-diag-recs-internal
|
||||
(handle-type handle)
|
||||
|
|
|
|||
|
|
@ -9,8 +9,7 @@
|
|||
(define (current-db) (fluid *current-db*))
|
||||
|
||||
(define (with-current-db* db thunk)
|
||||
(let-fluid *current-db* db
|
||||
thunk))
|
||||
(let-fluid *current-db* db thunk))
|
||||
|
||||
(define-syntax with-current-db
|
||||
(syntax-rules ()
|
||||
|
|
@ -33,32 +32,34 @@
|
|||
|
||||
(define (open-db database user password)
|
||||
(let* ((env-handle (odbc-alloc-environment-handle))
|
||||
(conn-handle (odbc-alloc-connection-handle env-handle)))
|
||||
(conn-handle (odbc-alloc-connection-handle env-handle))
|
||||
(db (make-db database user password conn-handle)))
|
||||
(begin
|
||||
(db-handle (odbc-sql-connect conn-handle database user password))
|
||||
conn-handle)))
|
||||
(odbc-sql-connect conn-handle database user password)
|
||||
db)))
|
||||
|
||||
(define (set-current-db! thing)
|
||||
(if (connection-handle? thing)
|
||||
(if (db? 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))))
|
||||
(let* ((db (:optional maybe-db (current-db)))
|
||||
(conn-handle (db:con 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)))
|
||||
(let ((db (open-db database user password)))
|
||||
(proc db)
|
||||
(close-db db)))
|
||||
|
||||
;;; what a useless function
|
||||
(define (string->sql-command sql-query)
|
||||
(if (current-db)
|
||||
(odbc-alloc-statement-handle conn-handle)
|
||||
(odbc-alloc-statement-handle (db:con db))
|
||||
(error "Error: You need to connect to a database first (don't ask why)")))
|
||||
|
||||
(define (prepare-execute-sql-args excute-sql-optionals)
|
||||
|
|
@ -72,8 +73,9 @@
|
|||
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)))
|
||||
(let-values* (((db params) (prepare-execute-sql-args args))
|
||||
((conn-handle) (db:con db))
|
||||
((stmt-handle) (maybe-make-statement-handle command)))
|
||||
;;; maybe prepare stmt
|
||||
(if (string? command)
|
||||
(odbc-sql-prepare stmt-handle command))
|
||||
|
|
@ -135,15 +137,48 @@
|
|||
(odbc-sql-bind-parameter-exec-out stmt-handle parameter-vector)))
|
||||
|
||||
(define (prepare-cursor stmt ncols)
|
||||
(error "Not implemented"))
|
||||
(let* ((table-desc-cols (prepare-cursor-get-col-descriptions stmt ncols))
|
||||
(table-desc (make-table-desc stmt (list->vector table-desc-cols)))
|
||||
(col-procs (prepare-cursor-make-col-procs stmt ncols (table-desc:cols table-desc))))
|
||||
(really-make-cursor table-desc ncols stmt #f col-procs)))
|
||||
|
||||
(define fetch-row fetch)
|
||||
(define (prepare-cursor-get-col-descriptions stmt ncols)
|
||||
(let loop ((index ncols) (res '()))
|
||||
(if (zero? index)
|
||||
res
|
||||
(loop (+ index 1)
|
||||
(cons (odbc-sql-describe-col stmt index) res)))))
|
||||
|
||||
(define (prepare-cursor-make-col-procs stmt ncols table-desc-vector)
|
||||
(let loop ((index ncols) (res '()))
|
||||
(if (zero? index)
|
||||
res
|
||||
(loop (+ index 1)
|
||||
(cons (odbc-sql-bind-col
|
||||
stmt index
|
||||
(odbc-type-identifier->c-type-identifier (vector-ref index table-desc-vector))
|
||||
1024)
|
||||
res)))))
|
||||
|
||||
(define (fetch-row cursor)
|
||||
(let loop ((index (cursor:nols cursor)) (res '()))
|
||||
(if (zero? index)
|
||||
(list->vector res)
|
||||
(loop (+ index 1)
|
||||
(cons ((vector-ref index (cursor:col-procs cursor))) res)))))
|
||||
|
||||
(define (fetch-rows cursor nrows)
|
||||
(error "Not implemented"))
|
||||
(let loop ((index nrows) (res '()))
|
||||
(if (zero? index)
|
||||
res
|
||||
(cond ((fetch-row cursor)
|
||||
=> (lambda (row)
|
||||
(loop (- nrows 1) (cons row res))))))))
|
||||
|
||||
(define (fetch-all cursor)
|
||||
(error "Not implemented"))
|
||||
|
||||
|
||||
;;; Cursors
|
||||
|
||||
|
||||
(define (close-cursor cursor)
|
||||
Loading…
Reference in New Issue