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