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