;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: odbc-dbi.cl ;;;; Purpose: Mid-level (DBI) interface for CLSQL ODBC backend ;;;; Author: Kevin M. Rosenberg ;;;; Create: April 2004 ;;;; ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; ;;;; CLSQL users are granted the rights to distribute and use this software ;;;; as governed by the terms of the Lisp Lesser GNU Public License ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* (in-package #:cl-user) (defpackage #:odbc-dbi (:use #:cl #:odbc) (:export #:bind-parameter #:close-query #:connect #:db-external-format #:db-hstmt #:db-width #:disconnect #:end-transaction #:fetch-row #:list-all-data-sources #:list-all-database-tables #:list-all-table-columns #:list-table-indexes #:loop-over-results #:prepare-sql #:rr-sql #:run-prepared-sql #:set-autocommit #:sql #:*auto-trim-strings* #:*default-database* #:*default-odbc-external-format* #:*null-value* ) (:documentation "This is the mid-level interface ODBC.")) (in-package #:odbc-dbi) (defgeneric terminate (src)) (defgeneric db-open-query (src query-expression &key arglen col-positions result-types width &allow-other-keys)) (defgeneric db-fetch-query-results (src &optional count)) (defgeneric %db-execute (src sql-expression &key &allow-other-keys)) (defgeneric db-execute-command (src sql-string)) (defgeneric %initialize-query (src arglen col-positions &key result-types width)) (defgeneric %read-query-data (src ignore-columns)) (defgeneric db-map-query (src type function query-exp &key result-types)) (defgeneric db-prepare-statement (src sql &key parameter-table parameter-columns)) (defgeneric get-odbc-info (src info-type)) (defvar *reuse-query-objects* t) ;;; SQL Interface (defclass odbc-db () (;; any reason to have more than one henv? (width :initform +max-precision+ :accessor db-width) (hstmt :initform nil :accessor db-hstmt) (henv :initform nil :allocation :class :initarg :henv :accessor henv) (hdbc :initform nil :initarg :hdbc :accessor hdbc) ;; info returned from SQLGetInfo (info :initform (make-hash-table) :reader db-info) (type :initform nil :initarg :db-type :reader db-type) (connected-p :initform nil :accessor db-connected-p) ;; not used yet (count :initform 0 :initarg :count :accessor db-count) ;; not used yet (total-count :initform 0 :allocation :class :accessor db-total-count) ;; the use of this slot is deprecated; it will be removed when dtf works without it. (query :initform nil :accessor db-query-object) ;; resource of (active and inactive) query objects (queries :initform () :accessor db-queries))) (defclass odbc-query () ((hstmt :initform nil :initarg :hstmt :accessor hstmt) ; = cursor?? (width :initform +max-precision+ :accessor query-width) (computed-result-types :initform nil :initarg :computed-result-types :accessor computed-result-types) (column-count :initform nil :accessor column-count) (column-names :initform (make-array 0 :element-type 'string :adjustable t :fill-pointer t) :accessor column-names) (column-c-types :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t) :accessor column-c-types) (column-sql-types :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t) :accessor column-sql-types) (column-data-ptrs :initform (make-array 0 :adjustable t :fill-pointer t) :accessor data-ptrs) (column-out-len-ptrs :initform (make-array 0 :adjustable t :fill-pointer t) :accessor column-out-len-ptrs) (column-precisions :initform (make-array 0 :element-type 'integer :adjustable t :fill-pointer t) :accessor column-precisions) (column-scales :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t) :accessor column-scales) (column-nullables-p :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t) :accessor column-nullables-p) ;;(parameter-count :initform 0 :accessor parameter-count) (parameter-data-ptrs :initform (make-array 0 :adjustable t :fill-pointer t) :accessor parameter-ptrs) ;; a query string or a query expression object (sql-expression :initform nil :initarg :sql-expression :accessor sql-expression) ;; database object the query is to be run against (database :initarg :database :reader query-database) (active-p :initform nil :initarg :active-p :accessor query-active-p)) (:documentation "Stores query information, like SQL query string/expression and database to run the query against." )) ;;; AODBC Compatible interface (defun connect (&key data-source-name user password connection-string completion window-handle (autocommit t)) (let ((db (make-instance 'odbc-db))) (unless (henv db) ;; has class allocation! (setf (henv db) (%new-environment-handle))) (setf (hdbc db) (%new-db-connection-handle (henv db))) (if connection-string (%sql-driver-connect (hdbc db) connection-string (ecase completion (:no-prompt odbc::$SQL_DRIVER_NOPROMPT) (:complete odbc::$SQL_DRIVER_COMPLETE) (:prompt odbc::$SQL_DRIVER_PROMPT) (:complete-required odbc::$SQL_DRIVER_COMPLETE_REQUIRED)) window-handle) (%sql-connect (hdbc db) data-source-name user password)) #+ignore (setf (db-hstmt db) (%new-statement-handle (hdbc db))) (when (/= (get-odbc-info db odbc::$SQL_TXN_CAPABLE) odbc::$SQL_TC_NONE) (if autocommit (enable-autocommit (hdbc db)) (disable-autocommit (hdbc db)))) db)) (defun disconnect (database) "This is set in the generic-odbc-database disconnect-fn slot so xref fails but this does get called on generic ODBC connections " (with-slots (hdbc queries) database (dolist (query queries) (db-close-query query :drop-p T)) (when (db-hstmt database) (%free-statement (db-hstmt database) :drop)) (%disconnect hdbc))) (defun sql (expr &key db result-types row-count (column-names t) query hstmt width) (declare (ignore hstmt)) (cond (query (let ((q (db-open-query db expr :result-types result-types :width width))) (if column-names (values q (column-names q)) q))) (t (multiple-value-bind (data col-names) (db-query db expr :result-types result-types :width width) (cond (row-count (if (consp data) (length data) data)) (column-names (values data col-names)) (t data)))))) (defun fetch-row (query &optional (eof-errorp t) eof-value) (multiple-value-bind (row query count) (db-fetch-query-results query 1) (cond ((zerop count) (close-query query) (when eof-errorp (error 'clsql:sql-database-data-error :message "ODBC: Ran out of data in fetch-row")) eof-value) (t (car row))))) (defun close-query (query) (db-close-query query)) (defun list-all-database-tables (&key db hstmt) (declare (ignore hstmt)) (let ((query (get-free-query db))) (unwind-protect (progn (with-slots (hstmt) query (unless hstmt (setf hstmt (%new-statement-handle (hdbc db)))) (%list-tables hstmt) (%initialize-query query nil nil) (values (db-fetch-query-results query) (coerce (column-names query) 'list)))) (db-close-query query)))) (defun list-table-indexes (table &key db unique hstmt &aux (table (princ-to-string (clsql-sys::unescaped-database-identifier table)))) (declare (ignore hstmt)) (let ((query (get-free-query db))) (unwind-protect (progn (with-slots (hstmt) query (unless hstmt (setf hstmt (%new-statement-handle (hdbc db)))) (%table-statistics table hstmt :unique unique) (%initialize-query query nil nil) (values (db-fetch-query-results query) (coerce (column-names query) 'list)))) (db-close-query query)))) (defun list-all-table-columns (table &key db hstmt &aux (table (princ-to-string (clsql-sys::unescaped-database-identifier table)))) (declare (ignore hstmt)) (db-describe-columns db nil nil table nil)) ;; use nil rather than "" for unspecified values (defun list-all-data-sources () (let ((db (make-instance 'odbc-db))) (unless (henv db) ;; has class allocation! (setf (henv db) (%new-environment-handle))) (%list-data-sources (henv db)))) (defun rr-sql (hstmt sql-statement &key db) (declare (ignore hstmt sql-statement db)) (warn "rr-sql not implemented.")) ;;; Mid-level interface (defun db-commit (database) (%commit (henv database) (hdbc database))) (defun db-rollback (database) (%rollback (henv database) (hdbc database))) (defun db-cancel-query (query) (with-slots (hstmt) query (%sql-cancel hstmt) (setf (query-active-p query) nil))) #+simple-version (defmacro with-transaction (&body body) `(%with-transaction (:henv (henv ,*default-database*) :hdbc (hdbc ,*default-database*)) ,@body)) (defmethod initialize-instance :after ((query odbc-query) &key sql henv hdbc &allow-other-keys) (when sql (let ((hstmt (%new-statement-handle hdbc))) (%sql-exec-direct sql hstmt henv hdbc) (with-slots (column-count column-names column-c-types column-sql-types column-data-ptrs column-out-len-ptrs column-precisions column-scales column-nullables-p active-p) query (setf (hstmt query) hstmt) (%initialize-query query nil nil) (setf active-p t))))) ;; one for odbc-db is missing ;; TODO: Seems to be uncalled (defmethod terminate ((query odbc-query)) ;;(format tb::*local-output* "~%*** terminated: ~s" query) (db-close-query query)) (defun %dispose-column-ptrs (query) "frees memory allocated for query object column-data and column-data-length" (with-slots (column-data-ptrs column-out-len-ptrs hstmt) query (loop for data-ptr across column-data-ptrs for out-len-ptr across column-out-len-ptrs when data-ptr do (uffi:free-foreign-object data-ptr) when out-len-ptr do (uffi:free-foreign-object out-len-ptr)) (setf (fill-pointer column-data-ptrs) 0 (fill-pointer column-out-len-ptrs) 0))) (defmethod db-open-query ((database odbc-db) query-expression &key arglen col-positions result-types width &allow-other-keys) (db-open-query (get-free-query database) query-expression :arglen arglen :col-positions col-positions :result-types result-types :width (if width width (db-width database)))) (defmethod db-open-query ((query odbc-query) query-expression &key arglen col-positions result-types width &allow-other-keys) (%db-execute query query-expression) (%initialize-query query arglen col-positions :result-types result-types :width width)) (defmethod db-fetch-query-results ((database odbc-db) &optional count) (db-fetch-query-results (db-query-object database) count)) (defmethod db-fetch-query-results ((query odbc-query) &optional count) (when (query-active-p query) (with-slots (column-count column-data-ptrs column-c-types column-sql-types column-out-len-ptrs column-precisions hstmt computed-result-types) query (let* ((rows-fetched 0) (rows (loop for i from 0 until (or (and count (= i count)) (= (%sql-fetch hstmt) odbc::$SQL_NO_DATA_FOUND)) collect (loop for result-type across computed-result-types for data-ptr across column-data-ptrs for c-type across column-c-types for sql-type across column-sql-types for out-len-ptr across column-out-len-ptrs for precision across column-precisions for j from 0 ; column count is zero based in lisp collect (progn (incf rows-fetched) (cond ((< 0 precision (query-width query)) (read-data data-ptr c-type sql-type out-len-ptr result-type)) ((zerop (get-cast-long out-len-ptr)) nil) (t (read-data-in-chunks hstmt j data-ptr c-type sql-type out-len-ptr result-type)))))))) (values rows query rows-fetched))))) (defun db-query (database query-expression &key result-types width) (let ((free-query (get-free-query database))) (setf (sql-expression free-query) query-expression) (unwind-protect (progn (%db-execute free-query query-expression) (%initialize-query free-query nil nil :result-types result-types :width width) (if (plusp (column-count free-query)) ;; KMR: Added check for commands that don't return columns (values (db-fetch-query-results free-query nil) (map 'list #'identity (column-names free-query))) (values (result-rows-count (hstmt free-query)) nil))) (db-close-query free-query) ))) (defmethod %db-execute ((database odbc-db) sql-expression &key &allow-other-keys) (%db-execute (get-free-query database) sql-expression)) (defmethod %db-execute ((query odbc-query) sql-expression &key &allow-other-keys) (with-slots (henv hdbc) (odbc::query-database query) (with-slots (hstmt) query (unless hstmt (setf hstmt (%new-statement-handle hdbc))) (setf (sql-expression query) sql-expression) (%sql-exec-direct sql-expression hstmt henv hdbc) query))) ;; reuse inactive queries (defun get-free-query (database) "get-free-query finds or makes a nonactive query object, and then sets it to active. This makes the functions db-execute-command and db-query thread safe." (with-slots (queries hdbc) database (or (and *reuse-query-objects* (clsql-sys:without-interrupts (let ((inactive-query (find-if (lambda (query) (not (query-active-p query))) queries))) (when inactive-query (with-slots (column-count column-names column-c-types width hstmt column-sql-types column-data-ptrs column-out-len-ptrs column-precisions column-scales column-nullables-p) inactive-query (setf column-count 0 width +max-precision+ ;; KMR hstmt (%new-statement-handle hdbc) (fill-pointer column-names) 0 (fill-pointer column-c-types) 0 (fill-pointer column-sql-types) 0 (fill-pointer column-data-ptrs) 0 (fill-pointer column-out-len-ptrs) 0 (fill-pointer column-precisions) 0 (fill-pointer column-scales) 0 (fill-pointer column-nullables-p) 0)) (setf (query-active-p inactive-query) t)) inactive-query))) (let ((new-query (make-instance 'odbc-query :database database ;;(clone-database database) :active-p t))) (push new-query queries) new-query)))) (defmethod db-execute-command ((database odbc-db) sql-string) (db-execute-command (get-free-query database) sql-string)) (defmethod db-execute-command ((query odbc-query) sql-string) (with-slots (hstmt database) query (with-slots (henv hdbc) database (unless hstmt (setf hstmt (%new-statement-handle hdbc))) (unwind-protect (%sql-exec-direct sql-string hstmt henv hdbc) (db-close-query query))))) (defmethod %initialize-query ((database odbc-db) arglen col-positions &key result-types width) (%initialize-query (db-query-object database) arglen col-positions :result-types result-types :width (if width width (db-width database)))) (defmethod %initialize-query ((query odbc-query) arglen col-positions &key result-types width) (with-slots (hstmt computed-result-types column-count column-names column-c-types column-sql-types column-data-ptrs column-out-len-ptrs column-precisions column-scales column-nullables-p) query (setf column-count (if arglen (min arglen (result-columns-count hstmt)) (result-columns-count hstmt))) (when width (setf (query-width query) width)) ;;(format tb::*local-output* "~%column-count: ~d, col-positions: ~d" column-count col-positions) (labels ((initialize-column (col-nr) (multiple-value-bind (name sql-type precision scale nullable-p) (%describe-column hstmt (1+ col-nr)) ;; allocate space to bind result rows to (multiple-value-bind (c-type data-ptr out-len-ptr size long-p) (%allocate-bindings sql-type precision) (if long-p ;; if long-p we fetch in chunks with %sql-get-data but must ensure that out_len_ptr is non zero (setf (uffi:deref-pointer out-len-ptr #.odbc::$ODBC-LONG-TYPE) #.odbc::$SQL_NO_TOTAL) (%bind-column hstmt col-nr c-type data-ptr (1+ size) out-len-ptr)) (vector-push-extend name column-names) (vector-push-extend sql-type column-sql-types) (vector-push-extend (sql-to-c-type sql-type) column-c-types) (vector-push-extend precision column-precisions) (vector-push-extend scale column-scales) (vector-push-extend nullable-p column-nullables-p) (vector-push-extend data-ptr column-data-ptrs) (vector-push-extend out-len-ptr column-out-len-ptrs))))) (if col-positions (dolist (col-nr col-positions) (initialize-column col-nr)) (dotimes (col-nr column-count) ;; get column information (initialize-column col-nr)))) ;; TODO: move this into the above loop (setf computed-result-types (make-array column-count)) (dotimes (i column-count) (setf (aref computed-result-types i) (cond ((consp result-types) (nth i result-types)) ((eq result-types :auto) (case (aref column-c-types i) (#.odbc::$SQL_C_SLONG :int) (#.odbc::$SQL_C_DOUBLE :double) (#.odbc::$SQL_C_FLOAT :float) (#.odbc::$SQL_C_SSHORT :short) (#.odbc::$SQL_C_STINYINT :short) (#.odbc::$SQL_C_SBIGINT #.odbc::$ODBC-BIG-TYPE) (#.odbc::$SQL_C_TYPE_TIMESTAMP :time) (#.odbc::$SQL_C_CHAR ;; TODO: Read this as rational instead of double (or (case (aref column-sql-types i) ((#.odbc::$SQL_NUMERIC #.odbc::$SQL_DECIMAL) :double)) T)) (t t))) (t t))))) query) (defun db-close-query (query &key (drop-p (not *reuse-query-objects*))) (with-slots (hstmt column-count column-names column-c-types column-sql-types column-data-ptrs column-out-len-ptrs column-precisions column-scales column-nullables-p database) query (%dispose-column-ptrs query) (cond ((null hstmt) nil) (drop-p (%free-statement hstmt :drop) ;; dont free with uffi/ this is a double free and crashes everything ;; (uffi:free-foreign-object hstmt) (setf hstmt nil)) (t (%free-statement hstmt :unbind) (%free-statement hstmt :reset) (%free-statement hstmt :close))) (setf (query-active-p query) nil) (when drop-p (clsql-sys:without-interrupts (with-slots (queries) database (setf queries (remove query queries)))))) query) (defmethod %read-query-data ((database odbc-db) ignore-columns) (%read-query-data (db-query-object database) ignore-columns)) (defmethod %read-query-data ((query odbc-query) ignore-columns) (with-slots (hstmt column-count column-c-types column-sql-types column-data-ptrs column-out-len-ptrs column-precisions computed-result-types) query (unless (= (odbc::SQLFetch hstmt) odbc::$SQL_NO_DATA_FOUND) (values (loop for col-nr from 0 to (- column-count (if (eq ignore-columns :last) 2 1)) for result-type across computed-result-types collect (let ((precision (aref column-precisions col-nr)) (sql-type (aref column-sql-types col-nr))) (cond ((or (< 0 precision (query-width query)) (and (zerop precision) (not (find sql-type '($SQL_C_CHAR))))) (read-data (aref column-data-ptrs col-nr) (aref column-c-types col-nr) sql-type (aref column-out-len-ptrs col-nr) result-type)) ((zerop (get-cast-long (aref column-out-len-ptrs col-nr))) *null*) (t (read-data-in-chunks hstmt col-nr (aref column-data-ptrs col-nr) (aref column-c-types col-nr) (aref column-sql-types col-nr) (aref column-out-len-ptrs col-nr) result-type))))) t)))) (defmethod db-map-query ((database odbc-db) type function query-exp &key result-types) (db-map-query (get-free-query database) type function query-exp :result-types result-types)) (defmethod db-map-query ((query odbc-query) type function query-exp &key result-types) (declare (ignore type)) ; preliminary. Do a type coersion here (%db-execute query (sql-expression query-exp)) (unwind-protect (progn (%initialize-query query nil nil :result-types result-types) ;; the main loop (loop for data = (%read-query-data query nil) while data do (apply function data))) ;; dispose of memory and set query inactive or get rid of it (db-close-query query))) (defun db-map-bind-query (query type function &rest parameters) (declare (ignore type)) ; preliminary. Do a type coersion here (unwind-protect (progn (apply #'%db-bind-execute query parameters) ;; the main loop (loop with data while (setf data (%read-query-data query nil)) do (apply function data))) ;; dispose of memory and set query inactive or get rid of it (%db-reset-query query))) ;; does not always return exactly a lisp type... (defun sql-to-lisp-type (sql-type) (ecase sql-type ((#.odbc::$SQL_CHAR #.odbc::$SQL_VARCHAR #.odbc::$SQL_LONGVARCHAR) :string) ((#.odbc::$SQL_NUMERIC #.odbc::$SQL_DECIMAL) :string) ; ?? (#.odbc::$SQL_BIGINT #.odbc::$ODBC-BIG-TYPE) (#.odbc::$SQL_INTEGER #.odbc::$ODBC-LONG-TYPE) (#.odbc::$SQL_SMALLINT :short) ((#.odbc::$SQL_FLOAT #.odbc::$SQL_DOUBLE) #.odbc::$ODBC-LONG-TYPE) (#.odbc::$SQL_REAL #.odbc::$ODBC-LONG-TYPE) ((#.odbc::$SQL_DATE #.odbc::$SQL_TYPE_DATE) 'sql-c-date) ((#.odbc::$SQL_TIME #.odbc::$SQL_TYPE_TIME) 'sql-c-time) ((#.odbc::$SQL_TIMESTAMP #.odbc::$SQL_TYPE_TIMESTAMP) 'sql-c-timestamp) ;;((#.odbc::$SQL_BINARY #.odbc::$SQL_VARBINARY #.odbc::$SQL_LONGVARBINARY) odbc::$SQL_C_BINARY) ; ?? (#.odbc::$SQL_TINYINT :short) ;;(#.odbc::$SQL_BIT odbc::$SQL_C_BIT) ; ?? (#.odbc::$SQL_BIT :short) ((#.odbc::$SQL_VARBINARY #.odbc::$SQL_LONGVARBINARY) :binary) )) ;; prepared queries (defmethod db-prepare-statement ((database odbc-db) sql &key parameter-table parameter-columns) (with-slots (hdbc) database (let ((query (get-free-query database))) (with-slots (hstmt) query (unless hstmt (setf hstmt (%new-statement-handle hdbc)))) (db-prepare-statement query sql :parameter-table parameter-table :parameter-columns parameter-columns)))) (defmethod db-prepare-statement ((query odbc-query) (sql string) &key parameter-table parameter-columns) ;; this is a workaround to get hold of the column types when the driver does not ;; support SQLDescribeParam. To do: put code in here for drivers that do ;; support it. (unless (string-equal sql "insert" :end1 6) (error 'clsql:sql-database-error (format nil "Only insert expressions are supported in literal ODBC: '~a'." sql))) (%db-execute query (format nil "select ~{~a~^,~} from ~a where 0 = 1" (or parameter-columns '("*")) parameter-table)) (%initialize-query query nil nil) (with-slots (hstmt) query (%free-statement hstmt :unbind) (%free-statement hstmt :reset) (setf (sql-expression query) sql) (%sql-prepare hstmt sql)) query) (defun %db-bind-execute (query &rest parameters) "Only used from db-map-bind-query parameters are released in %reset-query " (with-slots (hstmt parameter-data-ptrs) query (loop for parameter in parameters with data-ptr and size and parameter-string do (setf parameter-string (if (stringp parameter) parameter (write-to-string parameter)) size (length parameter-string) data-ptr (uffi:allocate-foreign-string (1+ size))) (vector-push-extend data-ptr parameter-data-ptrs) (%sql-bind-parameter hstmt (1- (fill-pointer parameter-data-ptrs)) odbc::$SQL_PARAM_INPUT odbc::$SQL_C_CHAR ; (aref column-c-types parameter-count) odbc::$SQL_CHAR ; sql-type (query-width query) ;precision ; this should be the actual precision! ;; scale 0 ;; should be calculated for odbc::$SQL_DECIMAL, ;;$SQL_NUMERIC and odbc::$SQL_TIMESTAMP data-ptr ;; = rgbValue 0 ;; *pcbValue; ;; change this for output and binary input! (see 3-32) +null-ptr+) (%put-str data-ptr parameter-string size)) (%sql-execute hstmt))) (defun %db-reset-query (query) "Only used from db-map-bind-query parameters are allocated in %db-bind-execute " (with-slots (hstmt parameter-data-ptrs) query (prog1 (db-fetch-query-results query nil) (%free-statement hstmt :reset) ;; but _not_ :unbind ! (%free-statement hstmt :close) (dotimes (param-nr (fill-pointer parameter-data-ptrs)) (let ((data-ptr (aref parameter-data-ptrs param-nr))) (when data-ptr (uffi:free-foreign-object data-ptr)))) (setf (fill-pointer parameter-data-ptrs) 0)))) (defun data-parameter-ptr (hstmt) (uffi:with-foreign-object (param-ptr :pointer-void) (let ((return-code (%sql-param-data hstmt param-ptr))) ;;(format t "~%return-code from %sql-param-data: ~a~%" return-code) (when (= return-code odbc::$SQL_NEED_DATA) ;;(ffc::%pointer-to-address (%get-ptr param-ptr)) (uffi:deref-pointer param-ptr :pointer-void))))) ;; database inquiery functions (defun db-describe-columns (database table-qualifier table-owner table-name column-name) (with-slots (hdbc) database (%describe-columns hdbc table-qualifier table-owner table-name column-name))) ;; should translate info-type integers to keywords in order to make this ;; more readable? (defmethod get-odbc-info ((database odbc-db) info-type) (with-slots (hdbc info) database (or (gethash info-type info) (setf (gethash info-type info) (%sql-get-info hdbc info-type))))) (defmethod get-odbc-info ((query odbc-query) info-type) (get-odbc-info (odbc::query-database query) info-type)) ;; driver inquiry ;; How does this differ from list-data-sources? (defgeneric db-data-sources (db-type)) (defmethod db-data-sources ((db-type (eql :odbc))) "Returns a list of (data-source description) - pairs" (let ((henv (%new-environment-handle))) (unwind-protect (loop with direction = :first for data-source+description = (multiple-value-list (%sql-data-sources henv :direction direction)) while (car data-source+description) collect data-source+description do (setf direction :next)) (%sql-free-environment henv))))