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
10 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
12 ;;;; CLSQL users are granted the rights to distribute and use this software
13 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
14 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
15 ;;;; *************************************************************************
17 (in-package #:cl-user)
19 (defpackage #:odbc-dbi
31 #:list-all-data-sources
32 #:list-all-database-tables
33 #:list-all-table-columns
44 #:*default-odbc-external-format*
47 (:documentation "This is the mid-level interface ODBC."))
49 (in-package #:odbc-dbi)
51 (defgeneric terminate (src))
52 (defgeneric db-open-query (src query-expression
53 &key arglen col-positions result-types width
55 (defgeneric db-fetch-query-results (src &optional count))
56 (defgeneric %db-execute (src sql-expression &key &allow-other-keys))
57 (defgeneric db-execute-command (src sql-string))
59 (defgeneric %initialize-query (src arglen col-positions
60 &key result-types width))
62 (defgeneric %read-query-data (src ignore-columns))
63 (defgeneric db-map-query (src type function query-exp &key result-types))
64 (defgeneric db-prepare-statement (src sql &key parameter-table
66 (defgeneric get-odbc-info (src info-type))
68 (defvar *reuse-query-objects* t)
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 'integer :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 "This is set in the generic-odbc-database disconnect-fn slot so xref fails
151 but this does get called on generic ODBC connections "
152 (with-slots (hdbc queries) database
153 (dolist (query queries)
154 (db-close-query query :drop-p T))
155 (when (db-hstmt database)
156 (%free-statement (db-hstmt database) :drop))
160 (defun sql (expr &key db result-types row-count (column-names t) query
162 (declare (ignore hstmt))
165 (let ((q (db-open-query db expr :result-types result-types :width width)))
167 (values q (column-names q))
170 (multiple-value-bind (data col-names)
171 (db-query db expr :result-types result-types :width width)
174 (if (consp data) (length data) data))
176 (values data col-names))
180 (defun fetch-row (query &optional (eof-errorp t) eof-value)
181 (multiple-value-bind (row query count) (db-fetch-query-results query 1)
186 (error 'clsql:sql-database-data-error
187 :message "ODBC: Ran out of data in fetch-row"))
193 (defun close-query (query)
194 (db-close-query query))
196 (defun list-all-database-tables (&key db hstmt)
197 (declare (ignore hstmt))
198 (let ((query (get-free-query db)))
201 (with-slots (hstmt) query
202 (unless hstmt (setf hstmt (%new-statement-handle (hdbc db))))
204 (%initialize-query query nil nil)
206 (db-fetch-query-results query)
207 (coerce (column-names query) 'list))))
208 (db-close-query query))))
210 (defun list-table-indexes (table &key db unique hstmt
213 (clsql-sys::unescaped-database-identifier table))))
214 (declare (ignore hstmt))
215 (let ((query (get-free-query db)))
218 (with-slots (hstmt) query
220 (setf hstmt (%new-statement-handle (hdbc db))))
221 (%table-statistics table hstmt :unique unique)
222 (%initialize-query query nil nil)
224 (db-fetch-query-results query)
225 (coerce (column-names query) 'list))))
226 (db-close-query query))))
228 (defun list-all-table-columns (table &key db hstmt
231 (clsql-sys::unescaped-database-identifier table))))
232 (declare (ignore hstmt))
233 (db-describe-columns db nil nil table nil)) ;; use nil rather than "" for unspecified values
235 (defun list-all-data-sources ()
236 (let ((db (make-instance 'odbc-db)))
237 (unless (henv db) ;; has class allocation!
238 (setf (henv db) (%new-environment-handle)))
239 (%list-data-sources (henv db))))
241 (defun rr-sql (hstmt sql-statement &key db)
242 (declare (ignore hstmt sql-statement db))
243 (warn "rr-sql not implemented."))
245 ;;; Mid-level interface
247 (defun db-commit (database)
248 (%commit (henv database) (hdbc database)))
250 (defun db-rollback (database)
251 (%rollback (henv database) (hdbc database)))
253 (defun db-cancel-query (query)
254 (with-slots (hstmt) query
256 (setf (query-active-p query) nil)))
259 (defmacro with-transaction (&body body)
261 (:henv (henv ,*default-database*) :hdbc (hdbc ,*default-database*))
264 (defmethod initialize-instance :after ((query odbc-query)
265 &key sql henv hdbc &allow-other-keys)
267 (let ((hstmt (%new-statement-handle hdbc)))
268 (%sql-exec-direct sql hstmt henv hdbc)
269 (with-slots (column-count
270 column-names column-c-types column-sql-types column-data-ptrs
271 column-out-len-ptrs column-precisions column-scales
272 column-nullables-p active-p) query
273 (setf (hstmt query) hstmt)
274 (%initialize-query query nil nil)
275 (setf active-p t)))))
277 ;; one for odbc-db is missing
278 ;; TODO: Seems to be uncalled
279 (defmethod terminate ((query odbc-query))
280 ;;(format tb::*local-output* "~%*** terminated: ~s" query)
281 (db-close-query query))
283 (defun %dispose-column-ptrs (query)
284 "frees memory allocated for query object column-data and column-data-length"
285 (with-slots (column-data-ptrs column-out-len-ptrs hstmt) query
286 (loop for data-ptr across column-data-ptrs
287 for out-len-ptr across column-out-len-ptrs
289 do (uffi:free-foreign-object data-ptr)
291 do (uffi:free-foreign-object out-len-ptr))
292 (setf (fill-pointer column-data-ptrs) 0
293 (fill-pointer column-out-len-ptrs) 0)))
295 (defmethod db-open-query ((database odbc-db) query-expression
296 &key arglen col-positions result-types width
298 (db-open-query (get-free-query database) query-expression
299 :arglen arglen :col-positions col-positions
300 :result-types result-types
301 :width (if width width (db-width database))))
303 (defmethod db-open-query ((query odbc-query) query-expression
304 &key arglen col-positions result-types width
306 (%db-execute query query-expression)
307 (%initialize-query query arglen col-positions :result-types result-types
310 (defmethod db-fetch-query-results ((database odbc-db) &optional count)
311 (db-fetch-query-results (db-query-object database) count))
313 (defmethod db-fetch-query-results ((query odbc-query) &optional count)
314 (when (query-active-p query)
315 (with-slots (column-count column-data-ptrs column-c-types column-sql-types
316 column-out-len-ptrs column-precisions hstmt computed-result-types)
318 (let* ((rows-fetched 0)
321 until (or (and count (= i count))
322 (= (%sql-fetch hstmt) odbc::$SQL_NO_DATA_FOUND))
324 (loop for result-type across computed-result-types
325 for data-ptr across column-data-ptrs
326 for c-type across column-c-types
327 for sql-type across column-sql-types
328 for out-len-ptr across column-out-len-ptrs
329 for precision across column-precisions
330 for j from 0 ; column count is zero based in lisp
334 (cond ((< 0 precision (query-width query))
335 (read-data data-ptr c-type sql-type out-len-ptr result-type))
336 ((zerop (get-cast-long out-len-ptr))
339 (read-data-in-chunks hstmt j data-ptr c-type sql-type
340 out-len-ptr result-type))))))))
341 (values rows query rows-fetched)))))
343 (defun db-query (database query-expression &key result-types width)
344 (let ((free-query (get-free-query database)))
345 (setf (sql-expression free-query) query-expression)
348 (%db-execute free-query query-expression)
349 (%initialize-query free-query nil nil :result-types result-types :width width)
350 (if (plusp (column-count free-query)) ;; KMR: Added check for commands that don't return columns
352 (db-fetch-query-results free-query nil)
353 (map 'list #'identity (column-names free-query)))
355 (result-rows-count (hstmt free-query))
357 (db-close-query free-query)
360 (defmethod %db-execute ((database odbc-db) sql-expression &key &allow-other-keys)
361 (%db-execute (get-free-query database) sql-expression))
363 (defmethod %db-execute ((query odbc-query) sql-expression &key &allow-other-keys)
364 (with-slots (henv hdbc) (odbc::query-database query)
365 (with-slots (hstmt) query
366 (unless hstmt (setf hstmt (%new-statement-handle hdbc)))
367 (setf (sql-expression query) sql-expression)
368 (%sql-exec-direct sql-expression hstmt henv hdbc)
371 ;; reuse inactive queries
372 (defun get-free-query (database)
373 "get-free-query finds or makes a nonactive query object, and then sets it to active.
374 This makes the functions db-execute-command and db-query thread safe."
375 (with-slots (queries hdbc) database
376 (or (and *reuse-query-objects*
377 (clsql-sys:without-interrupts
378 (let ((inactive-query (find-if (lambda (query)
379 (not (query-active-p query)))
382 (with-slots (column-count column-names column-c-types
384 column-sql-types column-data-ptrs
385 column-out-len-ptrs column-precisions
386 column-scales column-nullables-p)
389 width +max-precision+
390 ;; KMR hstmt (%new-statement-handle hdbc)
391 (fill-pointer column-names) 0
392 (fill-pointer column-c-types) 0
393 (fill-pointer column-sql-types) 0
394 (fill-pointer column-data-ptrs) 0
395 (fill-pointer column-out-len-ptrs) 0
396 (fill-pointer column-precisions) 0
397 (fill-pointer column-scales) 0
398 (fill-pointer column-nullables-p) 0))
399 (setf (query-active-p inactive-query) t))
401 (let ((new-query (make-instance 'odbc-query
403 ;;(clone-database database)
405 (push new-query queries)
408 (defmethod db-execute-command ((database odbc-db) sql-string)
409 (db-execute-command (get-free-query database) sql-string))
411 (defmethod db-execute-command ((query odbc-query) sql-string)
412 (with-slots (hstmt database) query
413 (with-slots (henv hdbc) database
414 (unless hstmt (setf hstmt (%new-statement-handle hdbc)))
416 (%sql-exec-direct sql-string hstmt henv hdbc)
417 (db-close-query query)))))
419 (defmethod %initialize-query ((database odbc-db) arglen col-positions &key result-types width)
420 (%initialize-query (db-query-object database) arglen col-positions
421 :result-types result-types
422 :width (if width width (db-width database))))
424 (defmethod %initialize-query ((query odbc-query) arglen col-positions &key result-types width)
425 (with-slots (hstmt computed-result-types
426 column-count column-names column-c-types column-sql-types
427 column-data-ptrs column-out-len-ptrs column-precisions
428 column-scales column-nullables-p)
430 (setf column-count (if arglen
431 (min arglen (result-columns-count hstmt))
432 (result-columns-count hstmt)))
433 (when width (setf (query-width query) width))
434 ;;(format tb::*local-output* "~%column-count: ~d, col-positions: ~d" column-count col-positions)
435 (labels ((initialize-column (col-nr)
436 (multiple-value-bind (name sql-type precision scale nullable-p)
437 (%describe-column hstmt (1+ col-nr))
438 ;; allocate space to bind result rows to
439 (multiple-value-bind (c-type data-ptr out-len-ptr size long-p)
440 (%allocate-bindings sql-type precision)
441 (if long-p ;; if long-p we fetch in chunks with %sql-get-data but must ensure that out_len_ptr is non zero
442 (setf (uffi:deref-pointer out-len-ptr #.odbc::$ODBC-LONG-TYPE) #.odbc::$SQL_NO_TOTAL)
443 (%bind-column hstmt col-nr c-type data-ptr (1+ size) out-len-ptr))
444 (vector-push-extend name column-names)
445 (vector-push-extend sql-type column-sql-types)
446 (vector-push-extend (sql-to-c-type sql-type) column-c-types)
447 (vector-push-extend precision column-precisions)
448 (vector-push-extend scale column-scales)
449 (vector-push-extend nullable-p column-nullables-p)
450 (vector-push-extend data-ptr column-data-ptrs)
451 (vector-push-extend out-len-ptr column-out-len-ptrs)))))
453 (dolist (col-nr col-positions)
454 (initialize-column col-nr))
455 (dotimes (col-nr column-count)
456 ;; get column information
457 (initialize-column col-nr))))
459 ;; TODO: move this into the above loop
460 (setf computed-result-types (make-array column-count))
461 (dotimes (i column-count)
462 (setf (aref computed-result-types i)
464 ((consp result-types)
465 (nth i result-types))
466 ((eq result-types :auto)
467 (case (aref column-c-types i)
468 (#.odbc::$SQL_C_SLONG :int)
469 (#.odbc::$SQL_C_DOUBLE :double)
470 (#.odbc::$SQL_C_FLOAT :float)
471 (#.odbc::$SQL_C_SSHORT :short)
472 (#.odbc::$SQL_C_STINYINT :short)
473 (#.odbc::$SQL_C_SBIGINT #.odbc::$ODBC-BIG-TYPE)
474 (#.odbc::$SQL_C_TYPE_TIMESTAMP :time)
475 (#.odbc::$SQL_C_CHAR ;; TODO: Read this as rational instead of double
476 (or (case (aref column-sql-types i)
477 (#.odbc::$SQL_NUMERIC :double))
484 (defun db-close-query (query &key (drop-p (not *reuse-query-objects*)))
485 (with-slots (hstmt column-count column-names column-c-types column-sql-types
486 column-data-ptrs column-out-len-ptrs column-precisions
487 column-scales column-nullables-p database) query
488 (%dispose-column-ptrs query)
489 (cond ((null hstmt) nil)
491 (%free-statement hstmt :drop)
492 ;; dont free with uffi/ this is a double free and crashes everything
493 ;; (uffi:free-foreign-object hstmt)
496 (%free-statement hstmt :unbind)
497 (%free-statement hstmt :reset)
498 (%free-statement hstmt :close)))
499 (setf (query-active-p query) nil)
501 (clsql-sys:without-interrupts
502 (with-slots (queries) database
503 (setf queries (remove query queries))))))
506 (defmethod %read-query-data ((database odbc-db) ignore-columns)
507 (%read-query-data (db-query-object database) ignore-columns))
509 (defmethod %read-query-data ((query odbc-query) ignore-columns)
510 (with-slots (hstmt column-count column-c-types column-sql-types
511 column-data-ptrs column-out-len-ptrs column-precisions
512 computed-result-types)
514 (unless (= (odbc::SQLFetch hstmt) odbc::$SQL_NO_DATA_FOUND)
516 (loop for col-nr from 0 to (- column-count
517 (if (eq ignore-columns :last) 2 1))
518 for result-type across computed-result-types
520 (let ((precision (aref column-precisions col-nr))
521 (sql-type (aref column-sql-types col-nr)))
522 (cond ((or (< 0 precision (query-width query))
523 (and (zerop precision) (not (find sql-type '($SQL_C_CHAR)))))
524 (read-data (aref column-data-ptrs col-nr)
525 (aref column-c-types col-nr)
527 (aref column-out-len-ptrs col-nr)
529 ((zerop (get-cast-long (aref column-out-len-ptrs col-nr)))
532 (read-data-in-chunks hstmt col-nr
533 (aref column-data-ptrs col-nr)
534 (aref column-c-types col-nr)
535 (aref column-sql-types col-nr)
536 (aref column-out-len-ptrs col-nr)
540 (defmethod db-map-query ((database odbc-db) type function query-exp &key result-types)
541 (db-map-query (get-free-query database) type function query-exp :result-types result-types))
543 (defmethod db-map-query ((query odbc-query) type function query-exp &key result-types)
544 (declare (ignore type)) ; preliminary. Do a type coersion here
545 (%db-execute query (sql-expression query-exp))
548 (%initialize-query query nil nil :result-types result-types)
550 (loop for data = (%read-query-data query nil)
552 do (apply function data)))
553 ;; dispose of memory and set query inactive or get rid of it
554 (db-close-query query)))
556 (defun db-map-bind-query (query type function
558 (declare (ignore type)) ; preliminary. Do a type coersion here
561 (apply #'%db-bind-execute query parameters)
564 while (setf data (%read-query-data query nil))
565 do (apply function data)))
566 ;; dispose of memory and set query inactive or get rid of it
567 (%db-reset-query query)))
569 ;; does not always return exactly a lisp type...
570 (defun sql-to-lisp-type (sql-type)
572 ((#.odbc::$SQL_CHAR #.odbc::$SQL_VARCHAR #.odbc::$SQL_LONGVARCHAR) :string)
573 ((#.odbc::$SQL_NUMERIC #.odbc::$SQL_DECIMAL) :string) ; ??
574 (#.odbc::$SQL_BIGINT #.odbc::$ODBC-BIG-TYPE)
575 (#.odbc::$SQL_INTEGER #.odbc::$ODBC-LONG-TYPE)
576 (#.odbc::$SQL_SMALLINT :short)
577 ((#.odbc::$SQL_FLOAT #.odbc::$SQL_DOUBLE) #.odbc::$ODBC-LONG-TYPE)
578 (#.odbc::$SQL_REAL #.odbc::$ODBC-LONG-TYPE)
579 ((#.odbc::$SQL_DATE #.odbc::$SQL_TYPE_DATE) 'sql-c-date)
580 ((#.odbc::$SQL_TIME #.odbc::$SQL_TYPE_TIME) 'sql-c-time)
581 ((#.odbc::$SQL_TIMESTAMP #.odbc::$SQL_TYPE_TIMESTAMP) 'sql-c-timestamp)
582 ;;((#.odbc::$SQL_BINARY #.odbc::$SQL_VARBINARY #.odbc::$SQL_LONGVARBINARY) odbc::$SQL_C_BINARY) ; ??
583 (#.odbc::$SQL_TINYINT :short)
584 ;;(#.odbc::$SQL_BIT odbc::$SQL_C_BIT) ; ??
585 (#.odbc::$SQL_BIT :short)
586 ((#.odbc::$SQL_VARBINARY #.odbc::$SQL_LONGVARBINARY) :binary)
591 (defmethod db-prepare-statement ((database odbc-db) sql
592 &key parameter-table parameter-columns)
593 (with-slots (hdbc) database
594 (let ((query (get-free-query database)))
595 (with-slots (hstmt) query
596 (unless hstmt (setf hstmt (%new-statement-handle hdbc))))
597 (db-prepare-statement
598 query sql :parameter-table parameter-table :parameter-columns parameter-columns))))
600 (defmethod db-prepare-statement ((query odbc-query) (sql string)
601 &key parameter-table parameter-columns)
602 ;; this is a workaround to get hold of the column types when the driver does not
603 ;; support SQLDescribeParam. To do: put code in here for drivers that do
605 (unless (string-equal sql "insert" :end1 6)
606 (error 'clsql:sql-database-error
608 "Only insert expressions are supported in literal ODBC: '~a'." sql)))
609 (%db-execute query (format nil "select ~{~a~^,~} from ~a where 0 = 1"
610 (or parameter-columns '("*")) parameter-table))
611 (%initialize-query query nil nil)
612 (with-slots (hstmt) query
613 (%free-statement hstmt :unbind)
614 (%free-statement hstmt :reset)
615 (setf (sql-expression query) sql)
616 (%sql-prepare hstmt sql))
620 (defun %db-bind-execute (query &rest parameters)
621 "Only used from db-map-bind-query
622 parameters are released in %reset-query
624 (with-slots (hstmt parameter-data-ptrs) query
625 (loop for parameter in parameters
626 with data-ptr and size and parameter-string
628 (setf parameter-string
629 (if (stringp parameter)
631 (write-to-string parameter))
632 size (length parameter-string)
634 (uffi:allocate-foreign-string (1+ size)))
635 (vector-push-extend data-ptr parameter-data-ptrs)
637 hstmt (1- (fill-pointer parameter-data-ptrs)) odbc::$SQL_PARAM_INPUT
638 odbc::$SQL_C_CHAR ; (aref column-c-types parameter-count)
639 odbc::$SQL_CHAR ; sql-type
640 (query-width query) ;precision ; this should be the actual precision!
642 0 ;; should be calculated for odbc::$SQL_DECIMAL,
643 ;;$SQL_NUMERIC and odbc::$SQL_TIMESTAMP
644 data-ptr ;; = rgbValue
647 ;; change this for output and binary input! (see 3-32)
649 (%put-str data-ptr parameter-string size))
650 (%sql-execute hstmt)))
653 (defun %db-reset-query (query)
654 "Only used from db-map-bind-query
655 parameters are allocated in %db-bind-execute
657 (with-slots (hstmt parameter-data-ptrs) query
659 (db-fetch-query-results query nil)
660 (%free-statement hstmt :reset) ;; but _not_ :unbind !
661 (%free-statement hstmt :close)
662 (dotimes (param-nr (fill-pointer parameter-data-ptrs))
663 (let ((data-ptr (aref parameter-data-ptrs param-nr)))
664 (when data-ptr (uffi:free-foreign-object data-ptr))))
665 (setf (fill-pointer parameter-data-ptrs) 0))))
667 (defun data-parameter-ptr (hstmt)
668 (uffi:with-foreign-object (param-ptr :pointer-void)
669 (let ((return-code (%sql-param-data hstmt param-ptr)))
670 ;;(format t "~%return-code from %sql-param-data: ~a~%" return-code)
671 (when (= return-code odbc::$SQL_NEED_DATA)
672 ;;(ffc::%pointer-to-address (%get-ptr param-ptr))
673 (uffi:deref-pointer param-ptr :pointer-void)))))
675 ;; database inquiery functions
677 (defun db-describe-columns (database table-qualifier table-owner
678 table-name column-name)
679 (with-slots (hdbc) database
680 (%describe-columns hdbc table-qualifier table-owner table-name column-name)))
682 ;; should translate info-type integers to keywords in order to make this
684 (defmethod get-odbc-info ((database odbc-db) info-type)
685 (with-slots (hdbc info) database
686 (or (gethash info-type info)
687 (setf (gethash info-type info)
688 (%sql-get-info hdbc info-type)))))
690 (defmethod get-odbc-info ((query odbc-query) info-type)
691 (get-odbc-info (odbc::query-database query) info-type))
694 ;; How does this differ from list-data-sources?
695 (defgeneric db-data-sources (db-type))
696 (defmethod db-data-sources ((db-type (eql :odbc)))
697 "Returns a list of (data-source description) - pairs"
698 (let ((henv (%new-environment-handle)))
700 (loop with direction = :first
701 for data-source+description
702 = (multiple-value-list (%sql-data-sources henv :direction direction))
703 while (car data-source+description)
704 collect data-source+description
705 do (setf direction :next))
706 (%sql-free-environment henv))))