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