db-odbc/odbc-dbi.lisp

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:    odbc-dbi.cl
   6 ;;;; Purpose: Mid-level (DBI) interface for CLSQL ODBC backend
   7 ;;;; Author:  Kevin M. Rosenberg
   8 ;;;; Create:  April 2004
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  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 ;;;; *************************************************************************
  18
  19 (in-package #:cl-user)
  20
  21 (defpackage #:odbc-dbi
  22   (:use #:cl #:odbc)
  23   (:export
  24    #:bind-parameter
  25    #:close-query
  26    #:connect
  27    #:db-external-format
  28    #:db-hstmt
  29    #:db-width
  30    #:disconnect
  31    #:end-transaction
  32    #:fetch-row
  33    #:list-all-data-sources
  34    #:list-all-database-tables
  35    #:list-all-table-columns
  36    #:list-table-indexes
  37    #:loop-over-results
  38    #:prepare-sql
  39    #:rr-sql
  40    #:run-prepared-sql
  41    #:set-autocommit
  42    #:sql
  43
  44    #:*auto-trim-strings*
  45    #:*default-database*
  46    #:*default-odbc-external-format*
  47    #:*null-value*
  48    )
  49   (:documentation "This is the mid-level interface ODBC."))
  50
  51 (in-package #:odbc-dbi)
  52
  53 (defgeneric terminate (src))
  54 (defgeneric db-open-query (src query-expression
  55                                &key arglen col-positions result-types width
  56                                &allow-other-keys))
  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))
  60
  61 (defgeneric %initialize-query (src arglen col-positions
  62                                    &key result-types width))
  63
  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
  67                                       parameter-columns))
  68 (defgeneric get-odbc-info (src info-type))
  69
  70
  71 ;;; SQL Interface
  72
  73 (defclass odbc-db ()
  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)
  83    ;; not used yet
  84    (count :initform 0 :initarg :count :accessor db-count)
  85    ;; not used yet
  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)))
  91
  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)
 104                      :accessor data-ptrs)
 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))
 121   (:documentation
 122    "Stores query information, like SQL query string/expression and database to run
 123 the query against." ))
 124
 125 ;;; AODBC Compatible interface
 126
 127 (defun connect (&key data-source-name user password (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     (%sql-connect (hdbc db) data-source-name user password)
 133     #+ignore (setf (db-hstmt db) (%new-statement-handle (hdbc db)))
 134     (when (/= (get-odbc-info db odbc::$SQL_TXN_CAPABLE) odbc::$SQL_TC_NONE)
 135       (if autocommit
 136           (enable-autocommit (hdbc db))
 137           (disable-autocommit (hdbc db))))
 138     db))
 139
 140 (defun disconnect (database)
 141   (with-slots (hdbc queries) database
 142     (dolist (query queries)
 143       (if (query-active-p query)
 144           (with-slots (hstmt) query
 145             (when hstmt
 146               (%free-statement hstmt :drop)
 147               (setf hstmt nil)))))
 148     (when (db-hstmt database)
 149       (%free-statement (db-hstmt database) :drop))
 150     (%disconnect hdbc)))
 151
 152
 153 (defun sql (expr &key db result-types row-count (column-names t) query
 154                       hstmt width)
 155   (declare (ignore hstmt))
 156   (cond
 157    (query
 158     (let ((q (db-open-query db expr :result-types result-types :width width)))
 159       (if column-names
 160           (values q (column-names q))
 161         q)))
 162    (t
 163     (multiple-value-bind (data col-names)
 164         (db-query db expr :result-types result-types :width width)
 165       (cond
 166         (row-count
 167          (if (consp data) (length data) data))
 168         (column-names
 169          (values data col-names))
 170         (t
 171          data))))))
 172
 173 (defun fetch-row (query &optional (eof-errorp t) eof-value)
 174   (multiple-value-bind (row query count) (db-fetch-query-results query 1)
 175     (cond
 176      ((zerop count)
 177       (close-query query)
 178       (when eof-errorp
 179         (error 'clsql:sql-database-data-error
 180                :message "ODBC: Ran out of data in fetch-row"))
 181       eof-value)
 182      (t
 183       (car row)))))
 184
 185
 186 (defun close-query (query)
 187   (db-close-query query))
 188
 189 (defun list-all-database-tables (&key db hstmt)
 190   (declare (ignore hstmt))
 191   (let ((query (get-free-query db)))
 192     (unwind-protect
 193         (progn
 194           (with-slots (hstmt) query
 195             (unless hstmt (setf hstmt (%new-statement-handle (hdbc db))))
 196             (%list-tables hstmt)
 197             (%initialize-query query nil nil)
 198             (values
 199              (db-fetch-query-results query)
 200              (coerce (column-names query) 'list))))
 201       (db-close-query query))))
 202
 203 (defun list-table-indexes (table &key db unique hstmt)
 204   (declare (ignore hstmt))
 205   (let ((query (get-free-query db)))
 206     (unwind-protect
 207         (progn
 208           (with-slots (hstmt) query
 209             (unless hstmt
 210               (setf hstmt (%new-statement-handle (hdbc db))))
 211             (%table-statistics table hstmt :unique unique)
 212             (%initialize-query query nil nil)
 213             (values
 214              (db-fetch-query-results query)
 215              (coerce (column-names query) 'list))))
 216       (db-close-query query))))
 217
 218 (defun list-all-table-columns (table &key db hstmt)
 219   (declare (ignore hstmt))
 220   (db-describe-columns db "" "" table ""))
 221
 222 (defun list-all-data-sources ()
 223   (let ((db (make-instance 'odbc-db)))
 224     (unless (henv db) ;; has class allocation!
 225       (setf (henv db) (%new-environment-handle)))
 226     (%list-data-sources (henv db))))
 227
 228 (defun rr-sql (hstmt sql-statement &key db)
 229   (declare (ignore hstmt sql-statement db))
 230   (warn "rr-sql not implemented."))
 231
 232 ;;; Mid-level interface
 233
 234 (defun db-commit (database)
 235   (%commit (henv database) (hdbc database)))
 236
 237 (defun db-rollback (database)
 238   (%rollback (henv database) (hdbc database)))
 239
 240 (defun db-cancel-query (query)
 241   (with-slots (hstmt) query
 242     (%sql-cancel hstmt)
 243     (setf (query-active-p query) nil)))
 244
 245 #+simple-version
 246 (defmacro with-transaction (&body body)
 247   `(%with-transaction
 248      (:henv (henv ,*default-database*) :hdbc (hdbc ,*default-database*))
 249      ,@body))
 250
 251 (defmethod initialize-instance :after ((query odbc-query)
 252                                        &key sql henv hdbc &allow-other-keys)
 253   (when sql
 254     (let ((hstmt (%new-statement-handle hdbc)))
 255       (%sql-exec-direct sql hstmt henv hdbc)
 256       (with-slots (column-count
 257                    column-names column-c-types column-sql-types column-data-ptrs
 258                    column-out-len-ptrs column-precisions column-scales
 259                    column-nullables-p active-p) query
 260         (setf (hstmt query) hstmt)
 261         (%initialize-query query nil nil)
 262         (setf active-p t)))))
 263
 264 ;; one for odbc-db is missing
 265 (defmethod terminate ((query odbc-query))
 266   ;;(format tb::*local-output* "~%*** terminated: ~s" query)
 267   (with-slots (hstmt) query
 268     (when hstmt
 269       ;(%free-statement hstmt :drop)
 270       (uffi:free-foreign-object hstmt)) ;; ??
 271     (%dispose-column-ptrs query)))
 272
 273 (defun %dispose-column-ptrs (query)
 274   (with-slots (column-data-ptrs column-out-len-ptrs hstmt) query
 275     (loop for data-ptr across column-data-ptrs
 276           when data-ptr do (uffi:free-foreign-object data-ptr))
 277     (loop for out-len-ptr across column-out-len-ptrs
 278           when out-len-ptr do (uffi:free-foreign-object out-len-ptr))))
 279
 280 (defmethod db-open-query ((database odbc-db) query-expression
 281                           &key arglen col-positions result-types width
 282                           &allow-other-keys)
 283   (db-open-query (get-free-query database) query-expression
 284                  :arglen arglen :col-positions col-positions
 285                  :result-types result-types
 286                  :width (if width width (db-width database))))
 287
 288 (defmethod db-open-query ((query odbc-query) query-expression
 289                           &key arglen col-positions result-types width
 290                           &allow-other-keys)
 291   (%db-execute query query-expression)
 292   (%initialize-query query arglen col-positions :result-types result-types
 293                      :width width))
 294
 295 (defmethod db-fetch-query-results ((database odbc-db) &optional count)
 296   (db-fetch-query-results (db-query-object database) count))
 297
 298 (defmethod db-fetch-query-results ((query odbc-query) &optional count)
 299   (when (query-active-p query)
 300     (with-slots (column-count column-data-ptrs column-c-types column-sql-types
 301                  column-out-len-ptrs column-precisions hstmt computed-result-types)
 302         query
 303       (let* ((rows-fetched 0)
 304              (rows
 305               (loop for i from 0
 306                   until (or (and count (= i count))
 307                             (= (%sql-fetch hstmt) odbc::$SQL_NO_DATA_FOUND))
 308                   collect
 309                     (loop for result-type across computed-result-types
 310                         for data-ptr across column-data-ptrs
 311                         for c-type across column-c-types
 312                         for sql-type across column-sql-types
 313                         for out-len-ptr across column-out-len-ptrs
 314                         for precision across column-precisions
 315                         for j from 0    ; column count is zero based in lisp
 316                         collect
 317                           (progn
 318                             (incf rows-fetched)
 319                             (cond ((< 0 precision (query-width query))
 320                                    (read-data data-ptr c-type sql-type out-len-ptr result-type))
 321                                   ((zerop (get-cast-long out-len-ptr))
 322                               nil)
 323                                   (t
 324                                    (read-data-in-chunks hstmt j data-ptr c-type sql-type
 325                                                         out-len-ptr result-type))))))))
 326         (values rows query rows-fetched)))))
 327
 328 (defun db-query (database query-expression &key result-types width)
 329   (let ((free-query (get-free-query database)))
 330     (setf (sql-expression free-query) query-expression)
 331     (unwind-protect
 332       (progn
 333         (%db-execute free-query query-expression)
 334         (%initialize-query free-query nil nil :result-types result-types :width width)
 335         (if (plusp (column-count free-query)) ;; KMR: Added check for commands that don't return columns
 336             (values
 337              (db-fetch-query-results free-query nil)
 338              (map 'list #'identity (column-names free-query)))
 339           (values
 340            (result-rows-count (hstmt free-query))
 341            nil)))
 342       (db-close-query free-query)
 343       )))
 344
 345 (defmethod %db-execute ((database odbc-db) sql-expression &key &allow-other-keys)
 346   (%db-execute (get-free-query database) sql-expression))
 347
 348 (defmethod %db-execute ((query odbc-query) sql-expression &key &allow-other-keys)
 349   (with-slots (henv hdbc) (odbc::query-database query)
 350     (with-slots (hstmt) query
 351       (unless hstmt (setf hstmt (%new-statement-handle hdbc)))
 352       (setf (sql-expression query) sql-expression)
 353       (%sql-exec-direct sql-expression hstmt henv hdbc)
 354       query)))
 355
 356 ;; reuse inactive queries
 357 (defun get-free-query (database)
 358   "get-free-query finds or makes a nonactive query object, and then sets it to active.
 359 This makes the functions db-execute-command and db-query thread safe."
 360   (with-slots (queries hdbc) database
 361     (or (clsql-sys:without-interrupts
 362          (let ((inactive-query (find-if (lambda (query)
 363                                           (not (query-active-p query)))
 364                                         queries)))
 365            (when inactive-query
 366              (with-slots (column-count column-names column-c-types
 367                           width hstmt
 368                           column-sql-types column-data-ptrs
 369                           column-out-len-ptrs column-precisions
 370                           column-scales column-nullables-p)
 371                          inactive-query
 372                ;;(print column-data-ptrs tb::*local-output*)
 373                ;;(%dispose-column-ptrs inactive-query)
 374                (setf column-count 0
 375                      width +max-precision+
 376                      ;; KMR hstmt (%new-statement-handle hdbc)
 377                      (fill-pointer column-names) 0
 378                      (fill-pointer column-c-types) 0
 379                      (fill-pointer column-sql-types) 0
 380                      (fill-pointer column-data-ptrs) 0
 381                      (fill-pointer column-out-len-ptrs) 0
 382                      (fill-pointer column-precisions) 0
 383                      (fill-pointer column-scales) 0
 384                      (fill-pointer column-nullables-p) 0))
 385              (setf (query-active-p inactive-query) t))
 386            inactive-query))
 387         (let ((new-query (make-instance 'odbc-query
 388                                         :database database
 389                                         ;;(clone-database database)
 390                                         :active-p t)))
 391           (push new-query queries)
 392           new-query))))
 393
 394 (defmethod db-execute-command ((database odbc-db) sql-string)
 395   (db-execute-command (get-free-query database) sql-string))
 396
 397 (defmethod db-execute-command ((query odbc-query) sql-string)
 398   (with-slots (hstmt database) query
 399     (with-slots (henv hdbc) database
 400       (unless hstmt (setf hstmt (%new-statement-handle hdbc)))
 401       (unwind-protect
 402           (%sql-exec-direct sql-string hstmt henv hdbc)
 403         (db-close-query query)))))
 404
 405 (defmethod %initialize-query ((database odbc-db) arglen col-positions &key result-types width)
 406   (%initialize-query (db-query-object database) arglen col-positions
 407                      :result-types result-types
 408                      :width (if width width (db-width database))))
 409
 410 (defmethod %initialize-query ((query odbc-query) arglen col-positions &key result-types width)
 411   (with-slots (hstmt computed-result-types
 412                column-count column-names column-c-types column-sql-types
 413                column-data-ptrs column-out-len-ptrs column-precisions
 414                column-scales column-nullables-p)
 415       query
 416     (setf column-count (if arglen
 417                          (min arglen (result-columns-count hstmt))
 418                          (result-columns-count hstmt)))
 419     (when width (setf (query-width query) width))
 420     ;;(format tb::*local-output* "~%column-count: ~d, col-positions: ~d" column-count col-positions)
 421     (labels ((initialize-column (col-nr)
 422                 (multiple-value-bind (name sql-type precision scale nullable-p)
 423                                      (%describe-column hstmt (1+ col-nr))
 424                   ;; allocate space to bind result rows to
 425                   (multiple-value-bind (c-type data-ptr out-len-ptr size long-p)
 426                                        (%allocate-bindings sql-type precision)
 427                     (unless long-p ;; if long-p we fetch in chunks with %sql-get-data
 428                       (%bind-column hstmt col-nr c-type data-ptr (1+ size) out-len-ptr))
 429                     (vector-push-extend name column-names)
 430                     (vector-push-extend sql-type column-sql-types)
 431                     (vector-push-extend (sql-to-c-type sql-type) column-c-types)
 432                     (vector-push-extend precision column-precisions)
 433                     (vector-push-extend scale column-scales)
 434                     (vector-push-extend nullable-p column-nullables-p)
 435                     (vector-push-extend data-ptr column-data-ptrs)
 436                     (vector-push-extend out-len-ptr column-out-len-ptrs)))))
 437       (if col-positions
 438         (dolist (col-nr col-positions)
 439           (initialize-column col-nr))
 440         (dotimes (col-nr column-count)
 441           ;; get column information
 442           (initialize-column col-nr))))
 443
 444     (setf computed-result-types (make-array column-count))
 445     (dotimes (i column-count)
 446       (setf (aref computed-result-types i)
 447         (cond
 448          ((consp result-types)
 449           (nth i result-types))
 450          ((eq result-types :auto)
 451           (if (eq (aref column-sql-types i) odbc::$SQL_BIGINT)
 452               :number
 453             (case (aref column-c-types i)
 454               (#.odbc::$SQL_C_SLONG :int)
 455               (#.odbc::$SQL_C_DOUBLE :double)
 456               (#.odbc::$SQL_C_FLOAT :float)
 457               (#.odbc::$SQL_C_SSHORT :short)
 458               (#.odbc::$SQL_C_STINYINT :short)
 459               (#.odbc::$SQL_BIGINT :short)
 460               (t t))))
 461           (t
 462            t)))))
 463   query)
 464
 465 (defun db-close-query (query &key drop-p)
 466   (with-slots (hstmt column-count column-names column-c-types column-sql-types
 467                      column-data-ptrs column-out-len-ptrs column-precisions
 468                      column-scales column-nullables-p) query
 469     (let ((count (fill-pointer column-data-ptrs)))
 470       (when (not (zerop count))
 471         (dotimes (col-nr count)
 472           (let ((data-ptr (aref column-data-ptrs col-nr))
 473                 (out-len-ptr (aref column-out-len-ptrs col-nr)))
 474             (declare (ignorable data-ptr out-len-ptr))
 475             ;; free-statment :unbind frees these
 476             #+ignore (when data-ptr (uffi:free-foreign-object data-ptr))
 477             #+ignore (when out-len-ptr (uffi:free-foreign-object out-len-ptr)))))
 478       (cond ((null hstmt)
 479              nil)
 480             (drop-p
 481              (%free-statement hstmt :drop)
 482              (setf hstmt nil))
 483             (t
 484              (%free-statement hstmt :unbind)
 485              (%free-statement hstmt :reset)
 486              (%free-statement hstmt :close)))
 487       (setf (query-active-p query) nil)))
 488   query)
 489
 490 (defmethod %read-query-data ((database odbc-db) ignore-columns)
 491   (%read-query-data (db-query-object database) ignore-columns))
 492
 493 (defmethod %read-query-data ((query odbc-query) ignore-columns)
 494   (with-slots (hstmt column-count column-c-types column-sql-types
 495                column-data-ptrs column-out-len-ptrs column-precisions
 496                computed-result-types)
 497       query
 498     (unless (= (odbc::SQLFetch hstmt) odbc::$SQL_NO_DATA_FOUND)
 499       (values
 500        (loop for col-nr from 0 to (- column-count
 501                                      (if (eq ignore-columns :last) 2 1))
 502            for result-type across computed-result-types
 503            collect
 504              (let ((precision (aref column-precisions col-nr))
 505                    (sql-type (aref column-sql-types col-nr)))
 506                (cond ((or (< 0 precision (query-width query))
 507                           (and (zerop precision) (not (find sql-type '($SQL_C_CHAR)))))
 508                       (read-data (aref column-data-ptrs col-nr)
 509                                  (aref column-c-types col-nr)
 510                                  sql-type
 511                                  (aref column-out-len-ptrs col-nr)
 512                                  result-type))
 513                      ((zerop (get-cast-long (aref column-out-len-ptrs col-nr)))
 514                       *null*)
 515                      (t
 516                       (read-data-in-chunks hstmt col-nr
 517                                            (aref column-data-ptrs col-nr)
 518                                            (aref column-c-types col-nr)
 519                                            (aref column-sql-types col-nr)
 520                                            (aref column-out-len-ptrs col-nr)
 521                                            result-type)))))
 522        t))))
 523
 524 (defmethod db-map-query ((database odbc-db) type function query-exp &key result-types)
 525   (db-map-query (get-free-query database) type function query-exp :result-types result-types))
 526
 527 (defmethod db-map-query ((query odbc-query) type function query-exp &key result-types)
 528   (declare (ignore type)) ; preliminary. Do a type coersion here
 529   (%db-execute query (sql-expression query-exp))
 530   (unwind-protect
 531     (progn
 532       (%initialize-query query nil nil :result-types result-types)
 533       ;; the main loop
 534       (loop for data = (%read-query-data query nil)
 535             while data
 536             do (apply function data)))
 537     ;; dispose of memory and set query inactive or get rid of it
 538     (db-close-query query)))
 539
 540 (defun db-map-bind-query (query type function
 541                           &rest parameters)
 542   (declare (ignore type)) ; preliminary. Do a type coersion here
 543   (unwind-protect
 544     (progn
 545       (apply #'%db-bind-execute query parameters)
 546       ;; the main loop
 547       (loop with data
 548             while (setf data (%read-query-data query nil))
 549             do (apply function data)))
 550     ;; dispose of memory and set query inactive or get rid of it
 551     (%db-reset-query query)))
 552
 553 ;; does not always return exactly a lisp type...
 554 (defun sql-to-lisp-type (sql-type)
 555   (ecase sql-type
 556     ((#.odbc::$SQL_CHAR #.odbc::$SQL_VARCHAR #.odbc::$SQL_LONGVARCHAR) :string)
 557     ((#.odbc::$SQL_NUMERIC #.odbc::$SQL_DECIMAL #.odbc::$SQL_BIGINT) :string) ; ??
 558     (#.odbc::$SQL_INTEGER #.odbc::$ODBC-LONG-TYPE)
 559     (#.odbc::$SQL_SMALLINT :short)
 560     ((#.odbc::$SQL_FLOAT #.odbc::$SQL_DOUBLE) #.odbc::$ODBC-LONG-TYPE)
 561     (#.odbc::$SQL_REAL #.odbc::$ODBC-LONG-TYPE)
 562     (#.odbc::$SQL_DATE 'sql-c-date)
 563     (#.odbc::$SQL_TIME 'sql-c-time)
 564     (#.odbc::$SQL_TIMESTAMP 'sql-c-timestamp)
 565     ;;((#.odbc::$SQL_BINARY #.odbc::$SQL_VARBINARY #.odbc::$SQL_LONGVARBINARY) odbc::$SQL_C_BINARY) ; ??
 566     (#.odbc::$SQL_TINYINT :short)
 567     ;;(#.odbc::$SQL_BIT odbc::$SQL_C_BIT) ; ??
 568     ((#.odbc::$SQL_VARBINARY #.odbc::$SQL_LONGVARBINARY) :binary)
 569     ))
 570
 571 ;; prepared queries
 572
 573 (defmethod db-prepare-statement ((database odbc-db) sql
 574                                      &key parameter-table parameter-columns)
 575   (with-slots (hdbc) database
 576     (let ((query (get-free-query database)))
 577       (with-slots (hstmt) query
 578         (unless hstmt (setf hstmt (%new-statement-handle hdbc))))
 579       (db-prepare-statement query sql parameter-table parameter-columns))))
 580
 581 (defmethod db-prepare-statement ((query odbc-query) (sql string)
 582                                      &key parameter-table parameter-columns)
 583   ;; this is a workaround to get hold of the column types when the driver does not
 584   ;; support SQLDescribeParam. To do: put code in here for drivers that do
 585   ;; support it.
 586   (unless (string-equal sql "insert" :end1 6)
 587     (error 'clsql:sql-database-error
 588            (format nil
 589                    "Only insert expressions are supported in literal ODBC: '~a'." sql)))
 590   (%db-execute query (format nil "select ~{~a~^,~} from ~a where 0 = 1"
 591                              (or parameter-columns '("*")) parameter-table))
 592   (%initialize-query query nil nil)
 593   (with-slots (hstmt) query
 594     (%free-statement hstmt :unbind)
 595     (%free-statement hstmt :reset)
 596     (setf (sql-expression query) sql)
 597     (%sql-prepare hstmt sql))
 598   query)
 599
 600
 601 (defun %db-bind-execute (query &rest parameters)
 602   (with-slots (hstmt parameter-data-ptrs) query
 603     (loop for parameter in parameters
 604           with data-ptr and size and parameter-string
 605           do
 606           (setf parameter-string
 607                 (if (stringp parameter)
 608                   parameter
 609                   (write-to-string parameter))
 610            size (length parameter-string)
 611                 data-ptr
 612                 (uffi:allocate-foreign-string (1+ size)))
 613           (vector-push-extend data-ptr parameter-data-ptrs)
 614           (%sql-bind-parameter
 615            hstmt (1- (fill-pointer parameter-data-ptrs)) odbc::$SQL_PARAM_INPUT
 616            odbc::$SQL_C_CHAR ; (aref column-c-types parameter-count)
 617            odbc::$SQL_CHAR ; sql-type
 618            (query-width query)          ;precision ; this should be the actual precision!
 619            ;; scale
 620            0 ;; should be calculated for odbc::$SQL_DECIMAL,
 621            ;;$SQL_NUMERIC and odbc::$SQL_TIMESTAMP
 622            data-ptr ;; = rgbValue
 623            0
 624            ;; *pcbValue;
 625            ;; change this for output and binary input! (see 3-32)
 626            +null-ptr+)
 627           (%put-str data-ptr parameter-string size))
 628         (%sql-execute hstmt)))
 629
 630
 631 (defun %db-reset-query (query)
 632   (with-slots (hstmt parameter-data-ptrs) query
 633     (prog1
 634       (db-fetch-query-results query nil)
 635       (%free-statement hstmt :reset) ;; but _not_ :unbind !
 636       (%free-statement hstmt :close)
 637       (dotimes (param-nr (fill-pointer parameter-data-ptrs))
 638         (let ((data-ptr (aref parameter-data-ptrs param-nr)))
 639           (when data-ptr (uffi:free-foreign-object data-ptr))))
 640       (setf (fill-pointer parameter-data-ptrs) 0))))
 641
 642 (defun data-parameter-ptr (hstmt)
 643   (uffi:with-foreign-object (param-ptr :pointer-void)
 644     (let ((return-code (%sql-param-data hstmt param-ptr)))
 645       ;;(format t "~%return-code from %sql-param-data: ~a~%" return-code)
 646       (when (= return-code odbc::$SQL_NEED_DATA)
 647         ;;(ffc::%pointer-to-address (%get-ptr param-ptr))
 648         (uffi:deref-pointer param-ptr :pointer-void)))))
 649
 650 ;; database inquiery functions
 651
 652 (defun db-describe-columns (database table-qualifier table-owner
 653                             table-name column-name)
 654   (with-slots (hdbc) database
 655     (%describe-columns hdbc table-qualifier table-owner table-name column-name)))
 656
 657 ;; should translate info-type integers to keywords in order to make this
 658 ;; more readable?
 659 (defmethod get-odbc-info ((database odbc-db) info-type)
 660   (with-slots (hdbc info) database
 661     (or (gethash info-type info)
 662         (setf (gethash info-type info)
 663               (%sql-get-info hdbc info-type)))))
 664
 665 (defmethod get-odbc-info ((query odbc-query) info-type)
 666   (get-odbc-info (odbc::query-database query) info-type))
 667
 668 ;; driver inquiry
 669 ;; How does this differ from list-data-sources?
 670 (defgeneric db-data-sources (db-type))
 671 (defmethod db-data-sources ((db-type (eql :odbc)))
 672    "Returns a list of (data-source description) - pairs"
 673    (let ((henv (%new-environment-handle)))
 674     (unwind-protect
 675           (loop with direction = :first
 676                for data-source+description
 677                = (multiple-value-list (%sql-data-sources henv :direction direction))
 678                while (car data-source+description)
 679                collect data-source+description
 680                do (setf direction :next))
 681       (%sql-free-environment henv))))