;;;; 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
(in-package #:odbc-dbi)
-(defun connect (&key user password data-source-name)
- (warn "Not implemented.")
- nil)
+(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))
-(defun disconnect (conn)
- (warn "Not implemented."))
+(defgeneric %initialize-query (src arglen col-positions
+ &key result-types width))
-(defun sql (expr &key db result-types row-count column-names)
- (warn "Not implemented."))
+(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))
-(defun close-query (result-set)
- (warn "Not implemented."))
-(defun fetch-row (result-set error-eof eof-value)
- (warn "Not implemented."))
+;;; SQL Interface
-
-(defclass odbc-query (query)
+(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
+ (info :initform (make-hash-table) :reader db-info)
+ (type :initform nil :initarg :db-type :reader db-type)
+ (connected-p :initform nil :accessor db-connected-p)
+ ;; not used yet
+ (count :initform 0 :initarg :count :accessor db-count)
+ ;; not used yet
+ (total-count :initform 0 :allocation :class :accessor db-total-count)
+ ;; the use of this slot is deprecated; it will be removed when dtf works without it.
+ (query :initform nil :accessor db-query-object)
+ ;; resource of (active and inactive) query objects
+ (queries :initform () :accessor db-queries)))
+
+(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)
- ;;(parameter-count :initform 0 :accessor parameter-count)
+ :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)))
-
-(defclass odbc-database (database)
- (;; any reason to have more than one henv?
- (henv :initform nil :allocation :class :initarg :henv :accessor henv)
- (hdbc :initform nil :initarg :hdbc :accessor hdbc)
- ;; info returned from SQLGetInfo
- (info :initform (make-hash-table) :reader db-info))
- #+cormanlisp (:metaclass cl::class-slot-class))
-
-;; use this method if the db object does not exist yet
-
-;; cstacy
-(defparameter *odbc-driver-connect-p* nil)
-
-;; cstacy
-(defmethod db-connect ((db-type (eql :odbc)) db-name user-id password autocommit)
- (if *odbc-driver-connect-p*
- (driver-connect db-type :db-name db-name :user-id user-id :password password)
- ;; Else just use SQLConnect (old way).
- (let ((db (make-instance 'odbc-database :db-type :odbc
- :db-name db-name
- :user-id user-id
- :password password)))
- (unless (henv db) ;; has class allocation!
- (setf (henv db) (%new-environment-handle)))
- (setf (hdbc db) (%new-db-connection-handle (henv db)))
- ;; if connection cannot be established, we drop out here.
- (db-connect db db-name user-id password autocommit))))
-
-;; cstacy
-(defmethod db-connect ((db odbc-database) db-name user-id password autocommit)
- (if *odbc-driver-connect-p*
- (driver-connect db :db-name db-name :user-id user-id :password password)
- ;; Else just use SQLConnect (old way).
- (%sql-connect (hdbc db) db-name user-id password))
- ;; If we got this far without erring out, the database was successfully connected.
- (setf (odbc::db-connected-p db) t)
- (let ((server-name (get-odbc-info db odbc::$SQL_SERVER_NAME))
- (dbms-name (get-odbc-info db odbc::$SQL_DBMS_NAME))
- (txn-capable-p (/= (get-odbc-info db odbc::$SQL_TXN_CAPABLE) odbc::$SQL_TC_NONE)))
- ;; need SERVER-NAME and DBMS-NAME because many drivers mix this up
- (flet ((db-type-p (db-name)
- (or (search db-name server-name :test #'char-equal)
- (search db-name dbms-name :test #'char-equal))))
- (cond ((db-type-p "oracle") (change-class db 'oracle-database))
- ((db-type-p "access") (change-class db 'access-database))
- ((db-type-p "mysql") (change-class db 'mysql-database))
- (t nil)))
- (when txn-capable-p ; has transaction support
+ :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
+ (database :initarg :database :reader query-database)
+ (active-p :initform nil :initarg :active-p :accessor query-active-p))
+ (:documentation
+ "Stores query information, like SQL query string/expression and database to run
+the query against." ))
+
+;;; AODBC Compatible interface
+
+(defun connect (&key data-source-name user password (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)
+ #+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)))))
- db)
-
-;; cstacy
-(defgeneric driver-connect (db-type &key hwnd connection-string
- completion-mode
- db-name user-id password
- &allow-other-keys))
-
-;; cstacy
-(defmethod driver-connect ((db-type (eql :odbc)) &key hwnd connection-string
- (completion-mode :complete)
- db-name user-id password)
- (multiple-value-bind (connection-string db-name user-id password)
- (odbc-connection-string connection-string db-name user-id password)
- (let ((db (make-instance 'odbc-database
- :db-type :odbc
- :db-name db-name
- :user-id user-id
- :password password)))
- (unless (henv db) ;; has class allocation!
- (setf (henv db) (%new-environment-handle))) ;SQLAllocEnv
- (setf (hdbc db) (%new-db-connection-handle (henv db))) ;SQLAllocConnect
- (cond ((null hwnd)
- (setq hwnd (%null-ptr)))
- #+(and :lispworks (not :unix))
- ((eq hwnd t)
- (setq hwnd (capi-library::representation-handle
- (capi:representation
- (ww::find-topmost-window nil nil)))))
- #+(and :lispworks (not :unix))
- ((eq hwnd :podium)
- (setq hwnd (capi-win32-lib::r-top-level-interface-hwnd win32::*main-representation*)))
- ((not (integerp hwnd))
- (error "HWND is not NIL, T, :PODIUM, or an integer")))
- ;; if connection cannot be established, we drop out here.
- (driver-connect db
- :hwnd hwnd
- :connection-string connection-string
- :completion-mode completion-mode))))
-
-;; cstacy
-(defmethod driver-connect ((db odbc-database) &key hwnd connection-string completion-mode
- &allow-other-keys)
- (let ((completion (%sql-driver-connect
- (henv db) (hdbc db) hwnd connection-string completion-mode)))
- (multiple-value-bind (dsn uid pwd)
- (odbc-parse-connection-string completion)
- (flet ((non-string-null (x) (and x (not (string= x "")) x)))
- (setf (odbc::db-name db) (or (non-string-null (odbc::db-name db)) dsn))
- (setf (odbc::db-user-id db) (or (non-string-null (odbc::db-user-id db)) uid))
- (setf (odbc::db-password db) (or (non-string-null (odbc::db-password db)) pwd)))))
- db)
-
-(defmethod db-disconnect ((database odbc-database))
- (with-slots (hdbc queries odbc::connected-p) database
- (when odbc::connected-p
- (dolist (query queries)
- (if (query-active-p query)
- (with-slots (hstmt) query
- (when hstmt
- (%free-statement hstmt :drop)
- (setf hstmt nil)))))
- (%disconnect hdbc)
- #+kmr-nil
- (let ((reset-default-db-p (eq *default-database* database)))
- (setf *connected-databases* (delete database *connected-databases*)
- odbc::connected-p nil)
- (when reset-default-db-p
- (setf *default-database* (car *connected-databases*)))))))
-
-(defmethod db-commit ((database odbc-database))
+ (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)))))
+ (when (db-hstmt database)
+ (%free-statement (db-hstmt database) :drop))
+ (%disconnect hdbc)))
+
+
+(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 "" "" table ""))
+
+(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 rr-sql (hstmt sql-statement &key db)
+ (declare (ignore hstmt sql-statement db))
+ (warn "rr-sql not implemented."))
+
+;;; Mid-level interface
+
+(defun db-commit (database)
(%commit (henv database) (hdbc database)))
-(defmethod db-rollback ((database odbc-database))
+(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)))
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-database is missing
+;; one for odbc-db is missing
(defmethod terminate ((query odbc-query))
;;(format tb::*local-output* "~%*** terminated: ~s" query)
(with-slots (hstmt) query
(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))
(loop for out-len-ptr across column-out-len-ptrs
when out-len-ptr do (uffi:free-foreign-object out-len-ptr))))
-(defmethod db-open-query ((database odbc-database) query-expression
- &key arglen col-positions
- &allow-other-keys)
+(defmethod db-open-query ((database odbc-db) query-expression
+ &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-database) &optional count flatp)
- (db-fetch-query-results (odbc::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))
- 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))
- ((zerop (get-cast-long out-len-ptr))
- 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-database) query-expression &optional flatp)
- (let ((free-query
- ;; make it thread safe
- (get-free-query database)))
- ;;(format tb::*local-output* "~%new query: ~s" free-query)
+ (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
+ (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)
+ (t
+ (read-data-in-chunks hstmt j data-ptr c-type sql-type
+ 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-database) sql-expression &key &allow-other-keys)
+(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*)
(setf (sql-expression query) sql-expression)
(%sql-exec-direct sql-expression hstmt henv hdbc)
query)))
;; reuse inactive queries
-(defmethod get-free-query ((database odbc-database))
+(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)
+ 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
(push new-query queries)
new-query))))
-(defmethod db-execute-command ((database odbc-database) sql-string)
+(defmethod db-execute-command ((database odbc-db) sql-string)
(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)))
(%sql-exec-direct sql-string hstmt henv hdbc)
(db-close-query query)))))
-(defmethod %initialize-query ((database odbc-database) &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
+ 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)
(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
(setf (query-active-p query) nil)))
query)
-(defmethod %read-query-data ((database odbc-database) ignore-columns)
+(defmethod %read-query-data ((database odbc-db) ignore-columns)
(%read-query-data (db-query-object database) ignore-columns))
(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)
+ (with-slots (hstmt column-count column-c-types column-sql-types
+ 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
(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)
(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
(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-database) 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 (odbc::sql-string query-exp))
+ (%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_FLOAT #.odbc::$SQL_DOUBLE) #.odbc::$ODBC-LONG-TYPE)
+ (#.odbc::$SQL_REAL #.odbc::$ODBC-LONG-TYPE)
(#.odbc::$SQL_DATE 'sql-c-date)
(#.odbc::$SQL_TIME 'sql-c-time)
(#.odbc::$SQL_TIMESTAMP 'sql-c-timestamp)
;; prepared queries
-(defmethod db-prepare-statement ((database odbc-database) sql
+(defmethod db-prepare-statement ((database odbc-db) sql
&key parameter-table parameter-columns)
(with-slots (hdbc) database
(let ((query (get-free-query database)))
;; 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
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-database)
- 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
;; more readable?
-(defmethod get-odbc-info ((database odbc-database) info-type)
+(defmethod get-odbc-info ((database odbc-db) info-type)
(with-slots (hdbc info) database
(or (gethash info-type info)
(setf (gethash info-type info)
(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)))
collect data-source+description
do (setf direction :next))
(%sql-free-environment henv))))
-
-; EOF
projects / clsql.git / blobdiff