1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: Mid-level (DBI) interface for CLSQL ODBC backend
7 ;;;; Author: Kevin M. Rosenberg
8 ;;;; Create: April 2004
12 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
14 ;;;; CLSQL users are granted the rights to distribute and use this software
15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
17 ;;;; *************************************************************************
19 (in-package #:cl-user
)
21 (defpackage #:odbc-dbi
33 #:list-all-data-sources
34 #:list-all-database-tables
35 #:list-all-table-columns
46 #:*default-odbc-external-format
*
49 (:documentation
"This is the mid-level interface ODBC."))
51 (in-package #:odbc-dbi
)
53 (defgeneric terminate
(src))
54 (defgeneric db-open-query
(src query-expression
55 &key arglen col-positions result-types width
57 (defgeneric db-fetch-query-results
(src &optional count
))
58 (defgeneric %db-execute
(src sql-expression
&key
&allow-other-keys
))
59 (defgeneric db-execute-command
(src sql-string
))
61 (defgeneric %initialize-query
(src arglen col-positions
62 &key result-types width
))
64 (defgeneric %read-query-data
(src ignore-columns
))
65 (defgeneric db-map-query
(src type function query-exp
&key result-types
))
66 (defgeneric db-prepare-statement
(src sql
&key parameter-table
68 (defgeneric get-odbc-info
(src info-type
))
74 (;; any reason to have more than one henv?
75 (width :initform
+max-precision
+ :accessor db-width
)
76 (hstmt :initform nil
:accessor db-hstmt
)
77 (henv :initform nil
:allocation
:class
:initarg
:henv
:accessor henv
)
78 (hdbc :initform nil
:initarg
:hdbc
:accessor hdbc
)
79 ;; info returned from SQLGetInfo
80 (info :initform
(make-hash-table) :reader db-info
)
81 (type :initform nil
:initarg
:db-type
:reader db-type
)
82 (connected-p :initform nil
:accessor db-connected-p
)
84 (count :initform
0 :initarg
:count
:accessor db-count
)
86 (total-count :initform
0 :allocation
:class
:accessor db-total-count
)
87 ;; the use of this slot is deprecated; it will be removed when dtf works without it.
88 (query :initform nil
:accessor db-query-object
)
89 ;; resource of (active and inactive) query objects
90 (queries :initform
() :accessor db-queries
)))
92 (defclass odbc-query
()
93 ((hstmt :initform nil
:initarg
:hstmt
:accessor hstmt
) ; = cursor??
94 (width :initform
+max-precision
+ :accessor query-width
)
95 (computed-result-types :initform nil
:initarg
:computed-result-types
:accessor computed-result-types
)
96 (column-count :initform nil
:accessor column-count
)
97 (column-names :initform
(make-array 0 :element-type
'string
:adjustable t
:fill-pointer t
)
98 :accessor column-names
)
99 (column-c-types :initform
(make-array 0 :element-type
'fixnum
:adjustable t
:fill-pointer t
)
100 :accessor column-c-types
)
101 (column-sql-types :initform
(make-array 0 :element-type
'fixnum
:adjustable t
:fill-pointer t
)
102 :accessor column-sql-types
)
103 (column-data-ptrs :initform
(make-array 0 :adjustable t
:fill-pointer t
)
105 (column-out-len-ptrs :initform
(make-array 0 :adjustable t
:fill-pointer t
)
106 :accessor column-out-len-ptrs
)
107 (column-precisions :initform
(make-array 0 :element-type
'fixnum
:adjustable t
:fill-pointer t
)
108 :accessor column-precisions
)
109 (column-scales :initform
(make-array 0 :element-type
'fixnum
:adjustable t
:fill-pointer t
)
110 :accessor column-scales
)
111 (column-nullables-p :initform
(make-array 0 :element-type
'fixnum
:adjustable t
:fill-pointer t
)
112 :accessor column-nullables-p
)
113 ;;(parameter-count :initform 0 :accessor parameter-count)
114 (parameter-data-ptrs :initform
(make-array 0 :adjustable t
:fill-pointer t
)
115 :accessor parameter-ptrs
)
116 ;; a query string or a query expression object
117 (sql-expression :initform nil
:initarg
:sql-expression
:accessor sql-expression
)
118 ;; database object the query is to be run against
119 (database :initarg
:database
:reader query-database
)
120 (active-p :initform nil
:initarg
:active-p
:accessor query-active-p
))
122 "Stores query information, like SQL query string/expression and database to run
123 the query against." ))
125 ;;; AODBC Compatible interface
127 (defun connect (&key data-source-name user password connection-string completion window-handle
(autocommit t
))
128 (let ((db (make-instance 'odbc-db
)))
129 (unless (henv db
) ;; has class allocation!
130 (setf (henv db
) (%new-environment-handle
)))
131 (setf (hdbc db
) (%new-db-connection-handle
(henv db
)))
132 (if connection-string
133 (%sql-driver-connect
(hdbc db
)
136 (:no-prompt odbc
::$SQL_DRIVER_NOPROMPT
)
137 (:complete odbc
::$SQL_DRIVER_COMPLETE
)
138 (:prompt odbc
::$SQL_DRIVER_PROMPT
)
139 (:complete-required odbc
::$SQL_DRIVER_COMPLETE_REQUIRED
))
141 (%sql-connect
(hdbc db
) data-source-name user password
))
142 #+ignore
(setf (db-hstmt db
) (%new-statement-handle
(hdbc db
)))
143 (when (/= (get-odbc-info db odbc
::$SQL_TXN_CAPABLE
) odbc
::$SQL_TC_NONE
)
145 (enable-autocommit (hdbc db
))
146 (disable-autocommit (hdbc db
))))
149 (defun disconnect (database)
150 (with-slots (hdbc queries
) database
151 (dolist (query queries
)
152 (if (query-active-p query
)
153 (with-slots (hstmt) query
155 (%free-statement hstmt
:drop
)
157 (when (db-hstmt database
)
158 (%free-statement
(db-hstmt database
) :drop
))
162 (defun sql (expr &key db result-types row-count
(column-names t
) query
164 (declare (ignore hstmt
))
167 (let ((q (db-open-query db expr
:result-types result-types
:width width
)))
169 (values q
(column-names q
))
172 (multiple-value-bind (data col-names
)
173 (db-query db expr
:result-types result-types
:width width
)
176 (if (consp data
) (length data
) data
))
178 (values data col-names
))
182 (defun fetch-row (query &optional
(eof-errorp t
) eof-value
)
183 (multiple-value-bind (row query count
) (db-fetch-query-results query
1)
188 (error 'clsql
:sql-database-data-error
189 :message
"ODBC: Ran out of data in fetch-row"))
195 (defun close-query (query)
196 (db-close-query query
))
198 (defun list-all-database-tables (&key db hstmt
)
199 (declare (ignore hstmt
))
200 (let ((query (get-free-query db
)))
203 (with-slots (hstmt) query
204 (unless hstmt
(setf hstmt
(%new-statement-handle
(hdbc db
))))
206 (%initialize-query query nil nil
)
208 (db-fetch-query-results query
)
209 (coerce (column-names query
) 'list
))))
210 (db-close-query query
))))
212 (defun list-table-indexes (table &key db unique hstmt
)
213 (declare (ignore hstmt
))
214 (let ((query (get-free-query db
)))
217 (with-slots (hstmt) query
219 (setf hstmt
(%new-statement-handle
(hdbc db
))))
220 (%table-statistics table hstmt
:unique unique
)
221 (%initialize-query query nil nil
)
223 (db-fetch-query-results query
)
224 (coerce (column-names query
) 'list
))))
225 (db-close-query query
))))
227 (defun list-all-table-columns (table &key db hstmt
)
228 (declare (ignore hstmt
))
229 (db-describe-columns db nil nil table nil
)) ;; use nil rather than "" for unspecified values
231 (defun list-all-data-sources ()
232 (let ((db (make-instance 'odbc-db
)))
233 (unless (henv db
) ;; has class allocation!
234 (setf (henv db
) (%new-environment-handle
)))
235 (%list-data-sources
(henv db
))))
237 (defun rr-sql (hstmt sql-statement
&key db
)
238 (declare (ignore hstmt sql-statement db
))
239 (warn "rr-sql not implemented."))
241 ;;; Mid-level interface
243 (defun db-commit (database)
244 (%commit
(henv database
) (hdbc database
)))
246 (defun db-rollback (database)
247 (%rollback
(henv database
) (hdbc database
)))
249 (defun db-cancel-query (query)
250 (with-slots (hstmt) query
252 (setf (query-active-p query
) nil
)))
255 (defmacro with-transaction
(&body body
)
257 (:henv
(henv ,*default-database
*) :hdbc
(hdbc ,*default-database
*))
260 (defmethod initialize-instance :after
((query odbc-query
)
261 &key sql henv hdbc
&allow-other-keys
)
263 (let ((hstmt (%new-statement-handle hdbc
)))
264 (%sql-exec-direct sql hstmt henv hdbc
)
265 (with-slots (column-count
266 column-names column-c-types column-sql-types column-data-ptrs
267 column-out-len-ptrs column-precisions column-scales
268 column-nullables-p active-p
) query
269 (setf (hstmt query
) hstmt
)
270 (%initialize-query query nil nil
)
271 (setf active-p t
)))))
273 ;; one for odbc-db is missing
274 (defmethod terminate ((query odbc-query
))
275 ;;(format tb::*local-output* "~%*** terminated: ~s" query)
276 (with-slots (hstmt) query
278 ;(%free-statement hstmt :drop)
279 (uffi:free-foreign-object hstmt
)) ;; ??
280 (%dispose-column-ptrs query
)))
282 (defun %dispose-column-ptrs
(query)
283 (with-slots (column-data-ptrs column-out-len-ptrs hstmt
) query
284 (loop for data-ptr across column-data-ptrs
285 when data-ptr do
(uffi:free-foreign-object data-ptr
))
286 (loop for out-len-ptr across column-out-len-ptrs
287 when out-len-ptr do
(uffi:free-foreign-object out-len-ptr
))))
289 (defmethod db-open-query ((database odbc-db
) query-expression
290 &key arglen col-positions result-types width
292 (db-open-query (get-free-query database
) query-expression
293 :arglen arglen
:col-positions col-positions
294 :result-types result-types
295 :width
(if width width
(db-width database
))))
297 (defmethod db-open-query ((query odbc-query
) query-expression
298 &key arglen col-positions result-types width
300 (%db-execute query query-expression
)
301 (%initialize-query query arglen col-positions
:result-types result-types
304 (defmethod db-fetch-query-results ((database odbc-db
) &optional count
)
305 (db-fetch-query-results (db-query-object database
) count
))
307 (defmethod db-fetch-query-results ((query odbc-query
) &optional count
)
308 (when (query-active-p query
)
309 (with-slots (column-count column-data-ptrs column-c-types column-sql-types
310 column-out-len-ptrs column-precisions hstmt computed-result-types
)
312 (let* ((rows-fetched 0)
315 until
(or (and count
(= i count
))
316 (= (%sql-fetch hstmt
) odbc
::$SQL_NO_DATA_FOUND
))
318 (loop for result-type across computed-result-types
319 for data-ptr across column-data-ptrs
320 for c-type across column-c-types
321 for sql-type across column-sql-types
322 for out-len-ptr across column-out-len-ptrs
323 for precision across column-precisions
324 for j from
0 ; column count is zero based in lisp
328 (cond ((< 0 precision
(query-width query
))
329 (read-data data-ptr c-type sql-type out-len-ptr result-type
))
330 ((zerop (get-cast-long out-len-ptr
))
333 (read-data-in-chunks hstmt j data-ptr c-type sql-type
334 out-len-ptr result-type
))))))))
335 (values rows query rows-fetched
)))))
337 (defun db-query (database query-expression
&key result-types width
)
338 (let ((free-query (get-free-query database
)))
339 (setf (sql-expression free-query
) query-expression
)
342 (%db-execute free-query query-expression
)
343 (%initialize-query free-query nil nil
:result-types result-types
:width width
)
344 (if (plusp (column-count free-query
)) ;; KMR: Added check for commands that don't return columns
346 (db-fetch-query-results free-query nil
)
347 (map 'list
#'identity
(column-names free-query
)))
349 (result-rows-count (hstmt free-query
))
351 (db-close-query free-query
)
354 (defmethod %db-execute
((database odbc-db
) sql-expression
&key
&allow-other-keys
)
355 (%db-execute
(get-free-query database
) sql-expression
))
357 (defmethod %db-execute
((query odbc-query
) sql-expression
&key
&allow-other-keys
)
358 (with-slots (henv hdbc
) (odbc::query-database query
)
359 (with-slots (hstmt) query
360 (unless hstmt
(setf hstmt
(%new-statement-handle hdbc
)))
361 (setf (sql-expression query
) sql-expression
)
362 (%sql-exec-direct sql-expression hstmt henv hdbc
)
365 ;; reuse inactive queries
366 (defun get-free-query (database)
367 "get-free-query finds or makes a nonactive query object, and then sets it to active.
368 This makes the functions db-execute-command and db-query thread safe."
369 (with-slots (queries hdbc
) database
370 (or (clsql-sys:without-interrupts
371 (let ((inactive-query (find-if (lambda (query)
372 (not (query-active-p query
)))
375 (with-slots (column-count column-names column-c-types
377 column-sql-types column-data-ptrs
378 column-out-len-ptrs column-precisions
379 column-scales column-nullables-p
)
381 ;;(print column-data-ptrs tb::*local-output*)
382 ;;(%dispose-column-ptrs inactive-query)
384 width
+max-precision
+
385 ;; KMR hstmt (%new-statement-handle hdbc)
386 (fill-pointer column-names
) 0
387 (fill-pointer column-c-types
) 0
388 (fill-pointer column-sql-types
) 0
389 (fill-pointer column-data-ptrs
) 0
390 (fill-pointer column-out-len-ptrs
) 0
391 (fill-pointer column-precisions
) 0
392 (fill-pointer column-scales
) 0
393 (fill-pointer column-nullables-p
) 0))
394 (setf (query-active-p inactive-query
) t
))
396 (let ((new-query (make-instance 'odbc-query
398 ;;(clone-database database)
400 (push new-query queries
)
403 (defmethod db-execute-command ((database odbc-db
) sql-string
)
404 (db-execute-command (get-free-query database
) sql-string
))
406 (defmethod db-execute-command ((query odbc-query
) sql-string
)
407 (with-slots (hstmt database
) query
408 (with-slots (henv hdbc
) database
409 (unless hstmt
(setf hstmt
(%new-statement-handle hdbc
)))
411 (%sql-exec-direct sql-string hstmt henv hdbc
)
412 (db-close-query query
)))))
414 (defmethod %initialize-query
((database odbc-db
) arglen col-positions
&key result-types width
)
415 (%initialize-query
(db-query-object database
) arglen col-positions
416 :result-types result-types
417 :width
(if width width
(db-width database
))))
419 (defmethod %initialize-query
((query odbc-query
) arglen col-positions
&key result-types width
)
420 (with-slots (hstmt computed-result-types
421 column-count column-names column-c-types column-sql-types
422 column-data-ptrs column-out-len-ptrs column-precisions
423 column-scales column-nullables-p
)
425 (setf column-count
(if arglen
426 (min arglen
(result-columns-count hstmt
))
427 (result-columns-count hstmt
)))
428 (when width
(setf (query-width query
) width
))
429 ;;(format tb::*local-output* "~%column-count: ~d, col-positions: ~d" column-count col-positions)
430 (labels ((initialize-column (col-nr)
431 (multiple-value-bind (name sql-type precision scale nullable-p
)
432 (%describe-column hstmt
(1+ col-nr
))
433 ;; allocate space to bind result rows to
434 (multiple-value-bind (c-type data-ptr out-len-ptr size long-p
)
435 (%allocate-bindings sql-type precision
)
436 (if long-p
;; if long-p we fetch in chunks with %sql-get-data but must ensure that out_len_ptr is non zero
437 (setf (uffi:deref-pointer out-len-ptr
#.odbc
::$ODBC-LONG-TYPE
) #.odbc
::$SQL_NO_TOTAL
)
438 (%bind-column hstmt col-nr c-type data-ptr
(1+ size
) out-len-ptr
))
439 (vector-push-extend name column-names
)
440 (vector-push-extend sql-type column-sql-types
)
441 (vector-push-extend (sql-to-c-type sql-type
) column-c-types
)
442 (vector-push-extend precision column-precisions
)
443 (vector-push-extend scale column-scales
)
444 (vector-push-extend nullable-p column-nullables-p
)
445 (vector-push-extend data-ptr column-data-ptrs
)
446 (vector-push-extend out-len-ptr column-out-len-ptrs
)))))
448 (dolist (col-nr col-positions
)
449 (initialize-column col-nr
))
450 (dotimes (col-nr column-count
)
451 ;; get column information
452 (initialize-column col-nr
))))
454 (setf computed-result-types
(make-array column-count
))
455 (dotimes (i column-count
)
456 (setf (aref computed-result-types i
)
458 ((consp result-types
)
459 (nth i result-types
))
460 ((eq result-types
:auto
)
461 (if (eq (aref column-sql-types i
) odbc
::$SQL_BIGINT
)
463 (case (aref column-c-types i
)
464 (#.odbc
::$SQL_C_SLONG
:int
)
465 (#.odbc
::$SQL_C_DOUBLE
:double
)
466 (#.odbc
::$SQL_C_FLOAT
:float
)
467 (#.odbc
::$SQL_C_SSHORT
:short
)
468 (#.odbc
::$SQL_C_STINYINT
:short
)
469 (#.odbc
::$SQL_BIGINT
:short
)
475 (defun db-close-query (query &key drop-p
)
476 (with-slots (hstmt column-count column-names column-c-types column-sql-types
477 column-data-ptrs column-out-len-ptrs column-precisions
478 column-scales column-nullables-p
) query
479 (let ((count (fill-pointer column-data-ptrs
)))
480 (when (not (zerop count
))
481 (dotimes (col-nr count
)
482 (let ((data-ptr (aref column-data-ptrs col-nr
))
483 (out-len-ptr (aref column-out-len-ptrs col-nr
)))
484 (declare (ignorable data-ptr out-len-ptr
))
485 ;; free-statment :unbind frees these
486 #+ignore
(when data-ptr
(uffi:free-foreign-object data-ptr
))
487 #+ignore
(when out-len-ptr
(uffi:free-foreign-object out-len-ptr
)))))
491 (%free-statement hstmt
:drop
)
494 (%free-statement hstmt
:unbind
)
495 (%free-statement hstmt
:reset
)
496 (%free-statement hstmt
:close
)))
497 (setf (query-active-p query
) nil
)))
500 (defmethod %read-query-data
((database odbc-db
) ignore-columns
)
501 (%read-query-data
(db-query-object database
) ignore-columns
))
503 (defmethod %read-query-data
((query odbc-query
) ignore-columns
)
504 (with-slots (hstmt column-count column-c-types column-sql-types
505 column-data-ptrs column-out-len-ptrs column-precisions
506 computed-result-types
)
508 (unless (= (odbc::SQLFetch hstmt
) odbc
::$SQL_NO_DATA_FOUND
)
510 (loop for col-nr from
0 to
(- column-count
511 (if (eq ignore-columns
:last
) 2 1))
512 for result-type across computed-result-types
514 (let ((precision (aref column-precisions col-nr
))
515 (sql-type (aref column-sql-types col-nr
)))
516 (cond ((or (< 0 precision
(query-width query
))
517 (and (zerop precision
) (not (find sql-type
'($SQL_C_CHAR
)))))
518 (read-data (aref column-data-ptrs col-nr
)
519 (aref column-c-types col-nr
)
521 (aref column-out-len-ptrs col-nr
)
523 ((zerop (get-cast-long (aref column-out-len-ptrs col-nr
)))
526 (read-data-in-chunks hstmt col-nr
527 (aref column-data-ptrs col-nr
)
528 (aref column-c-types col-nr
)
529 (aref column-sql-types col-nr
)
530 (aref column-out-len-ptrs col-nr
)
534 (defmethod db-map-query ((database odbc-db
) type function query-exp
&key result-types
)
535 (db-map-query (get-free-query database
) type function query-exp
:result-types result-types
))
537 (defmethod db-map-query ((query odbc-query
) type function query-exp
&key result-types
)
538 (declare (ignore type
)) ; preliminary. Do a type coersion here
539 (%db-execute query
(sql-expression query-exp
))
542 (%initialize-query query nil nil
:result-types result-types
)
544 (loop for data
= (%read-query-data query nil
)
546 do
(apply function data
)))
547 ;; dispose of memory and set query inactive or get rid of it
548 (db-close-query query
)))
550 (defun db-map-bind-query (query type function
552 (declare (ignore type
)) ; preliminary. Do a type coersion here
555 (apply #'%db-bind-execute query parameters
)
558 while
(setf data
(%read-query-data query nil
))
559 do
(apply function data
)))
560 ;; dispose of memory and set query inactive or get rid of it
561 (%db-reset-query query
)))
563 ;; does not always return exactly a lisp type...
564 (defun sql-to-lisp-type (sql-type)
566 ((#.odbc
::$SQL_CHAR
#.odbc
::$SQL_VARCHAR
#.odbc
::$SQL_LONGVARCHAR
) :string
)
567 ((#.odbc
::$SQL_NUMERIC
#.odbc
::$SQL_DECIMAL
#.odbc
::$SQL_BIGINT
) :string
) ; ??
568 (#.odbc
::$SQL_INTEGER
#.odbc
::$ODBC-LONG-TYPE
)
569 (#.odbc
::$SQL_SMALLINT
:short
)
570 ((#.odbc
::$SQL_FLOAT
#.odbc
::$SQL_DOUBLE
) #.odbc
::$ODBC-LONG-TYPE
)
571 (#.odbc
::$SQL_REAL
#.odbc
::$ODBC-LONG-TYPE
)
572 ((#.odbc
::$SQL_DATE
#.odbc
::$SQL_TYPE_DATE
) 'sql-c-date
)
573 ((#.odbc
::$SQL_TIME
#.odbc
::$SQL_TYPE_TIME
) 'sql-c-time
)
574 ((#.odbc
::$SQL_TIMESTAMP
#.odbc
::$SQL_TYPE_TIMESTAMP
) 'sql-c-timestamp
)
575 ;;((#.odbc::$SQL_BINARY #.odbc::$SQL_VARBINARY #.odbc::$SQL_LONGVARBINARY) odbc::$SQL_C_BINARY) ; ??
576 (#.odbc
::$SQL_TINYINT
:short
)
577 ;;(#.odbc::$SQL_BIT odbc::$SQL_C_BIT) ; ??
578 ((#.odbc
::$SQL_VARBINARY
#.odbc
::$SQL_LONGVARBINARY
) :binary
)
583 (defmethod db-prepare-statement ((database odbc-db
) sql
584 &key parameter-table parameter-columns
)
585 (with-slots (hdbc) database
586 (let ((query (get-free-query database
)))
587 (with-slots (hstmt) query
588 (unless hstmt
(setf hstmt
(%new-statement-handle hdbc
))))
589 (db-prepare-statement query sql parameter-table parameter-columns
))))
591 (defmethod db-prepare-statement ((query odbc-query
) (sql string
)
592 &key parameter-table parameter-columns
)
593 ;; this is a workaround to get hold of the column types when the driver does not
594 ;; support SQLDescribeParam. To do: put code in here for drivers that do
596 (unless (string-equal sql
"insert" :end1
6)
597 (error 'clsql
:sql-database-error
599 "Only insert expressions are supported in literal ODBC: '~a'." sql
)))
600 (%db-execute query
(format nil
"select ~{~a~^,~} from ~a where 0 = 1"
601 (or parameter-columns
'("*")) parameter-table
))
602 (%initialize-query query nil nil
)
603 (with-slots (hstmt) query
604 (%free-statement hstmt
:unbind
)
605 (%free-statement hstmt
:reset
)
606 (setf (sql-expression query
) sql
)
607 (%sql-prepare hstmt sql
))
611 (defun %db-bind-execute
(query &rest parameters
)
612 (with-slots (hstmt parameter-data-ptrs
) query
613 (loop for parameter in parameters
614 with data-ptr and size and parameter-string
616 (setf parameter-string
617 (if (stringp parameter
)
619 (write-to-string parameter
))
620 size
(length parameter-string
)
622 (uffi:allocate-foreign-string
(1+ size
)))
623 (vector-push-extend data-ptr parameter-data-ptrs
)
625 hstmt
(1- (fill-pointer parameter-data-ptrs
)) odbc
::$SQL_PARAM_INPUT
626 odbc
::$SQL_C_CHAR
; (aref column-c-types parameter-count)
627 odbc
::$SQL_CHAR
; sql-type
628 (query-width query
) ;precision ; this should be the actual precision!
630 0 ;; should be calculated for odbc::$SQL_DECIMAL,
631 ;;$SQL_NUMERIC and odbc::$SQL_TIMESTAMP
632 data-ptr
;; = rgbValue
635 ;; change this for output and binary input! (see 3-32)
637 (%put-str data-ptr parameter-string size
))
638 (%sql-execute hstmt
)))
641 (defun %db-reset-query
(query)
642 (with-slots (hstmt parameter-data-ptrs
) query
644 (db-fetch-query-results query nil
)
645 (%free-statement hstmt
:reset
) ;; but _not_ :unbind !
646 (%free-statement hstmt
:close
)
647 (dotimes (param-nr (fill-pointer parameter-data-ptrs
))
648 (let ((data-ptr (aref parameter-data-ptrs param-nr
)))
649 (when data-ptr
(uffi:free-foreign-object data-ptr
))))
650 (setf (fill-pointer parameter-data-ptrs
) 0))))
652 (defun data-parameter-ptr (hstmt)
653 (uffi:with-foreign-object
(param-ptr :pointer-void
)
654 (let ((return-code (%sql-param-data hstmt param-ptr
)))
655 ;;(format t "~%return-code from %sql-param-data: ~a~%" return-code)
656 (when (= return-code odbc
::$SQL_NEED_DATA
)
657 ;;(ffc::%pointer-to-address (%get-ptr param-ptr))
658 (uffi:deref-pointer param-ptr
:pointer-void
)))))
660 ;; database inquiery functions
662 (defun db-describe-columns (database table-qualifier table-owner
663 table-name column-name
)
664 (with-slots (hdbc) database
665 (%describe-columns hdbc table-qualifier table-owner table-name column-name
)))
667 ;; should translate info-type integers to keywords in order to make this
669 (defmethod get-odbc-info ((database odbc-db
) info-type
)
670 (with-slots (hdbc info
) database
671 (or (gethash info-type info
)
672 (setf (gethash info-type info
)
673 (%sql-get-info hdbc info-type
)))))
675 (defmethod get-odbc-info ((query odbc-query
) info-type
)
676 (get-odbc-info (odbc::query-database query
) info-type
))
679 ;; How does this differ from list-data-sources?
680 (defgeneric db-data-sources
(db-type))
681 (defmethod db-data-sources ((db-type (eql :odbc
)))
682 "Returns a list of (data-source description) - pairs"
683 (let ((henv (%new-environment-handle
)))
685 (loop with direction
= :first
686 for data-source
+description
687 = (multiple-value-list (%sql-data-sources henv
:direction direction
))
688 while
(car data-source
+description
)
689 collect data-source
+description
690 do
(setf direction
:next
))
691 (%sql-free-environment henv
))))