;;;; Author: Kevin M. Rosenberg
;;;; Create: April 2004
;;;;
-;;;; $Id: odbc-sql.lisp 8983 2004-04-12 21:16:48Z kevin $
+;;;; $Id$
;;;;
;;;; This file, part of CLSQL, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
#:disconnect
#:end-transaction
#:fetch-row
+ #:list-all-data-sources
#:list-all-database-tables
#:list-all-table-columns
+ #:list-table-indexes
#:loop-over-results
#:prepare-sql
#:rr-sql
#:run-prepared-sql
#:set-autocommit
#:sql
-
+
#:*auto-trim-strings*
#:*default-database*
#:*default-odbc-external-format*
(in-package #:odbc-dbi)
+(defgeneric terminate (src))
+(defgeneric db-open-query (src query-expression
+ &key arglen col-positions result-types width
+ &allow-other-keys))
+(defgeneric db-fetch-query-results (src &optional count))
+(defgeneric %db-execute (src sql-expression &key &allow-other-keys))
+(defgeneric db-execute-command (src sql-string))
+
+(defgeneric %initialize-query (src arglen col-positions
+ &key result-types width))
+
+(defgeneric %read-query-data (src ignore-columns))
+(defgeneric db-map-query (src type function query-exp &key result-types))
+(defgeneric db-prepare-statement (src sql &key parameter-table
+ parameter-columns))
+(defgeneric get-odbc-info (src info-type))
+
+
;;; SQL Interface
(defclass odbc-db ()
(;; any reason to have more than one henv?
+ (width :initform +max-precision+ :accessor db-width)
+ (hstmt :initform nil :accessor db-hstmt)
(henv :initform nil :allocation :class :initarg :henv :accessor henv)
(hdbc :initform nil :initarg :hdbc :accessor hdbc)
;; info returned from SQLGetInfo
;; resource of (active and inactive) query objects
(queries :initform () :accessor db-queries)))
-(defclass query ()
+(defclass odbc-query ()
((hstmt :initform nil :initarg :hstmt :accessor hstmt) ; = cursor??
+ (width :initform +max-precision+ :accessor query-width)
+ (computed-result-types :initform nil :initarg :computed-result-types :accessor computed-result-types)
(column-count :initform nil :accessor column-count)
(column-names :initform (make-array 0 :element-type 'string :adjustable t :fill-pointer t)
- :accessor column-names)
+ :accessor column-names)
(column-c-types :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t)
- :accessor column-c-types)
+ :accessor column-c-types)
(column-sql-types :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t)
- :accessor column-sql-types)
+ :accessor column-sql-types)
(column-data-ptrs :initform (make-array 0 :adjustable t :fill-pointer t)
- :accessor data-ptrs)
+ :accessor data-ptrs)
(column-out-len-ptrs :initform (make-array 0 :adjustable t :fill-pointer t)
- :accessor column-out-len-ptrs)
+ :accessor column-out-len-ptrs)
(column-precisions :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t)
- :accessor column-precisions)
+ :accessor column-precisions)
(column-scales :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t)
- :accessor column-scales)
+ :accessor column-scales)
(column-nullables-p :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t)
- :accessor column-nullables-p)
+ :accessor column-nullables-p)
;;(parameter-count :initform 0 :accessor parameter-count)
(parameter-data-ptrs :initform (make-array 0 :adjustable t :fill-pointer t)
- :accessor parameter-ptrs)
+ :accessor parameter-ptrs)
;; a query string or a query expression object
(sql-expression :initform nil :initarg :sql-expression :accessor sql-expression)
;; database object the query is to be run against
"Stores query information, like SQL query string/expression and database to run
the query against." ))
-(defun connect (&key data-source-name user password (autocommit t))
+;;; AODBC Compatible interface
+
+(defun connect (&key data-source-name user password connection-string completion window-handle (autocommit t))
(let ((db (make-instance 'odbc-db)))
(unless (henv db) ;; has class allocation!
(setf (henv db) (%new-environment-handle)))
(setf (hdbc db) (%new-db-connection-handle (henv db)))
- (%sql-connect (hdbc db) data-source-name user password)
- ;; FIXME: Check if connected
+ (if connection-string
+ (%sql-driver-connect (hdbc db)
+ connection-string
+ (ecase completion
+ (:no-prompt odbc::$SQL_DRIVER_NOPROMPT)
+ (:complete odbc::$SQL_DRIVER_COMPLETE)
+ (:prompt odbc::$SQL_DRIVER_PROMPT)
+ (:complete-required odbc::$SQL_DRIVER_COMPLETE_REQUIRED))
+ window-handle)
+ (%sql-connect (hdbc db) data-source-name user password))
+ #+ignore (setf (db-hstmt db) (%new-statement-handle (hdbc db)))
(when (/= (get-odbc-info db odbc::$SQL_TXN_CAPABLE) odbc::$SQL_TC_NONE)
(if autocommit
- (enable-autocommit (hdbc db))
- (disable-autocommit (hdbc db))))
+ (enable-autocommit (hdbc db))
+ (disable-autocommit (hdbc db))))
db))
(defun disconnect (database)
(with-slots (hdbc queries) database
(dolist (query queries)
(if (query-active-p query)
- (with-slots (hstmt) query
- (when hstmt
- (%free-statement hstmt :drop)
- (setf hstmt nil)))))
+ (with-slots (hstmt) query
+ (when hstmt
+ (%free-statement hstmt :drop)
+ (setf hstmt nil)))))
+ (when (db-hstmt database)
+ (%free-statement (db-hstmt database) :drop))
(%disconnect hdbc)))
-(defun sql (expr &key db result-types row-count column-names)
- (warn "Not implemented."))
-
-(defun close-query (result-set)
- (warn "Not implemented."))
+(defun sql (expr &key db result-types row-count (column-names t) query
+ hstmt width)
+ (declare (ignore hstmt))
+ (cond
+ (query
+ (let ((q (db-open-query db expr :result-types result-types :width width)))
+ (if column-names
+ (values q (column-names q))
+ q)))
+ (t
+ (multiple-value-bind (data col-names)
+ (db-query db expr :result-types result-types :width width)
+ (cond
+ (row-count
+ (if (consp data) (length data) data))
+ (column-names
+ (values data col-names))
+ (t
+ data))))))
+
+(defun fetch-row (query &optional (eof-errorp t) eof-value)
+ (multiple-value-bind (row query count) (db-fetch-query-results query 1)
+ (cond
+ ((zerop count)
+ (close-query query)
+ (when eof-errorp
+ (error 'clsql:sql-database-data-error
+ :message "ODBC: Ran out of data in fetch-row"))
+ eof-value)
+ (t
+ (car row)))))
+
+
+(defun close-query (query)
+ (db-close-query query))
+
+(defun list-all-database-tables (&key db hstmt)
+ (declare (ignore hstmt))
+ (let ((query (get-free-query db)))
+ (unwind-protect
+ (progn
+ (with-slots (hstmt) query
+ (unless hstmt (setf hstmt (%new-statement-handle (hdbc db))))
+ (%list-tables hstmt)
+ (%initialize-query query nil nil)
+ (values
+ (db-fetch-query-results query)
+ (coerce (column-names query) 'list))))
+ (db-close-query query))))
+
+(defun list-table-indexes (table &key db unique hstmt)
+ (declare (ignore hstmt))
+ (let ((query (get-free-query db)))
+ (unwind-protect
+ (progn
+ (with-slots (hstmt) query
+ (unless hstmt
+ (setf hstmt (%new-statement-handle (hdbc db))))
+ (%table-statistics table hstmt :unique unique)
+ (%initialize-query query nil nil)
+ (values
+ (db-fetch-query-results query)
+ (coerce (column-names query) 'list))))
+ (db-close-query query))))
+
+(defun list-all-table-columns (table &key db hstmt)
+ (declare (ignore hstmt))
+ (db-describe-columns db nil nil table nil)) ;; use nil rather than "" for unspecified values
+
+(defun list-all-data-sources ()
+ (let ((db (make-instance 'odbc-db)))
+ (unless (henv db) ;; has class allocation!
+ (setf (henv db) (%new-environment-handle)))
+ (%list-data-sources (henv db))))
-(defun fetch-row (result-set error-eof eof-value)
- (warn "Not implemented."))
+(defun rr-sql (hstmt sql-statement &key db)
+ (declare (ignore hstmt sql-statement db))
+ (warn "rr-sql not implemented."))
-(defclass odbc-query (query)
- ((hstmt :initform nil :initarg :hstmt :accessor hstmt) ; = cursor??
- (column-count :initform nil :accessor column-count)
- (column-names :initform (make-array 0 :element-type 'string :adjustable t :fill-pointer t)
- :accessor column-names)
- (column-c-types :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t)
- :accessor column-c-types)
- (column-sql-types :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t)
- :accessor column-sql-types)
- (column-data-ptrs :initform (make-array 0 :adjustable t :fill-pointer t)
- :accessor data-ptrs)
- (column-out-len-ptrs :initform (make-array 0 :adjustable t :fill-pointer t)
- :accessor column-out-len-ptrs)
- (column-precisions :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t)
- :accessor column-precisions)
- (column-scales :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t)
- :accessor column-scales)
- (column-nullables-p :initform (make-array 0 :element-type 'fixnum :adjustable t :fill-pointer t)
- :accessor column-nullables-p)
- ;;(parameter-count :initform 0 :accessor parameter-count)
- (parameter-data-ptrs :initform (make-array 0 :adjustable t :fill-pointer t)
- :accessor parameter-ptrs)))
+;;; Mid-level interface
-(defmethod db-commit ((database odbc-db))
+(defun db-commit (database)
(%commit (henv database) (hdbc database)))
-(defmethod db-rollback ((database odbc-db))
+(defun db-rollback (database)
(%rollback (henv database) (hdbc database)))
-(defmethod db-cancel-query ((query odbc-query))
+(defun db-cancel-query (query)
(with-slots (hstmt) query
(%sql-cancel hstmt)
(setf (query-active-p query) nil)))
(:henv (henv ,*default-database*) :hdbc (hdbc ,*default-database*))
,@body))
-(defmethod initialize-instance :after ((query odbc-query)
+(defmethod initialize-instance :after ((query odbc-query)
&key sql henv hdbc &allow-other-keys)
(when sql
(let ((hstmt (%new-statement-handle hdbc)))
(%sql-exec-direct sql hstmt henv hdbc)
- (with-slots (column-count
- column-names column-c-types column-sql-types column-data-ptrs
+ (with-slots (column-count
+ column-names column-c-types column-sql-types column-data-ptrs
column-out-len-ptrs column-precisions column-scales
column-nullables-p active-p) query
(setf (hstmt query) hstmt)
- (%initialize-query query)
+ (%initialize-query query nil nil)
(setf active-p t)))))
;; one for odbc-db is missing
(uffi:free-foreign-object hstmt)) ;; ??
(%dispose-column-ptrs query)))
-(defmethod %dispose-column-ptrs ((query odbc-query))
+(defun %dispose-column-ptrs (query)
(with-slots (column-data-ptrs column-out-len-ptrs hstmt) query
(loop for data-ptr across column-data-ptrs
when data-ptr do (uffi:free-foreign-object data-ptr))
when out-len-ptr do (uffi:free-foreign-object out-len-ptr))))
(defmethod db-open-query ((database odbc-db) query-expression
- &key arglen col-positions
- &allow-other-keys)
+ &key arglen col-positions result-types width
+ &allow-other-keys)
(db-open-query (get-free-query database) query-expression
- :arglen arglen :col-positions col-positions))
+ :arglen arglen :col-positions col-positions
+ :result-types result-types
+ :width (if width width (db-width database))))
(defmethod db-open-query ((query odbc-query) query-expression
- &key arglen col-positions &allow-other-keys)
+ &key arglen col-positions result-types width
+ &allow-other-keys)
(%db-execute query query-expression)
- (%initialize-query query arglen col-positions))
+ (%initialize-query query arglen col-positions :result-types result-types
+ :width width))
-(defmethod db-fetch-query-results ((database odbc-db) &optional count flatp)
- (db-fetch-query-results (db-query-object database) count flatp))
+(defmethod db-fetch-query-results ((database odbc-db) &optional count)
+ (db-fetch-query-results (db-query-object database) count))
-(defmethod db-fetch-query-results ((query odbc-query) &optional count flatp)
+(defmethod db-fetch-query-results ((query odbc-query) &optional count)
(when (query-active-p query)
- (let (#+ignore(no-data nil))
- (with-slots (column-count column-data-ptrs column-c-types column-sql-types
- column-out-len-ptrs column-precisions hstmt)
- query
- (values
- (cond (flatp
- (when (> column-count 1)
- (error "If more than one column is to be fetched, flatp has to be nil."))
- (let ((data-ptr (aref column-data-ptrs 0))
- (c-type (aref column-c-types 0))
- (sql-type (aref column-sql-types 0))
- (out-len-ptr (aref column-out-len-ptrs 0))
- (precision (aref column-precisions 0)))
- (loop for i from 0
- until (or (and count (= i count))
- ;;(setf no-data ;; not used???
- (= (%sql-fetch hstmt) odbc::$SQL_NO_DATA_FOUND))
+ (with-slots (column-count column-data-ptrs column-c-types column-sql-types
+ column-out-len-ptrs column-precisions hstmt computed-result-types)
+ query
+ (let* ((rows-fetched 0)
+ (rows
+ (loop for i from 0
+ until (or (and count (= i count))
+ (= (%sql-fetch hstmt) odbc::$SQL_NO_DATA_FOUND))
+ collect
+ (loop for result-type across computed-result-types
+ for data-ptr across column-data-ptrs
+ for c-type across column-c-types
+ for sql-type across column-sql-types
+ for out-len-ptr across column-out-len-ptrs
+ for precision across column-precisions
+ for j from 0 ; column count is zero based in lisp
collect
- (cond ((< 0 precision +max-precision+)
- (read-data data-ptr c-type sql-type out-len-ptr nil))
- ((zerop (get-cast-long out-len-ptr))
- nil)
- (t
- (read-data-in-chunks hstmt 0 data-ptr c-type sql-type
- out-len-ptr nil)))
- #+ignore
- (if (< 0 precision +max-precision+) ;(and precision (< precision +max-precision+))
- (read-data data-ptr c-type sql-type out-len-ptr nil)
- (read-data-in-chunks hstmt 0 data-ptr c-type sql-type
- out-len-ptr nil)))))
- (t
- (loop for i from 0
- until (or (and count (= i count))
- (= (%sql-fetch hstmt) odbc::$SQL_NO_DATA_FOUND))
- collect
- (loop for data-ptr across column-data-ptrs
- for c-type across column-c-types
- for sql-type across column-sql-types
- for out-len-ptr across column-out-len-ptrs
- for precision across column-precisions
- for j from 0 ; column count is zero based in lisp
- collect
- (cond ((< 0 precision +max-precision+)
- (read-data data-ptr c-type sql-type out-len-ptr nil))
+ (progn
+ (incf rows-fetched)
+ (cond ((< 0 precision (query-width query))
+ (read-data data-ptr c-type sql-type out-len-ptr result-type))
((zerop (get-cast-long out-len-ptr))
- nil)
+ nil)
(t
(read-data-in-chunks hstmt j data-ptr c-type sql-type
- out-len-ptr nil)))))))
- query)))))
-
-#+lispworks
-(defmacro without-interrupts (&body body)
- `(mp:without-preemption ,@body))
-
-#+allegro
-(defmacro without-interrupts (&body body)
- `(mp:without-scheduling ,@body))
-
-#+cormanlisp
-(defmacro without-interrupts (&body body)
- `(progn ,@body))
-
-#+pcl
-(defmacro without-interrupts (&body body)
- `(pcl::without-interrupts ,@body))
-
-(defmethod db-query ((database odbc-db) query-expression &optional flatp)
- (let ((free-query
- ;; make it thread safe
- (get-free-query database)))
- ;;(format tb::*local-output* "~%new query: ~s" free-query)
+ out-len-ptr result-type))))))))
+ (values rows query rows-fetched)))))
+
+(defun db-query (database query-expression &key result-types width)
+ (let ((free-query (get-free-query database)))
(setf (sql-expression free-query) query-expression)
(unwind-protect
(progn
(%db-execute free-query query-expression)
- (%initialize-query free-query)
- (values
- (db-fetch-query-results free-query nil flatp)
- ;; LMH return the column names as well
- (column-names free-query)))
+ (%initialize-query free-query nil nil :result-types result-types :width width)
+ (if (plusp (column-count free-query)) ;; KMR: Added check for commands that don't return columns
+ (values
+ (db-fetch-query-results free-query nil)
+ (map 'list #'identity (column-names free-query)))
+ (values
+ (result-rows-count (hstmt free-query))
+ nil)))
(db-close-query free-query)
- ;;(format tb::*local-output* "~%query closed: ~s" free-query)
)))
(defmethod %db-execute ((database odbc-db) sql-expression &key &allow-other-keys)
(%db-execute (get-free-query database) sql-expression))
-;; C. Stacy's idea
(defmethod %db-execute ((query odbc-query) sql-expression &key &allow-other-keys)
- ;; cstacy
- (when *trace-sql*
- (format (if (streamp *trace-sql*) *trace-sql* *trace-output*)
- "~&~A;~%" sql-expression))
(with-slots (henv hdbc) (odbc::query-database query)
(with-slots (hstmt) query
- (unless hstmt (setf hstmt (%new-statement-handle hdbc)))
- ;;(print (list :new hstmt) tb::*local-output*)
+ (unless hstmt (setf hstmt (%new-statement-handle hdbc)))
(setf (sql-expression query) sql-expression)
(%sql-exec-direct sql-expression hstmt henv hdbc)
query)))
;; reuse inactive queries
-(defmethod get-free-query ((database odbc-db))
+(defun get-free-query (database)
"get-free-query finds or makes a nonactive query object, and then sets it to active.
This makes the functions db-execute-command and db-query thread safe."
- (with-slots (queries) database
- (or (without-interrupts ;; not context switch allowed here
+ (with-slots (queries hdbc) database
+ (or (clsql-sys:without-interrupts
(let ((inactive-query (find-if (lambda (query)
(not (query-active-p query)))
queries)))
- (when inactive-query
- (with-slots (column-count column-names column-c-types
- column-sql-types column-data-ptrs
- column-out-len-ptrs column-precisions
- column-scales column-nullables-p)
+ (when inactive-query
+ (with-slots (column-count column-names column-c-types
+ width hstmt
+ column-sql-types column-data-ptrs
+ column-out-len-ptrs column-precisions
+ column-scales column-nullables-p)
inactive-query
;;(print column-data-ptrs tb::*local-output*)
;;(%dispose-column-ptrs inactive-query)
(setf column-count 0
+ width +max-precision+
+ ;; KMR hstmt (%new-statement-handle hdbc)
(fill-pointer column-names) 0
(fill-pointer column-c-types) 0
(fill-pointer column-sql-types) 0
(db-execute-command (get-free-query database) sql-string))
(defmethod db-execute-command ((query odbc-query) sql-string)
- ;; cstacy
- (when *trace-sql*
- (format (if (streamp *trace-sql*) *trace-sql* *trace-output*)
- "~&~A;~%" sql-string))
(with-slots (hstmt database) query
(with-slots (henv hdbc) database
- (unless hstmt (setf hstmt (%new-statement-handle hdbc)))
- (unwind-protect
+ (unless hstmt (setf hstmt (%new-statement-handle hdbc)))
+ (unwind-protect
(%sql-exec-direct sql-string hstmt henv hdbc)
(db-close-query query)))))
-(defmethod %initialize-query ((database odbc-db) &optional arglen col-positions)
- (%initialize-query (db-query-object database) arglen col-positions))
+(defmethod %initialize-query ((database odbc-db) arglen col-positions &key result-types width)
+ (%initialize-query (db-query-object database) arglen col-positions
+ :result-types result-types
+ :width (if width width (db-width database))))
-(defmethod %initialize-query ((query odbc-query) &optional arglen col-positions)
- (with-slots (hstmt
+(defmethod %initialize-query ((query odbc-query) arglen col-positions &key result-types width)
+ (with-slots (hstmt computed-result-types
column-count column-names column-c-types column-sql-types
column-data-ptrs column-out-len-ptrs column-precisions
- column-scales column-nullables-p)
- query
+ column-scales column-nullables-p)
+ query
(setf column-count (if arglen
(min arglen (result-columns-count hstmt))
(result-columns-count hstmt)))
+ (when width (setf (query-width query) width))
;;(format tb::*local-output* "~%column-count: ~d, col-positions: ~d" column-count col-positions)
(labels ((initialize-column (col-nr)
(multiple-value-bind (name sql-type precision scale nullable-p)
;; allocate space to bind result rows to
(multiple-value-bind (c-type data-ptr out-len-ptr size long-p)
(%allocate-bindings sql-type precision)
- (unless long-p ;; if long-p we fetch in chunks with %sql-get-data
+ (if long-p ;; if long-p we fetch in chunks with %sql-get-data but must ensure that out_len_ptr is non zero
+ (setf (uffi:deref-pointer out-len-ptr #.odbc::$ODBC-LONG-TYPE) #.odbc::$SQL_NO_TOTAL)
(%bind-column hstmt col-nr c-type data-ptr (1+ size) out-len-ptr))
- (vector-push-extend name column-names)
+ (vector-push-extend name column-names)
(vector-push-extend sql-type column-sql-types)
(vector-push-extend (sql-to-c-type sql-type) column-c-types)
(vector-push-extend precision column-precisions)
(initialize-column col-nr))
(dotimes (col-nr column-count)
;; get column information
- (initialize-column col-nr)))))
+ (initialize-column col-nr))))
+
+ (setf computed-result-types (make-array column-count))
+ (dotimes (i column-count)
+ (setf (aref computed-result-types i)
+ (cond
+ ((consp result-types)
+ (nth i result-types))
+ ((eq result-types :auto)
+ (if (eq (aref column-sql-types i) odbc::$SQL_BIGINT)
+ :number
+ (case (aref column-c-types i)
+ (#.odbc::$SQL_C_SLONG :int)
+ (#.odbc::$SQL_C_DOUBLE :double)
+ (#.odbc::$SQL_C_FLOAT :float)
+ (#.odbc::$SQL_C_SSHORT :short)
+ (#.odbc::$SQL_C_STINYINT :short)
+ (#.odbc::$SQL_BIGINT :short)
+ (t t))))
+ (t
+ t)))))
query)
-(defmethod db-close-query ((query odbc-query) &key drop-p)
+(defun db-close-query (query &key drop-p)
(with-slots (hstmt column-count column-names column-c-types column-sql-types
column-data-ptrs column-out-len-ptrs column-precisions
column-scales column-nullables-p) query
(dotimes (col-nr count)
(let ((data-ptr (aref column-data-ptrs col-nr))
(out-len-ptr (aref column-out-len-ptrs col-nr)))
- (when data-ptr (uffi:free-foreign-object data-ptr)) ; we *did* allocate them
- (when out-len-ptr (uffi:free-foreign-object out-len-ptr)))))
+ (declare (ignorable data-ptr out-len-ptr))
+ ;; free-statment :unbind frees these
+ #+ignore (when data-ptr (uffi:free-foreign-object data-ptr))
+ #+ignore (when out-len-ptr (uffi:free-foreign-object out-len-ptr)))))
(cond ((null hstmt)
nil)
(drop-p
(defmethod %read-query-data ((query odbc-query) ignore-columns)
(with-slots (hstmt column-count column-c-types column-sql-types
- column-data-ptrs column-out-len-ptrs column-precisions)
- query
- (unless (= (SQLFetch hstmt) odbc::$SQL_NO_DATA_FOUND)
+ column-data-ptrs column-out-len-ptrs column-precisions
+ computed-result-types)
+ query
+ (unless (= (odbc::SQLFetch hstmt) odbc::$SQL_NO_DATA_FOUND)
(values
- (loop for col-nr from 0 to (- column-count
+ (loop for col-nr from 0 to (- column-count
(if (eq ignore-columns :last) 2 1))
- collect
+ for result-type across computed-result-types
+ collect
(let ((precision (aref column-precisions col-nr))
(sql-type (aref column-sql-types col-nr)))
- (cond ((or (< 0 precision +max-precision+)
+ (cond ((or (< 0 precision (query-width query))
(and (zerop precision) (not (find sql-type '($SQL_C_CHAR)))))
- (read-data (aref column-data-ptrs col-nr)
+ (read-data (aref column-data-ptrs col-nr)
(aref column-c-types col-nr)
sql-type
(aref column-out-len-ptrs col-nr)
- nil))
+ result-type))
((zerop (get-cast-long (aref column-out-len-ptrs col-nr)))
*null*)
(t
(read-data-in-chunks hstmt col-nr
- (aref column-data-ptrs col-nr)
+ (aref column-data-ptrs col-nr)
(aref column-c-types col-nr)
(aref column-sql-types col-nr)
(aref column-out-len-ptrs col-nr)
- nil)))))
+ result-type)))))
t))))
-(defmethod db-map-query ((database odbc-db) type function query-exp)
- (db-map-query (get-free-query database) type function query-exp))
+(defmethod db-map-query ((database odbc-db) type function query-exp &key result-types)
+ (db-map-query (get-free-query database) type function query-exp :result-types result-types))
-(defmethod db-map-query ((query odbc-query) type function query-exp)
+(defmethod db-map-query ((query odbc-query) type function query-exp &key result-types)
(declare (ignore type)) ; preliminary. Do a type coersion here
(%db-execute query (sql-expression query-exp))
(unwind-protect
(progn
- (%initialize-query query)
+ (%initialize-query query nil nil :result-types result-types)
;; the main loop
(loop for data = (%read-query-data query nil)
while data
;; dispose of memory and set query inactive or get rid of it
(db-close-query query)))
-(defmethod db-map-bind-query ((query odbc-query) type function
- &rest parameters)
+(defun db-map-bind-query (query type function
+ &rest parameters)
(declare (ignore type)) ; preliminary. Do a type coersion here
(unwind-protect
(progn
(ecase sql-type
((#.odbc::$SQL_CHAR #.odbc::$SQL_VARCHAR #.odbc::$SQL_LONGVARCHAR) :string)
((#.odbc::$SQL_NUMERIC #.odbc::$SQL_DECIMAL #.odbc::$SQL_BIGINT) :string) ; ??
- (#.odbc::$SQL_INTEGER :long)
+ (#.odbc::$SQL_INTEGER #.odbc::$ODBC-LONG-TYPE)
(#.odbc::$SQL_SMALLINT :short)
- ((#.odbc::$SQL_FLOAT #.odbc::$SQL_DOUBLE) :long)
- (#.odbc::$SQL_REAL :long)
- (#.odbc::$SQL_DATE 'sql-c-date)
- (#.odbc::$SQL_TIME 'sql-c-time)
- (#.odbc::$SQL_TIMESTAMP 'sql-c-timestamp)
+ ((#.odbc::$SQL_FLOAT #.odbc::$SQL_DOUBLE) #.odbc::$ODBC-LONG-TYPE)
+ (#.odbc::$SQL_REAL #.odbc::$ODBC-LONG-TYPE)
+ ((#.odbc::$SQL_DATE #.odbc::$SQL_TYPE_DATE) 'sql-c-date)
+ ((#.odbc::$SQL_TIME #.odbc::$SQL_TYPE_TIME) 'sql-c-time)
+ ((#.odbc::$SQL_TIMESTAMP #.odbc::$SQL_TYPE_TIMESTAMP) 'sql-c-timestamp)
;;((#.odbc::$SQL_BINARY #.odbc::$SQL_VARBINARY #.odbc::$SQL_LONGVARBINARY) odbc::$SQL_C_BINARY) ; ??
(#.odbc::$SQL_TINYINT :short)
;;(#.odbc::$SQL_BIT odbc::$SQL_C_BIT) ; ??
(defmethod db-prepare-statement ((database odbc-db) sql
&key parameter-table parameter-columns)
(with-slots (hdbc) database
- (let ((query (get-free-query database)))
+ (let ((query (get-free-query database)))
(with-slots (hstmt) query
(unless hstmt (setf hstmt (%new-statement-handle hdbc))))
(db-prepare-statement query sql parameter-table parameter-columns))))
;; support SQLDescribeParam. To do: put code in here for drivers that do
;; support it.
(unless (string-equal sql "insert" :end1 6)
- (error "Only insert expressions are supported in literal ODBC: '~a'." sql))
+ (error 'clsql:sql-database-error
+ (format nil
+ "Only insert expressions are supported in literal ODBC: '~a'." sql)))
(%db-execute query (format nil "select ~{~a~^,~} from ~a where 0 = 1"
(or parameter-columns '("*")) parameter-table))
- (%initialize-query query)
+ (%initialize-query query nil nil)
(with-slots (hstmt) query
(%free-statement hstmt :unbind)
(%free-statement hstmt :reset)
query)
-(defmethod %db-bind-execute ((query odbc-query) &rest parameters)
+(defun %db-bind-execute (query &rest parameters)
(with-slots (hstmt parameter-data-ptrs) query
(loop for parameter in parameters
with data-ptr and size and parameter-string
parameter
(write-to-string parameter))
size (length parameter-string)
- data-ptr
+ data-ptr
(uffi:allocate-foreign-string (1+ size)))
(vector-push-extend data-ptr parameter-data-ptrs)
- (%sql-bind-parameter
+ (%sql-bind-parameter
hstmt (1- (fill-pointer parameter-data-ptrs)) odbc::$SQL_PARAM_INPUT
odbc::$SQL_C_CHAR ; (aref column-c-types parameter-count)
odbc::$SQL_CHAR ; sql-type
- +max-precision+ ;precision ; this should be the actual precision!
+ (query-width query) ;precision ; this should be the actual precision!
;; scale
0 ;; should be calculated for odbc::$SQL_DECIMAL,
;;$SQL_NUMERIC and odbc::$SQL_TIMESTAMP
0
;; *pcbValue;
;; change this for output and binary input! (see 3-32)
- (%null-ptr))
+ +null-ptr+)
(%put-str data-ptr parameter-string size))
(%sql-execute hstmt)))
-(defmethod %db-reset-query ((query odbc-query))
+(defun %db-reset-query (query)
(with-slots (hstmt parameter-data-ptrs) query
(prog1
- (db-fetch-query-results query nil ; flatp
- nil)
+ (db-fetch-query-results query nil)
(%free-statement hstmt :reset) ;; but _not_ :unbind !
(%free-statement hstmt :close)
(dotimes (param-nr (fill-pointer parameter-data-ptrs))
(setf (fill-pointer parameter-data-ptrs) 0))))
(defun data-parameter-ptr (hstmt)
- (uffi:with-foreign-object (param-ptr (* :pointer-void))
+ (uffi:with-foreign-object (param-ptr :pointer-void)
(let ((return-code (%sql-param-data hstmt param-ptr)))
;;(format t "~%return-code from %sql-param-data: ~a~%" return-code)
(when (= return-code odbc::$SQL_NEED_DATA)
;; database inquiery functions
-(defmethod db-describe-columns ((database odbc-db)
- table-qualifier table-owner table-name column-name)
+(defun db-describe-columns (database table-qualifier table-owner
+ table-name column-name)
(with-slots (hdbc) database
(%describe-columns hdbc table-qualifier table-owner table-name column-name)))
-;; should translate info-type integers to keywords in order to make this
+;; should translate info-type integers to keywords in order to make this
;; more readable?
(defmethod get-odbc-info ((database odbc-db) info-type)
(with-slots (hdbc info) database
(defmethod get-odbc-info ((query odbc-query) info-type)
(get-odbc-info (odbc::query-database query) info-type))
-;; driver inquiery
+;; driver inquiry
+;; How does this differ from list-data-sources?
+(defgeneric db-data-sources (db-type))
(defmethod db-data-sources ((db-type (eql :odbc)))
"Returns a list of (data-source description) - pairs"
(let ((henv (%new-environment-handle)))
(unwind-protect
(loop with direction = :first
- for data-source+description
+ for data-source+description
= (multiple-value-list (%sql-data-sources henv :direction direction))
while (car data-source+description)
collect data-source+description
do (setf direction :next))
(%sql-free-environment henv))))
-
-; EOF
projects / clsql.git / blobdiff