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