1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: Mid-level (DBI) interface for CLSQL ODBC backend
7 ;;;; Author: Kevin M. Rosenberg
8 ;;;; Create: April 2004
10 ;;;; $Id: odbc-sql.lisp 8983 2004-04-12 21:16:48Z kevin $
12 ;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
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 ;;;; *************************************************************************
19 (in-package #:cl-user)
21 (defpackage #:odbc-dbi
33 #:list-all-database-tables
34 #:list-all-table-columns
44 #:*default-odbc-external-format*
47 (:documentation "This is the mid-level interface ODBC."))
49 (in-package #:odbc-dbi)
54 (;; any reason to have more than one henv?
55 (width :initform +max-precision+ :accessor db-width)
56 (hstmt :initform nil :accessor db-hstmt)
57 (henv :initform nil :allocation :class :initarg :henv :accessor henv)
58 (hdbc :initform nil :initarg :hdbc :accessor hdbc)
59 ;; info returned from SQLGetInfo
60 (info :initform (make-hash-table) :reader db-info)
61 (type :initform nil :initarg :db-type :reader db-type)
62 (connected-p :initform nil :accessor db-connected-p)
64 (count :initform 0 :initarg :count :accessor db-count)
66 (total-count :initform 0 :allocation :class :accessor db-total-count)
67 ;; the use of this slot is deprecated; it will be removed when dtf works without it.
68 (query :initform nil :accessor db-query-object)
69 ;; resource of (active and inactive) query objects
70 (queries :initform () :accessor db-queries)))
72 (defclass odbc-query ()
73 ((hstmt :initform nil :initarg :hstmt :accessor hstmt) ; = cursor??
74 (width :initform +max-precision+ :accessor query-width)
75 (computed-result-types :initform nil :initarg :computed-result-types :accessor computed-result-types)
76 (column-count :initform nil :accessor column-count)
77 (column-names :initform (make-array 0 :element-type 'string :adjustable t :fill-pointer t)
78 :accessor column-names)
79 (column-c-types :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t)
80 :accessor column-c-types)
81 (column-sql-types :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t)
82 :accessor column-sql-types)
83 (column-data-ptrs :initform (make-array 0 :adjustable t :fill-pointer t)
85 (column-out-len-ptrs :initform (make-array 0 :adjustable t :fill-pointer t)
86 :accessor column-out-len-ptrs)
87 (column-precisions :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t)
88 :accessor column-precisions)
89 (column-scales :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t)
90 :accessor column-scales)
91 (column-nullables-p :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t)
92 :accessor column-nullables-p)
93 ;;(parameter-count :initform 0 :accessor parameter-count)
94 (parameter-data-ptrs :initform (make-array 0 :adjustable t :fill-pointer t)
95 :accessor parameter-ptrs)
96 ;; a query string or a query expression object
97 (sql-expression :initform nil :initarg :sql-expression :accessor sql-expression)
98 ;; database object the query is to be run against
99 (database :initarg :database :reader query-database)
100 (active-p :initform nil :initarg :active-p :accessor query-active-p))
102 "Stores query information, like SQL query string/expression and database to run
103 the query against." ))
105 ;;; AODBC Compatible interface
107 (defun connect (&key data-source-name user password (autocommit t))
108 (let ((db (make-instance 'odbc-db)))
109 (unless (henv db) ;; has class allocation!
110 (setf (henv db) (%new-environment-handle)))
111 (setf (hdbc db) (%new-db-connection-handle (henv db)))
112 (%sql-connect (hdbc db) data-source-name user password)
113 (setf (db-hstmt db) (%new-statement-handle (hdbc db)))
114 (when (/= (get-odbc-info db odbc::$SQL_TXN_CAPABLE) odbc::$SQL_TC_NONE)
116 (enable-autocommit (hdbc db))
117 (disable-autocommit (hdbc db))))
120 (defun disconnect (database)
121 (with-slots (hdbc queries) database
122 (dolist (query queries)
123 (if (query-active-p query)
124 (with-slots (hstmt) query
126 (%free-statement hstmt :drop)
128 (%free-statement (db-hstmt database) :drop)
132 (defun sql (expr &key db result-types row-count (column-names t) query
134 (declare (ignore hstmt))
137 (let ((q (db-open-query db expr :result-types result-types :width width)))
139 (values q (column-names q))
142 (multiple-value-bind (data col-names)
143 (db-query db expr :result-types result-types :width width)
146 (if (consp data) (length data) data))
148 (values data col-names))
152 (defun fetch-row (query &optional (eof-errorp t) eof-value)
153 (multiple-value-bind (row query count) (db-fetch-query-results query 1)
158 (error 'clsql-odbc-error :odbc-message "Ran out of data in fetch-row"))
164 (defun close-query (query)
165 (db-close-query query))
167 (defun list-all-database-tables (&key db hstmt)
168 (declare (ignore hstmt))
169 (let ((query (get-free-query db)))
172 (with-slots (hstmt) query
173 (unless hstmt (setf hstmt (%new-statement-handle (hdbc db))))
175 (%initialize-query query nil nil)
177 (db-fetch-query-results query)
178 (coerce (column-names query) 'list))))
179 (db-close-query query))))
181 (defun list-all-table-columns (table &key db hstmt)
182 (declare (ignore hstmt))
183 (db-describe-columns db "" "" table ""))
185 (defun rr-sql (hstmt sql-statement &key db)
186 (declare (ignore hstmt sql-statement db))
187 (warn "rr-sql not implemented."))
189 ;;; Mid-level interface
191 (defmethod db-commit ((database odbc-db))
192 (%commit (henv database) (hdbc database)))
194 (defmethod db-rollback ((database odbc-db))
195 (%rollback (henv database) (hdbc database)))
197 (defmethod db-cancel-query ((query odbc-query))
198 (with-slots (hstmt) query
200 (setf (query-active-p query) nil)))
203 (defmacro with-transaction (&body body)
205 (:henv (henv ,*default-database*) :hdbc (hdbc ,*default-database*))
208 (defmethod initialize-instance :after ((query odbc-query)
209 &key sql henv hdbc &allow-other-keys)
211 (let ((hstmt (%new-statement-handle hdbc)))
212 (%sql-exec-direct sql hstmt henv hdbc)
213 (with-slots (column-count
214 column-names column-c-types column-sql-types column-data-ptrs
215 column-out-len-ptrs column-precisions column-scales
216 column-nullables-p active-p) query
217 (setf (hstmt query) hstmt)
218 (%initialize-query query nil nil)
219 (setf active-p t)))))
221 ;; one for odbc-db is missing
222 (defmethod terminate ((query odbc-query))
223 ;;(format tb::*local-output* "~%*** terminated: ~s" query)
224 (with-slots (hstmt) query
226 ;(%free-statement hstmt :drop)
227 (uffi:free-foreign-object hstmt)) ;; ??
228 (%dispose-column-ptrs query)))
230 (defmethod %dispose-column-ptrs ((query odbc-query))
231 (with-slots (column-data-ptrs column-out-len-ptrs hstmt) query
232 (loop for data-ptr across column-data-ptrs
233 when data-ptr do (uffi:free-foreign-object data-ptr))
234 (loop for out-len-ptr across column-out-len-ptrs
235 when out-len-ptr do (uffi:free-foreign-object out-len-ptr))))
237 (defmethod db-open-query ((database odbc-db) query-expression
238 &key arglen col-positions result-types width
240 (db-open-query (get-free-query database) query-expression
241 :arglen arglen :col-positions col-positions
242 :result-types result-types
243 :width (if width width (db-width database))))
245 (defmethod db-open-query ((query odbc-query) query-expression
246 &key arglen col-positions result-types width
248 (%db-execute query query-expression)
249 (%initialize-query query arglen col-positions :result-types result-types
252 (defmethod db-fetch-query-results ((database odbc-db) &optional count)
253 (db-fetch-query-results (db-query-object database) count))
255 (defmethod db-fetch-query-results ((query odbc-query) &optional count)
256 (when (query-active-p query)
257 (with-slots (column-count column-data-ptrs column-c-types column-sql-types
258 column-out-len-ptrs column-precisions hstmt computed-result-types)
260 (let* ((rows-fetched 0)
263 until (or (and count (= i count))
264 (= (%sql-fetch hstmt) odbc::$SQL_NO_DATA_FOUND))
266 (loop for result-type across computed-result-types
267 for data-ptr across column-data-ptrs
268 for c-type across column-c-types
269 for sql-type across column-sql-types
270 for out-len-ptr across column-out-len-ptrs
271 for precision across column-precisions
272 for j from 0 ; column count is zero based in lisp
276 (cond ((< 0 precision (query-width query))
277 (read-data data-ptr c-type sql-type out-len-ptr result-type))
278 ((zerop (get-cast-long out-len-ptr))
281 (read-data-in-chunks hstmt j data-ptr c-type sql-type
282 out-len-ptr result-type))))))))
283 (values rows query rows-fetched)))))
285 (defmethod db-query ((database odbc-db) query-expression &key result-types width)
286 (let ((free-query (get-free-query database)))
287 (setf (sql-expression free-query) query-expression)
290 (%db-execute free-query query-expression)
291 (%initialize-query free-query nil nil :result-types result-types :width width)
292 (if (plusp (column-count free-query)) ;; KMR: Added check for commands that don't return columns
294 (db-fetch-query-results free-query nil)
295 (column-names free-query))
297 (result-rows-count (hstmt free-query))
299 (db-close-query free-query)
302 (defmethod %db-execute ((database odbc-db) sql-expression &key &allow-other-keys)
303 (%db-execute (get-free-query database) sql-expression))
305 (defmethod %db-execute ((query odbc-query) sql-expression &key &allow-other-keys)
306 (with-slots (henv hdbc) (odbc::query-database query)
307 (with-slots (hstmt) query
308 (unless hstmt (setf hstmt (%new-statement-handle hdbc)))
309 (setf (sql-expression query) sql-expression)
310 (%sql-exec-direct sql-expression hstmt henv hdbc)
313 ;; reuse inactive queries
314 (defmethod get-free-query ((database odbc-db))
315 "get-free-query finds or makes a nonactive query object, and then sets it to active.
316 This makes the functions db-execute-command and db-query thread safe."
317 (with-slots (queries) database
318 (or (clsql-base-sys:without-interrupts
319 (let ((inactive-query (find-if (lambda (query)
320 (not (query-active-p query)))
323 (with-slots (column-count column-names column-c-types
325 column-sql-types column-data-ptrs
326 column-out-len-ptrs column-precisions
327 column-scales column-nullables-p)
329 ;;(print column-data-ptrs tb::*local-output*)
330 ;;(%dispose-column-ptrs inactive-query)
332 width +max-precision+
333 (fill-pointer column-names) 0
334 (fill-pointer column-c-types) 0
335 (fill-pointer column-sql-types) 0
336 (fill-pointer column-data-ptrs) 0
337 (fill-pointer column-out-len-ptrs) 0
338 (fill-pointer column-precisions) 0
339 (fill-pointer column-scales) 0
340 (fill-pointer column-nullables-p) 0))
341 (setf (query-active-p inactive-query) t))
343 (let ((new-query (make-instance 'odbc-query
345 ;;(clone-database database)
347 (push new-query queries)
350 (defmethod db-execute-command ((database odbc-db) sql-string)
351 (db-execute-command (get-free-query database) sql-string))
353 (defmethod db-execute-command ((query odbc-query) sql-string)
354 (with-slots (hstmt database) query
355 (with-slots (henv hdbc) database
356 (unless hstmt (setf hstmt (%new-statement-handle hdbc)))
358 (%sql-exec-direct sql-string hstmt henv hdbc)
359 (db-close-query query)))))
361 (defmethod %initialize-query ((database odbc-db) arglen col-positions &key result-types width)
362 (%initialize-query (db-query-object database) arglen col-positions
363 :result-types result-types
364 :width (if width width (db-width database))))
366 (defmethod %initialize-query ((query odbc-query) arglen col-positions &key result-types width)
367 (with-slots (hstmt computed-result-types
368 column-count column-names column-c-types column-sql-types
369 column-data-ptrs column-out-len-ptrs column-precisions
370 column-scales column-nullables-p)
372 (setf column-count (if arglen
373 (min arglen (result-columns-count hstmt))
374 (result-columns-count hstmt)))
375 (when width (setf (query-width query) width))
376 ;;(format tb::*local-output* "~%column-count: ~d, col-positions: ~d" column-count col-positions)
377 (labels ((initialize-column (col-nr)
378 (multiple-value-bind (name sql-type precision scale nullable-p)
379 (%describe-column hstmt (1+ col-nr))
380 ;; allocate space to bind result rows to
381 (multiple-value-bind (c-type data-ptr out-len-ptr size long-p)
382 (%allocate-bindings sql-type precision)
383 (unless long-p ;; if long-p we fetch in chunks with %sql-get-data
384 (%bind-column hstmt col-nr c-type data-ptr (1+ size) out-len-ptr))
385 (vector-push-extend name column-names)
386 (vector-push-extend sql-type column-sql-types)
387 (vector-push-extend (sql-to-c-type sql-type) column-c-types)
388 (vector-push-extend precision column-precisions)
389 (vector-push-extend scale column-scales)
390 (vector-push-extend nullable-p column-nullables-p)
391 (vector-push-extend data-ptr column-data-ptrs)
392 (vector-push-extend out-len-ptr column-out-len-ptrs)))))
394 (dolist (col-nr col-positions)
395 (initialize-column col-nr))
396 (dotimes (col-nr column-count)
397 ;; get column information
398 (initialize-column col-nr))))
400 (setf computed-result-types (make-array column-count))
401 (dotimes (i column-count)
402 (setf (aref computed-result-types i)
404 ((consp result-types)
405 (nth i result-types))
406 ((eq result-types :auto)
407 (if (eq (aref column-sql-types i) odbc::$SQL_BIGINT)
409 (case (aref column-c-types i)
410 (#.odbc::$SQL_C_SLONG :int)
411 (#.odbc::$SQL_C_DOUBLE :double)
412 (#.odbc::$SQL_C_FLOAT :float)
413 (#.odbc::$SQL_C_SSHORT :short)
414 (#.odbc::$SQL_BIGINT :short)
420 (defmethod db-close-query ((query odbc-query) &key drop-p)
421 (with-slots (hstmt column-count column-names column-c-types column-sql-types
422 column-data-ptrs column-out-len-ptrs column-precisions
423 column-scales column-nullables-p) query
424 (let ((count (fill-pointer column-data-ptrs)))
425 (when (not (zerop count))
426 (dotimes (col-nr count)
427 (let ((data-ptr (aref column-data-ptrs col-nr))
428 (out-len-ptr (aref column-out-len-ptrs col-nr)))
429 (when data-ptr (uffi:free-foreign-object data-ptr)) ; we *did* allocate them
430 (when out-len-ptr (uffi:free-foreign-object out-len-ptr)))))
434 (%free-statement hstmt :drop)
437 (%free-statement hstmt :unbind)
438 (%free-statement hstmt :reset)
439 (%free-statement hstmt :close)))
440 (setf (query-active-p query) nil)))
443 (defmethod %read-query-data ((database odbc-db) ignore-columns)
444 (%read-query-data (db-query-object database) ignore-columns))
446 (defmethod %read-query-data ((query odbc-query) ignore-columns)
447 (with-slots (hstmt column-count column-c-types column-sql-types
448 column-data-ptrs column-out-len-ptrs column-precisions
449 computed-result-types)
451 (unless (= (SQLFetch hstmt) odbc::$SQL_NO_DATA_FOUND)
453 (loop for col-nr from 0 to (- column-count
454 (if (eq ignore-columns :last) 2 1))
455 for result-type across computed-result-types
457 (let ((precision (aref column-precisions col-nr))
458 (sql-type (aref column-sql-types col-nr)))
459 (cond ((or (< 0 precision (query-width query))
460 (and (zerop precision) (not (find sql-type '($SQL_C_CHAR)))))
461 (read-data (aref column-data-ptrs col-nr)
462 (aref column-c-types col-nr)
464 (aref column-out-len-ptrs col-nr)
466 ((zerop (get-cast-long (aref column-out-len-ptrs col-nr)))
469 (read-data-in-chunks hstmt col-nr
470 (aref column-data-ptrs col-nr)
471 (aref column-c-types col-nr)
472 (aref column-sql-types col-nr)
473 (aref column-out-len-ptrs col-nr)
477 (defmethod db-map-query ((database odbc-db) type function query-exp &key result-types)
478 (db-map-query (get-free-query database) type function query-exp :result-types result-types))
480 (defmethod db-map-query ((query odbc-query) type function query-exp &key result-types)
481 (declare (ignore type)) ; preliminary. Do a type coersion here
482 (%db-execute query (sql-expression query-exp))
485 (%initialize-query query nil nil :result-types result-types)
487 (loop for data = (%read-query-data query nil)
489 do (apply function data)))
490 ;; dispose of memory and set query inactive or get rid of it
491 (db-close-query query)))
493 (defmethod db-map-bind-query ((query odbc-query) type function
495 (declare (ignore type)) ; preliminary. Do a type coersion here
498 (apply #'%db-bind-execute query parameters)
501 while (setf data (%read-query-data query nil))
502 do (apply function data)))
503 ;; dispose of memory and set query inactive or get rid of it
504 (%db-reset-query query)))
506 ;; does not always return exactly a lisp type...
507 (defun sql-to-lisp-type (sql-type)
509 ((#.odbc::$SQL_CHAR #.odbc::$SQL_VARCHAR #.odbc::$SQL_LONGVARCHAR) :string)
510 ((#.odbc::$SQL_NUMERIC #.odbc::$SQL_DECIMAL #.odbc::$SQL_BIGINT) :string) ; ??
511 (#.odbc::$SQL_INTEGER :long)
512 (#.odbc::$SQL_SMALLINT :short)
513 ((#.odbc::$SQL_FLOAT #.odbc::$SQL_DOUBLE) :long)
514 (#.odbc::$SQL_REAL :long)
515 (#.odbc::$SQL_DATE 'sql-c-date)
516 (#.odbc::$SQL_TIME 'sql-c-time)
517 (#.odbc::$SQL_TIMESTAMP 'sql-c-timestamp)
518 ;;((#.odbc::$SQL_BINARY #.odbc::$SQL_VARBINARY #.odbc::$SQL_LONGVARBINARY) odbc::$SQL_C_BINARY) ; ??
519 (#.odbc::$SQL_TINYINT :short)
520 ;;(#.odbc::$SQL_BIT odbc::$SQL_C_BIT) ; ??
521 ((#.odbc::$SQL_VARBINARY #.odbc::$SQL_LONGVARBINARY) :binary)
526 (defmethod db-prepare-statement ((database odbc-db) sql
527 &key parameter-table parameter-columns)
528 (with-slots (hdbc) database
529 (let ((query (get-free-query database)))
530 (with-slots (hstmt) query
531 (unless hstmt (setf hstmt (%new-statement-handle hdbc))))
532 (db-prepare-statement query sql parameter-table parameter-columns))))
534 (defmethod db-prepare-statement ((query odbc-query) (sql string)
535 &key parameter-table parameter-columns)
536 ;; this is a workaround to get hold of the column types when the driver does not
537 ;; support SQLDescribeParam. To do: put code in here for drivers that do
539 (unless (string-equal sql "insert" :end1 6)
540 (error "Only insert expressions are supported in literal ODBC: '~a'." sql))
541 (%db-execute query (format nil "select ~{~a~^,~} from ~a where 0 = 1"
542 (or parameter-columns '("*")) parameter-table))
543 (%initialize-query query nil nil)
544 (with-slots (hstmt) query
545 (%free-statement hstmt :unbind)
546 (%free-statement hstmt :reset)
547 (setf (sql-expression query) sql)
548 (%sql-prepare hstmt sql))
552 (defmethod %db-bind-execute ((query odbc-query) &rest parameters)
553 (with-slots (hstmt parameter-data-ptrs) query
554 (loop for parameter in parameters
555 with data-ptr and size and parameter-string
557 (setf parameter-string
558 (if (stringp parameter)
560 (write-to-string parameter))
561 size (length parameter-string)
563 (uffi:allocate-foreign-string (1+ size)))
564 (vector-push-extend data-ptr parameter-data-ptrs)
566 hstmt (1- (fill-pointer parameter-data-ptrs)) odbc::$SQL_PARAM_INPUT
567 odbc::$SQL_C_CHAR ; (aref column-c-types parameter-count)
568 odbc::$SQL_CHAR ; sql-type
569 (query-width query) ;precision ; this should be the actual precision!
571 0 ;; should be calculated for odbc::$SQL_DECIMAL,
572 ;;$SQL_NUMERIC and odbc::$SQL_TIMESTAMP
573 data-ptr ;; = rgbValue
576 ;; change this for output and binary input! (see 3-32)
578 (%put-str data-ptr parameter-string size))
579 (%sql-execute hstmt)))
582 (defmethod %db-reset-query ((query odbc-query))
583 (with-slots (hstmt parameter-data-ptrs) query
585 (db-fetch-query-results query nil)
586 (%free-statement hstmt :reset) ;; but _not_ :unbind !
587 (%free-statement hstmt :close)
588 (dotimes (param-nr (fill-pointer parameter-data-ptrs))
589 (let ((data-ptr (aref parameter-data-ptrs param-nr)))
590 (when data-ptr (uffi:free-foreign-object data-ptr))))
591 (setf (fill-pointer parameter-data-ptrs) 0))))
593 (defun data-parameter-ptr (hstmt)
594 (uffi:with-foreign-object (param-ptr :pointer-void)
595 (let ((return-code (%sql-param-data hstmt param-ptr)))
596 ;;(format t "~%return-code from %sql-param-data: ~a~%" return-code)
597 (when (= return-code odbc::$SQL_NEED_DATA)
598 ;;(ffc::%pointer-to-address (%get-ptr param-ptr))
599 (uffi:deref-pointer param-ptr :pointer-void)))))
601 ;; database inquiery functions
603 (defmethod db-describe-columns ((database odbc-db)
604 table-qualifier table-owner table-name column-name)
605 (with-slots (hdbc) database
606 (%describe-columns hdbc table-qualifier table-owner table-name column-name)))
608 ;; should translate info-type integers to keywords in order to make this
610 (defmethod get-odbc-info ((database odbc-db) info-type)
611 (with-slots (hdbc info) database
612 (or (gethash info-type info)
613 (setf (gethash info-type info)
614 (%sql-get-info hdbc info-type)))))
616 (defmethod get-odbc-info ((query odbc-query) info-type)
617 (get-odbc-info (odbc::query-database query) info-type))
620 (defmethod db-data-sources ((db-type (eql :odbc)))
621 "Returns a list of (data-source description) - pairs"
622 (let ((henv (%new-environment-handle)))
624 (loop with direction = :first
625 for data-source+description
626 = (multiple-value-list (%sql-data-sources henv :direction direction))
627 while (car data-source+description)
628 collect data-source+description
629 do (setf direction :next))
630 (%sql-free-environment henv))))