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 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
  11 ;;;;
  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 ;;;; *************************************************************************
  16
  17 (in-package #:cl-user)
  18
  19 (defpackage #:odbc-dbi
  20   (:use #:cl #:odbc)
  21   (:export
  22    #:bind-parameter
  23    #:close-query
  24    #:connect
  25    #:db-external-format
  26    #:db-hstmt
  27    #:db-width
  28    #:disconnect
  29    #:end-transaction
  30    #:fetch-row
  31    #:list-all-data-sources
  32    #:list-all-database-tables
  33    #:list-all-table-columns
  34    #:list-table-indexes
  35    #:loop-over-results
  36    #:prepare-sql
  37    #:rr-sql
  38    #:run-prepared-sql
  39    #:set-autocommit
  40    #:sql
  41
  42    #:*auto-trim-strings*
  43    #:*default-database*
  44    #:*default-odbc-external-format*
  45    #:*null-value*
  46    )
  47   (:documentation "This is the mid-level interface ODBC."))
  48
  49 (in-package #:odbc-dbi)
  50
  51 (defgeneric terminate (src))
  52 (defgeneric db-open-query (src query-expression
  53                                &key arglen col-positions result-types width
  54                                &allow-other-keys))
  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))
  58
  59 (defgeneric %initialize-query (src arglen col-positions
  60                                    &key result-types width))
  61
  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
  65                                       parameter-columns))
  66 (defgeneric get-odbc-info (src info-type))
  67
  68 (defvar *reuse-query-objects* t)
  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 '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))
 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 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)
 134                              connection-string
 135                              (ecase completion
 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))
 140                              window-handle)
 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)
 144       (if autocommit
 145           (enable-autocommit (hdbc db))
 146           (disable-autocommit (hdbc db))))
 147     db))
 148
 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))
 157     (%disconnect hdbc)))
 158
 159
 160 (defun sql (expr &key db result-types row-count (column-names t) query
 161                       hstmt width)
 162   (declare (ignore hstmt))
 163   (cond
 164    (query
 165     (let ((q (db-open-query db expr :result-types result-types :width width)))
 166       (if column-names
 167           (values q (column-names q))
 168         q)))
 169    (t
 170     (multiple-value-bind (data col-names)
 171         (db-query db expr :result-types result-types :width width)
 172       (cond
 173         (row-count
 174          (if (consp data) (length data) data))
 175         (column-names
 176          (values data col-names))
 177         (t
 178          data))))))
 179
 180 (defun fetch-row (query &optional (eof-errorp t) eof-value)
 181   (multiple-value-bind (row query count) (db-fetch-query-results query 1)
 182     (cond
 183      ((zerop count)
 184       (close-query query)
 185       (when eof-errorp
 186         (error 'clsql:sql-database-data-error
 187                :message "ODBC: Ran out of data in fetch-row"))
 188       eof-value)
 189      (t
 190       (car row)))))
 191
 192
 193 (defun close-query (query)
 194   (db-close-query query))
 195
 196 (defun list-all-database-tables (&key db hstmt)
 197   (declare (ignore hstmt))
 198   (let ((query (get-free-query db)))
 199     (unwind-protect
 200         (progn
 201           (with-slots (hstmt) query
 202             (unless hstmt (setf hstmt (%new-statement-handle (hdbc db))))
 203             (%list-tables hstmt)
 204             (%initialize-query query nil nil)
 205             (values
 206              (db-fetch-query-results query)
 207              (coerce (column-names query) 'list))))
 208       (db-close-query query))))
 209
 210 (defun list-table-indexes (table &key db unique hstmt
 211                             &aux (table
 212                                      (princ-to-string
 213                                       (clsql-sys::unescaped-database-identifier table))))
 214   (declare (ignore hstmt))
 215   (let ((query (get-free-query db)))
 216     (unwind-protect
 217          (progn
 218            (with-slots (hstmt) query
 219              (unless hstmt
 220                (setf hstmt (%new-statement-handle (hdbc db))))
 221              (%table-statistics table hstmt :unique unique)
 222              (%initialize-query query nil nil)
 223              (values
 224               (db-fetch-query-results query)
 225               (coerce (column-names query) 'list))))
 226       (db-close-query query))))
 227
 228 (defun list-all-table-columns (table &key db hstmt
 229                                 &aux (table
 230                                          (princ-to-string
 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
 234
 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))))
 240
 241 (defun rr-sql (hstmt sql-statement &key db)
 242   (declare (ignore hstmt sql-statement db))
 243   (warn "rr-sql not implemented."))
 244
 245 ;;; Mid-level interface
 246
 247 (defun db-commit (database)
 248   (%commit (henv database) (hdbc database)))
 249
 250 (defun db-rollback (database)
 251   (%rollback (henv database) (hdbc database)))
 252
 253 (defun db-cancel-query (query)
 254   (with-slots (hstmt) query
 255     (%sql-cancel hstmt)
 256     (setf (query-active-p query) nil)))
 257
 258 #+simple-version
 259 (defmacro with-transaction (&body body)
 260   `(%with-transaction
 261      (:henv (henv ,*default-database*) :hdbc (hdbc ,*default-database*))
 262      ,@body))
 263
 264 (defmethod initialize-instance :after ((query odbc-query)
 265                                        &key sql henv hdbc &allow-other-keys)
 266   (when sql
 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)))))
 276
 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))
 282
 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
 288           when data-ptr
 289             do (uffi:free-foreign-object data-ptr)
 290           when out-len-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)))
 294
 295 (defmethod db-open-query ((database odbc-db) query-expression
 296                           &key arglen col-positions result-types width
 297                           &allow-other-keys)
 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))))
 302
 303 (defmethod db-open-query ((query odbc-query) query-expression
 304                           &key arglen col-positions result-types width
 305                           &allow-other-keys)
 306   (%db-execute query query-expression)
 307   (%initialize-query query arglen col-positions :result-types result-types
 308                      :width width))
 309
 310 (defmethod db-fetch-query-results ((database odbc-db) &optional count)
 311   (db-fetch-query-results (db-query-object database) count))
 312
 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)
 317         query
 318       (let* ((rows-fetched 0)
 319              (rows
 320               (loop for i from 0
 321                   until (or (and count (= i count))
 322                             (= (%sql-fetch hstmt) odbc::$SQL_NO_DATA_FOUND))
 323                   collect
 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
 331                         collect
 332                           (progn
 333                             (incf rows-fetched)
 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))
 337                                    nil)
 338                                   (t
 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)))))
 342
 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)
 346     (unwind-protect
 347       (progn
 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
 351             (values
 352              (db-fetch-query-results free-query nil)
 353              (map 'list #'identity (column-names free-query)))
 354           (values
 355            (result-rows-count (hstmt free-query))
 356            nil)))
 357       (db-close-query free-query)
 358       )))
 359
 360 (defmethod %db-execute ((database odbc-db) sql-expression &key &allow-other-keys)
 361   (%db-execute (get-free-query database) sql-expression))
 362
 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)
 369       query)))
 370
 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)))
 380                                               queries)))
 381                  (when inactive-query
 382                    (with-slots (column-count column-names column-c-types
 383                                 width hstmt
 384                                 column-sql-types column-data-ptrs
 385                                 column-out-len-ptrs column-precisions
 386                                 column-scales column-nullables-p)
 387                        inactive-query
 388                      (setf column-count 0
 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))
 400                  inactive-query)))
 401         (let ((new-query (make-instance 'odbc-query
 402                                         :database database
 403                                         ;;(clone-database database)
 404                                         :active-p t)))
 405           (push new-query queries)
 406           new-query))))
 407
 408 (defmethod db-execute-command ((database odbc-db) sql-string)
 409   (db-execute-command (get-free-query database) sql-string))
 410
 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)))
 415       (unwind-protect
 416           (%sql-exec-direct sql-string hstmt henv hdbc)
 417         (db-close-query query)))))
 418
 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))))
 423
 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)
 429       query
 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)))))
 452       (if col-positions
 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))))
 458
 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)
 463             (cond
 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 #.odbc::$SQL_DECIMAL) :double))
 478                        T))
 479
 480                  (t t)))
 481               (t t)))))
 482   query)
 483
 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)
 490           (drop-p
 491            (%free-statement hstmt :drop)
 492            ;; dont free with uffi/ this is a double free and crashes everything
 493            ;; (uffi:free-foreign-object hstmt)
 494            (setf hstmt nil))
 495           (t
 496            (%free-statement hstmt :unbind)
 497            (%free-statement hstmt :reset)
 498            (%free-statement hstmt :close)))
 499     (setf (query-active-p query) nil)
 500     (when drop-p
 501       (clsql-sys:without-interrupts
 502         (with-slots (queries) database
 503           (setf queries (remove query queries))))))
 504   query)
 505
 506 (defmethod %read-query-data ((database odbc-db) ignore-columns)
 507   (%read-query-data (db-query-object database) ignore-columns))
 508
 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)
 513       query
 514     (unless (= (odbc::SQLFetch hstmt) odbc::$SQL_NO_DATA_FOUND)
 515       (values
 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
 519            collect
 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)
 526                                  sql-type
 527                                  (aref column-out-len-ptrs col-nr)
 528                                  result-type))
 529                      ((zerop (get-cast-long (aref column-out-len-ptrs col-nr)))
 530                       *null*)
 531                      (t
 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)
 537                                            result-type)))))
 538        t))))
 539
 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))
 542
 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))
 546   (unwind-protect
 547     (progn
 548       (%initialize-query query nil nil :result-types result-types)
 549       ;; the main loop
 550       (loop for data = (%read-query-data query nil)
 551             while data
 552             do (apply function data)))
 553     ;; dispose of memory and set query inactive or get rid of it
 554     (db-close-query query)))
 555
 556 (defun db-map-bind-query (query type function
 557                           &rest parameters)
 558   (declare (ignore type)) ; preliminary. Do a type coersion here
 559   (unwind-protect
 560     (progn
 561       (apply #'%db-bind-execute query parameters)
 562       ;; the main loop
 563       (loop with data
 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)))
 568
 569 ;; does not always return exactly a lisp type...
 570 (defun sql-to-lisp-type (sql-type)
 571   (ecase 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)
 587     ))
 588
 589 ;; prepared queries
 590
 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))))
 599
 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
 604   ;; support it.
 605   (unless (string-equal sql "insert" :end1 6)
 606     (error 'clsql:sql-database-error
 607            (format nil
 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))
 617   query)
 618
 619
 620 (defun %db-bind-execute (query &rest parameters)
 621   "Only used from db-map-bind-query
 622     parameters are released in %reset-query
 623   "
 624   (with-slots (hstmt parameter-data-ptrs) query
 625     (loop for parameter in parameters
 626           with data-ptr and size and parameter-string
 627           do
 628           (setf parameter-string
 629                 (if (stringp parameter)
 630                     parameter
 631                     (write-to-string parameter))
 632                 size (length parameter-string)
 633                 data-ptr
 634                 (uffi:allocate-foreign-string (1+ size)))
 635           (vector-push-extend data-ptr parameter-data-ptrs)
 636           (%sql-bind-parameter
 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!
 641            ;; scale
 642            0 ;; should be calculated for odbc::$SQL_DECIMAL,
 643            ;;$SQL_NUMERIC and odbc::$SQL_TIMESTAMP
 644            data-ptr ;; = rgbValue
 645            0
 646            ;; *pcbValue;
 647            ;; change this for output and binary input! (see 3-32)
 648            +null-ptr+)
 649           (%put-str data-ptr parameter-string size))
 650         (%sql-execute hstmt)))
 651
 652
 653 (defun %db-reset-query (query)
 654   "Only used from db-map-bind-query
 655     parameters are allocated in %db-bind-execute
 656   "
 657   (with-slots (hstmt parameter-data-ptrs) query
 658     (prog1
 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))))
 666
 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)))))
 674
 675 ;; database inquiery functions
 676
 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)))
 681
 682 ;; should translate info-type integers to keywords in order to make this
 683 ;; more readable?
 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)))))
 689
 690 (defmethod get-odbc-info ((query odbc-query) info-type)
 691   (get-odbc-info (odbc::query-database query) info-type))
 692
 693 ;; driver inquiry
 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)))
 699     (unwind-protect
 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))))