-14 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net)
- * Version 2.6.14.
+15 Apr 2004 Kevin Rosenberg (kevin@rosenberg.net)
+ * Version 2.7.0: New backend: ODBC. Tests as
+ well as AODBC backend. Requires UFFI v1.4.10
+ * db-odbc/*.lisp: Add ODBC3 function SQLSetEnvAttr
+ to explicitly set ODBC2 support. Add BIGINT support.
+ Add result-types support. Added SQLTables.
+ Fix array type in fetch-all-rows. Make width
+ changable by database or query.
* base/utils.lisp: Add process functions
* base/package.lisp: Export utils to CLSQL-BASE-SYS
- * db-aodbc: implement sequence functions
+ * db-aodbc: Implement sequence functions,
+ database-list-tables, database-list-attributes
+ * tests/utils.lisp: Add support for ODBC backend,
+ rework READ-SPECS to use +all-db-types+
* db-mysql/mysql-sql.lisp: Use WITHOUT-INTERRUPTS
for SEQUENCE-NEXT
(format stream "~S is not a CLSQL database."
(clsql-no-database-error-database c)))))
+(define-condition clsql-odbc-error (clsql-error)
+ ((odbc-message :initarg :odbc-message
+ :reader clsql-odbc-error-message)
+ (sql-state :initarg :sql-state :initform nil
+ :reader clsql-odbc-error-sql-state))
+ (:report (lambda (c stream)
+ (format stream "[ODBC error] ~A; state: ~A"
+ (clsql-odbc-error-message c)
+ (clsql-odbc-error-sql-state c)))))
+
;; Signal conditions
#:clsql-closed-error-database
#:clsql-sql-syntax-error
#:clsql-type-error
-
+ #:clsql-odbc-error
+ #:clsql-odbc-error-message
+
#:*loaded-database-types*
#:reload-database-types
#:*default-database-type*
(defmacro without-interrupts (&body body)
#+lispworks `(mp:without-preemption ,@body)
#+allegro `(mp:without-scheduling ,@body)
- #+cmu `(pcl::without-interrupts ,@body)
+ #+cmu `(system:without-interrupts ,@body)
#+sbcl `(sb-sys::without-interrupts ,@body)
#+openmcl `(ccl:without-interrupts ,@body))
(handler-case
(make-instance 'aodbc-database
:name (database-name-from-spec connection-spec :aodbc)
+ :database-type :aodbc
:aodbc-conn
(dbi:connect :user user
:password password
:data-source-name dsn))
+ (clsql-error (e)
+ (error e))
(error () ;; Init or Connect failed
(error 'clsql-connect-error
:database-type database-type
(handler-case
(dbi:sql query-expression :db (database-aodbc-conn database)
:types result-types)
+ (clsql-error (e)
+ (error e))
(error ()
(error 'clsql-sql-error
:database database
#+aodbc-v2
(handler-case
(dbi:sql sql-expression :db (database-aodbc-conn database))
+ (clsql-error (e)
+ (error e))
(error ()
(error 'clsql-sql-error
:database database
(length column-names)
nil ;; not able to return number of rows with aodbc
))
+ (clsql-error (e)
+ (error e))
(error ()
(error 'clsql-sql-error
:database database
(database-query "SHOW TABLES LIKE '%clsql_seq%'"
database nil)))
+(defmethod database-list-tables ((database aodbc-database)
+ &key (owner nil))
+ (declare (ignore owner))
+ #+aodbc-v2
+ (multiple-value-bind (rows col-names)
+ (dbi:list-all-database-tables :db (database-aodbc-conn database))
+ (let ((pos (position "TABLE_NAME" col-names :test #'string-equal)))
+ (when pos
+ (loop for row in rows
+ collect (nth pos row))))))
+
+
+(defmethod database-list-attributes ((table string) (database aodbc-database)
+ &key (owner nil))
+ (declare (ignore owner))
+ #+aodbc-v2
+ (multiple-value-bind (rows col-names)
+ (dbi:list-all-table-columns table :db (database-aodbc-conn database))
+ (let ((pos (position "COLUMN_NAME" col-names :test #'string-equal)))
+ (when pos
+ (loop for row in rows
+ collect (nth pos row))))))
+
+(defmethod database-attribute-type ((attribute string) (table string) (database aodbc-database)
+ &key (owner nil))
+ (declare (ignore owner))
+ #+aodbc-v2
+ (multiple-value-bind (rows col-names)
+ (dbi:list-all-table-columns table :db (database-aodbc-conn database))
+ (let ((pos (position "TYPE_NAME" col-names :test #'string-equal)))
+ (when pos
+ (loop for row in rows
+ collect (nth pos row))))))
+
(defmethod database-set-sequence-position (sequence-name
(position integer)
(database aodbc-database))
(database-execute-command
- (format nil "UPDATE ~A SET last-value=~A"
+ (format nil "UPDATE ~A SET last_value=~A,is_called='t'"
(%sequence-name-to-table sequence-name)
position)
database)
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
-;;;; Name: odbc-ff-interface.lisp
-;;;; Purpose: Function definitions for UFFI interface to ODBC
-;;;; Author: Kevin M. Rosenberg, Paul Meurer
+;;;; Name: odbc-api.lisp
+;;;; Purpose: Low-level ODBC API using UFFI
+;;;; Authors: Kevin M. Rosenberg and Paul Meurer
;;;;
;;;; $Id: odbc-package.lisp 7061 2003-09-07 06:34:45Z kevin $
;;;;
(in-package #:odbc)
-(defvar *null* (make-null-pointer :byte))
+(defvar *null* nil
+ "Lisp representation of SQL Null value, default = nil.
+May be locally bound to something else if a certain type is necessary.")
+
+
(defvar *binary-format* :unsigned-byte-vector)
-(defvar *time-conversion-function* 'identity)
+(defvar *time-conversion-function* (lambda (universal-time &optional fraction)
+ (declare (ignore fraction))
+ universal-time)
+ "Bound to a function that converts from a Lisp universal time fixnum (and a fractional
+as possible second argument) to the desired representation of date/time/timestamp.")
+
+(defvar +null-ptr+ (make-null-pointer :byte))
+(defvar *info-output* nil
+ "Stream to send SUCCESS_WITH_INFO messages.")
(defun %null-ptr ()
(make-null-pointer :byte))
(when (and ,max-length (> ,size ,max-length))
(error "string \"~a\" of length ~d is longer than max-length: ~d"
,string ,size ,max-length))
- (dotimes (i ,size)
- (setf (deref-array ,ptr '(:array :unsigned-char) i) (char ,string i)))
- (setf (deref-array ,ptr '(:array :unsigned-char) ,size) 0))))
+ (with-cast-pointer (char-ptr ,ptr :byte)
+ (dotimes (i ,size)
+ (setf (deref-array char-ptr '(:array :byte) i)
+ (char-code (char ,string i))))
+ (setf (deref-array char-ptr '(:array :byte) ,size) 0)))))
(defun %cstring-into-vector (ptr vector offset size-in-bytes)
- (dotimes (i size-in-bytes)
- (setf (aref vector offset)
- (deref-array ptr '(:array :unsigned-char) i))
- (incf offset))
- offset)
+ (dotimes (i size-in-bytes)
+ (setf (schar vector offset)
+ (ensure-char-character
+ (deref-array ptr '(:array :unsigned-char) i)))
+ (incf offset))
+ offset)
(defun handle-error (henv hdbc hstmt)
- (with-foreign-objects ((sql-state '(:array :unsigned-char 256))
- (error-message '(:array :unsigned-char
- #.$SQL_MAX_MESSAGE_LENGTH))
- (error-code :long)
- (msg-length :short))
- (SQLError henv hdbc hstmt sql-state
- error-code error-message
- $SQL_MAX_MESSAGE_LENGTH msg-length)
- (values
- (convert-from-foreign-string error-message)
- (convert-from-foreign-string sql-state)
- (deref-pointer msg-length :short)
- (deref-pointer error-code :long))))
-
-; test this: return a keyword for efficiency
+ (let ((sql-state (allocate-foreign-string 256))
+ (error-message (allocate-foreign-string $SQL_MAX_MESSAGE_LENGTH)))
+ (with-foreign-objects ((error-code :long)
+ (msg-length :short))
+ (SQLError henv hdbc hstmt sql-state
+ error-code error-message
+ $SQL_MAX_MESSAGE_LENGTH msg-length)
+ (values
+ (prog1
+ (convert-from-foreign-string error-message)
+ (free-foreign-object error-message))
+ (prog1
+ (convert-from-foreign-string sql-state)
+ (free-foreign-object error-message))
+ (deref-pointer msg-length :short)
+ (deref-pointer error-code :long)))))
+
(defun sql-state (henv hdbc hstmt)
- (with-foreign-objects ((sql-state '(:array :unsigned-char 256))
- (error-message '(:array :unsigned-char
- #.$SQL_MAX_MESSAGE_LENGTH))
- (error-code :long)
- (msg-length :short))
- (SQLError henv hdbc hstmt sql-state error-code
- error-message $SQL_MAX_MESSAGE_LENGTH msg-length)
- (convert-from-foreign-string sql-state) ;(%cstring-to-keyword sql-state)
+ (let ((sql-state (allocate-foreign-string 256))
+ (error-message (allocate-foreign-string $SQL_MAX_MESSAGE_LENGTH)))
+ (with-foreign-objects ((error-code :long)
+ (msg-length :short))
+ (SQLError henv hdbc hstmt sql-state error-code
+ error-message $SQL_MAX_MESSAGE_LENGTH msg-length)
+ (free-foreign-object error-message)
+ (prog1
+ (convert-from-foreign-string sql-state)
+ (free-foreign-object sql-state)))
+ ;; test this: return a keyword for efficiency
+ ;;(%cstring-to-keyword sql-state)
))
(defmacro with-error-handling ((&key henv hdbc hstmt (print-info t))
(#.$SQL_SUCCESS_WITH_INFO
(when ,print-info
(multiple-value-bind (error-message sql-state)
- (handle-error (or ,henv (%null-ptr))
- (or ,hdbc (%null-ptr))
- (or ,hstmt (%null-ptr)))
- (warn "[ODBC info] ~a state: ~a"
- ,result-code error-message
- sql-state)))
+ (handle-error (or ,henv +null-ptr+)
+ (or ,hdbc +null-ptr+)
+ (or ,hstmt +null-ptr+))
+ (when *info-output*
+ (format *info-output* "[ODBC info ~A] ~A state: ~A"
+ ,result-code error-message
+ sql-state))))
(progn ,result-code ,@body))
(#.$SQL_INVALID_HANDLE
- (error "[ODBC error] Invalid handle"))
+ (error
+ 'clsql-base-sys:clsql-odbc-error
+ :odbc-message "Invalid handle"))
(#.$SQL_STILL_EXECUTING
- (error "[ODBC error] Still executing"))
+ (error
+ 'clsql-base-sys:clsql-odbc-error
+ :odbc-message "Still executing"))
(#.$SQL_ERROR
(multiple-value-bind (error-message sql-state)
- (handle-error (or ,henv (%null-ptr))
- (or ,hdbc (%null-ptr))
- (or ,hstmt (%null-ptr)))
- (error "[ODBC error] ~a; state: ~a" error-message sql-state)))
- (otherwise
+ (handle-error (or ,henv +null-ptr+)
+ (or ,hdbc +null-ptr+)
+ (or ,hstmt +null-ptr+))
+ (error
+ 'clsql-base-sys:clsql-odbc-error
+ :odbc-message error-message
+ :sql-state sql-state)))
+ (otherwise
(progn ,result-code ,@body))))))
(defun %new-environment-handle ()
- (with-foreign-object (phenv 'sql-handle-ptr)
- (with-error-handling
- ()
- (SQLAllocEnv phenv)
- (deref-pointer phenv 'sql-handle-ptr))))
+ (let ((henv
+ (with-foreign-object (phenv 'sql-handle)
+ (with-error-handling
+ ()
+ (SQLAllocEnv phenv)
+ (deref-pointer phenv 'sql-handle)))))
+ (%set-attr-odbc-version henv $SQL_OV_ODBC2)
+ henv))
+
(defun %sql-free-environment (henv)
(with-error-handling
(SQLFreeEnv henv)))
(defun %new-db-connection-handle (henv)
- (with-foreign-object (phdbc 'sql-handle-ptr)
+ (with-foreign-object (phdbc 'sql-handle)
(with-error-handling
(:henv henv)
(SQLAllocConnect henv phdbc)
- (deref-pointer phdbc 'sql-handle-ptr))))
+ (deref-pointer phdbc 'sql-handle))))
(defun %free-statement (hstmt option)
(with-error-handling
scale ;0
data-ptr
max-value
- out-len-ptr ;#.(%null-ptr)
+ out-len-ptr ;#.+null-ptr+
)))
(defun %sql-fetch (hstmt)
(SQLFetch hstmt)))
(defun %new-statement-handle (hdbc)
- (with-foreign-object (hstmt-ptr 'sql-handle-ptr)
+ (with-foreign-object (hstmt-ptr 'sql-handle)
(with-error-handling
(:hdbc hdbc)
(SQLAllocStmt hdbc hstmt-ptr)
- (deref-pointer hstmt-ptr 'sql-handle-ptr))))
+ (deref-pointer hstmt-ptr 'sql-handle))))
(defun %sql-get-info (hdbc info-type)
(ecase info-type
#.$SQL_SPECIAL_CHARACTERS
#.$SQL_TABLE_TERM
#.$SQL_USER_NAME)
- (with-foreign-objects ((info-ptr '(:array :unsigned-char 1024))
- (info-length-ptr :short))
- (with-error-handling
- (:hdbc hdbc)
- #-pcl
- (SQLGetInfo hdbc info-type info-ptr 1023 info-length-ptr)
- #+pcl
- (SQLGetInfo-Str hdbc info-type info-ptr 1023 info-length-ptr)
- (convert-from-foreign-string info-ptr))))
+ (let ((info-ptr (allocate-foreign-string 1024)))
+ (with-foreign-object (info-length-ptr :short)
+ (with-error-handling
+ (:hdbc hdbc)
+ (SQLGetInfo hdbc info-type info-ptr 1023 info-length-ptr)
+ (prog1
+ (convert-from-foreign-string info-ptr)
+ (free-foreign-object info-ptr))))))
;; those returning a word
((#.$SQL_ACTIVE_CONNECTIONS
#.$SQL_ACTIVE_STATEMENTS
;; column counting is 1-based
(defun %describe-column (hstmt column-nr)
- (with-foreign-objects ((column-name-ptr '(:array :unsigned-char 256))
- (column-name-length-ptr :short)
- (column-sql-type-ptr :short)
- (column-precision-ptr :long)
- (column-scale-ptr :short)
- (column-nullable-p-ptr :short))
- (with-error-handling (:hstmt hstmt)
- (SQLDescribeCol hstmt column-nr column-name-ptr 256
- column-name-length-ptr
- column-sql-type-ptr
- column-precision-ptr
- column-scale-ptr
- column-nullable-p-ptr)
- (values
- (convert-from-foreign-string column-name-ptr)
- (deref-pointer column-sql-type-ptr :short)
- (deref-pointer column-precision-ptr :long)
- (deref-pointer column-scale-ptr :short)
- (deref-pointer column-nullable-p-ptr :short)))))
-
+ (let ((column-name-ptr (allocate-foreign-string 256)))
+ (with-foreign-objects ((column-name-length-ptr :short)
+ (column-sql-type-ptr :short)
+ (column-precision-ptr :long)
+ (column-scale-ptr :short)
+ (column-nullable-p-ptr :short))
+ (with-error-handling (:hstmt hstmt)
+ (SQLDescribeCol hstmt column-nr column-name-ptr 256
+ column-name-length-ptr
+ column-sql-type-ptr
+ column-precision-ptr
+ column-scale-ptr
+ column-nullable-p-ptr)
+ (let ((column-name (convert-from-foreign-string column-name-ptr)))
+ (free-foreign-object column-name-ptr)
+ (values
+ column-name
+ (deref-pointer column-sql-type-ptr :short)
+ (deref-pointer column-precision-ptr :long)
+ (deref-pointer column-scale-ptr :short)
+ (deref-pointer column-nullable-p-ptr :short)))))))
+
;; parameter counting is 1-based
(defun %describe-parameter (hstmt parameter-nr)
(with-foreign-objects ((column-sql-type-ptr :short)
(deref-pointer column-nullable-p-ptr :short)))))
(defun %column-attributes (hstmt column-nr descriptor-type)
- (with-foreign-objects ((descriptor-info-ptr '(:array :unsigned-char 256))
- (descriptor-length-ptr :short)
- (numeric-descriptor-ptr :long))
- (with-error-handling
- (:hstmt hstmt)
- (SQLColAttributes hstmt column-nr descriptor-type descriptor-info-ptr 256
- descriptor-length-ptr
- numeric-descriptor-ptr)
- (values
- (convert-from-foreign-string descriptor-info-ptr)
- (deref-pointer numeric-descriptor-ptr :long)))))
-
+ (let ((descriptor-info-ptr (allocate-foreign-string 256)))
+ (with-foreign-objects ((descriptor-length-ptr :short)
+ (numeric-descriptor-ptr :long))
+ (with-error-handling
+ (:hstmt hstmt)
+ (SQLColAttributes hstmt column-nr descriptor-type descriptor-info-ptr
+ 256 descriptor-length-ptr
+ numeric-descriptor-ptr)
+ (values
+ (prog1
+ (convert-from-foreign-string descriptor-info-ptr)
+ (free-foreign-object descriptor-info-ptr))
+ (deref-pointer numeric-descriptor-ptr :long))))))
+
(defun %prepare-describe-columns (hstmt table-qualifier table-owner
table-name column-name)
(with-cstrings ((table-qualifier-ptr table-qualifier)
(fetch-all-rows hstmt)))
(defun %sql-data-sources (henv &key (direction :first))
- (with-foreign-objects
- ((name-ptr '(:array :unsigned-char #.(1+ $SQL_MAX_DSN_LENGTH)))
- (name-length-ptr :short)
- (description-ptr '(:array :unsigned-char 1024))
- (description-length-ptr :short))
- (let ((res (with-error-handling
- (:henv henv)
- (SQLDataSources henv
- (ecase direction
- (:first $SQL_FETCH_FIRST)
- (:next $SQL_FETCH_NEXT))
- name-ptr
- (1+ $SQL_MAX_DSN_LENGTH)
- name-length-ptr
- description-ptr
- 1024
- description-length-ptr))))
- (unless (= res $SQL_NO_DATA_FOUND)
- (values (convert-from-foreign-string name-ptr)
- (convert-from-foreign-string description-ptr))))))
+ (let ((name-ptr (allocate-foreign-string (1+ $SQL_MAX_DSN_LENGTH)))
+ (description-ptr (allocate-foreign-string 1024)))
+ (with-foreign-objects ((name-length-ptr :short)
+ (description-length-ptr :short))
+ (let ((res (with-error-handling
+ (:henv henv)
+ (SQLDataSources henv
+ (ecase direction
+ (:first $SQL_FETCH_FIRST)
+ (:next $SQL_FETCH_NEXT))
+ name-ptr
+ (1+ $SQL_MAX_DSN_LENGTH)
+ name-length-ptr
+ description-ptr
+ 1024
+ description-length-ptr))))
+ (unless (= res $SQL_NO_DATA_FOUND)
+ (values
+ (prog1
+ (convert-from-foreign-string name-ptr)
+ (free-foreign-object name-ptr))
+ (prog1
+ (convert-from-foreign-string description-ptr)
+ (free-foreign-object description-ptr))))))))
(defun sql-to-c-type (sql-type)
(ecase sql-type
#.$SQL_NUMERIC #.$SQL_DECIMAL #.$SQL_BIGINT -8 -9) $SQL_C_CHAR)
(#.$SQL_INTEGER $SQL_C_SLONG)
(#.$SQL_SMALLINT $SQL_C_SSHORT)
- ((#.$SQL_FLOAT #.$SQL_DOUBLE) $SQL_C_DOUBLE)
- (#.$SQL_REAL $SQL_C_FLOAT)
+ (#.$SQL_DOUBLE $SQL_C_DOUBLE)
+ (#.$SQL_FLOAT $SQL_C_FLOAT)
+ (#.$SQL_REAL $SQL_C_DOUBLE)
(#.$SQL_DATE $SQL_C_DATE)
(#.$SQL_TIME $SQL_C_TIME)
(#.$SQL_TIMESTAMP $SQL_C_TIMESTAMP)
(#.$SQL_TINYINT $SQL_C_STINYINT)
(#.$SQL_BIT $SQL_C_BIT)))
+(def-type byte-pointer-type '(* :byte))
+(def-type short-pointer-type '(* :short))
+(def-type int-pointer-type '(* :int))
+(def-type long-pointer-type '(* :long))
+(def-type float-pointer-type '(* :float))
+(def-type double-pointer-type '(* :double))
+(def-type string-pointer-type '(* :unsigned-char))
+
(defun get-cast-byte (ptr)
- (declare (type long-ptr-type out-len-ptr))
- (with-cast-pointer (casted ptr '(* :byte))
- (deref-pointer casted :byte)))
+ (locally (declare (type byte-pointer-type ptr))
+ (deref-pointer ptr :byte)))
(defun get-cast-short (ptr)
- (declare (type long-ptr-type out-len-ptr))
- (with-cast-pointer (casted ptr '(* :short))
- (deref-pointer casted :short)))
+ (locally (declare (type short-pointer-type ptr))
+ (deref-pointer ptr :short)))
(defun get-cast-int (ptr)
- (declare (type long-ptr-type out-len-ptr))
- (with-cast-pointer (casted ptr '(* :int))
- (deref-pointer casted :int)))
+ (locally (declare (type int-pointer-type ptr))
+ (deref-pointer ptr :int)))
(defun get-cast-long (ptr)
- (declare (type long-ptr-type out-len-ptr))
- (with-cast-pointer (casted ptr '(* :long))
- (deref-pointer casted :long)))
+ (locally (declare (type long-pointer-type ptr))
+ (deref-pointer ptr :long)))
(defun get-cast-single-float (ptr)
- (declare (type long-ptr-type out-len-ptr))
- (with-cast-pointer (casted ptr '(* :float))
- (deref-pointer casted :float)))
+ (locally (declare (type float-pointer-type ptr))
+ (deref-pointer ptr :float)))
(defun get-cast-double-float (ptr)
- (declare (type long-ptr-type out-len-ptr))
- (with-cast-pointer (casted ptr '(* :double))
- (deref-pointer casted :double)))
+ (locally (declare (type double-pointer-type ptr))
+ (deref-pointer ptr :double)))
(defun get-cast-foreign-string (ptr)
- (declare (type long-ptr-type out-len-ptr))
- (with-cast-pointer (casted ptr '(* :unsigned-char))
- (convert-from-foreign-string casted)))
+ (locally (declare (type string-pointer-type ptr))
+ (convert-from-foreign-string ptr)))
(defun get-cast-binary (ptr len format)
"FORMAT is one of :unsigned-byte-vector, :bit-vector (:string, :hex-string)"
- (with-cast-pointer (casted ptr '(* :byte))
+ (with-cast-pointer (casted ptr :byte)
(ecase format
(:unsigned-byte-vector
(let ((vector (make-array len :element-type '(unsigned-byte 8))))
(dotimes (i len)
(let ((byte (deref-array casted '(:array :byte) i)))
(dotimes (j 8)
- (setf (bit vector (+ (ash i 3) j)) (logand (ash byte (- j 7)) 1)))))
+ (setf (bit vector (+ (ash i 3) j))
+ (logand (ash byte (- j 7)) 1)))))
vector)))))
-(defun read-data (data-ptr c-type sql-type out-len-ptr convert-to-string-p)
+(defun read-data (data-ptr c-type sql-type out-len-ptr result-type)
(declare (type long-ptr-type out-len-ptr))
- (let ((out-len (deref-pointer out-len-ptr :long)))
- (cond ((= out-len $SQL_NULL_DATA)
- *null*)
- ;; obsolete?
- (convert-to-string-p
- (convert-from-foreign-string data-ptr))
- (t
- (case sql-type
- ;; SQL extended datatypes
- (#.$SQL_TINYINT (get-cast-short data-ptr))
- (#.$SQL_C_STINYINT (get-cast-short data-ptr)) ;; ?
- (#.$SQL_C_SSHORT (get-cast-short data-ptr)) ;; ?
- (#.$SQL_SMALLINT (deref-pointer data-ptr :short)) ; ??
- (#.$SQL_INTEGER (deref-pointer data-ptr :long))
- (#.$SQL_DECIMAL
- (let ((*read-base* 10))
- (read-from-string (get-cast-foreign-string data-ptr))))
- (t
- (case c-type
- (#.$SQL_C_DATE
- (funcall *time-conversion-function* (date-to-universal-time data-ptr)))
- (#.$SQL_C_TIME
- (multiple-value-bind (universal-time frac) (time-to-universal-time data-ptr)
- (funcall *time-conversion-function* universal-time frac)))
- (#.$SQL_C_TIMESTAMP
- (multiple-value-bind (universal-time frac) (timestamp-to-universal-time data-ptr)
- (funcall *time-conversion-function* universal-time frac)))
- (#.$SQL_INTEGER
- (get-cast-int data-ptr))
- (#.$SQL_C_FLOAT
- (get-cast-single-float data-ptr))
- (#.$SQL_C_DOUBLE
- (get-cast-double-float data-ptr))
- (#.$SQL_C_SLONG
- (get-cast-long data-ptr))
- #+lispworks
- (#.$SQL_C_BIT ; encountered only in Access
- (get-cast-byte data-ptr))
- (#.$SQL_C_BINARY
- (get-cast-binary data-ptr out-len *binary-format*))
- ((#.$SQL_C_SSHORT #.$SQL_C_STINYINT) ; LMH short ints
- (get-cast-short data-ptr)) ; LMH
- #+ignore
- (#.$SQL_C_CHAR
- (code-char (get-cast-short data-ptr)))
- (t
- (convert-from-foreign-string data-ptr)))))))))
+ (let* ((out-len (deref-pointer out-len-ptr :long))
+ (value
+ (cond ((= out-len $SQL_NULL_DATA)
+ *null*)
+ (t
+ (case sql-type
+ ;; SQL extended datatypes
+ (#.$SQL_TINYINT (get-cast-byte data-ptr))
+ (#.$SQL_C_STINYINT (get-cast-byte data-ptr)) ;; ?
+ (#.$SQL_C_SSHORT (get-cast-short data-ptr)) ;; ?
+ (#.$SQL_SMALLINT (get-cast-short data-ptr)) ;; ??
+ (#.$SQL_INTEGER (get-cast-int data-ptr))
+ (#.$SQL_BIGINT (read-from-string
+ (get-cast-foreign-string data-ptr)))
+ (#.$SQL_TINYINT (read-from-string
+ (get-cast-foreign-string data-ptr)))
+ (#.$SQL_DECIMAL
+ (let ((*read-base* 10))
+ (read-from-string (get-cast-foreign-string data-ptr))))
+ (t
+ (case c-type
+ (#.$SQL_C_DATE
+ (funcall *time-conversion-function* (date-to-universal-time data-ptr)))
+ (#.$SQL_C_TIME
+ (multiple-value-bind (universal-time frac) (time-to-universal-time data-ptr)
+ (funcall *time-conversion-function* universal-time frac)))
+ (#.$SQL_C_TIMESTAMP
+ (multiple-value-bind (universal-time frac) (timestamp-to-universal-time data-ptr)
+ (funcall *time-conversion-function* universal-time frac)))
+ (#.$SQL_INTEGER
+ (get-cast-int data-ptr))
+ (#.$SQL_C_FLOAT
+ (get-cast-single-float data-ptr))
+ (#.$SQL_C_DOUBLE
+ (get-cast-double-float data-ptr))
+ (#.$SQL_C_SLONG
+ (get-cast-long data-ptr))
+ #+lispworks
+ (#.$SQL_C_BIT ; encountered only in Access
+ (get-cast-byte data-ptr))
+ (#.$SQL_C_BINARY
+ (get-cast-binary data-ptr out-len *binary-format*))
+ ((#.$SQL_C_SSHORT #.$SQL_C_STINYINT) ; LMH short ints
+ (get-cast-short data-ptr)) ; LMH
+ #+ignore
+ (#.$SQL_C_CHAR
+ (code-char (get-cast-short data-ptr)))
+ (t
+ (get-cast-foreign-string data-ptr)))))))))
+
+ ;; FIXME: this could be better optimized for types which use READ-FROM-STRING above
+
+ (if (and (or (eq result-type t) (eq result-type :string))
+ (not (stringp value)))
+ (write-to-string value)
+ value)))
;; which value is appropriate?
-(defparameter +max-precision+
- #+mcl 512
- #-mcl 4001)
+(defparameter +max-precision+ 4001)
(defvar *break-on-unknown-data-type* t)
(#.$SQL_C_DATE (allocate-foreign-object 'sql-c-date))
(#.$SQL_C_TIME (allocate-foreign-object 'sql-c-time))
(#.$SQL_C_TIMESTAMP (allocate-foreign-object 'sql-c-timestamp))
- #+lispworks(#.$SQL_C_FLOAT (uffi:allocate-foreign-object :float))
- (#.$SQL_C_BIT (uffi:allocate-foreign-object :boolean))
+ (#.$SQL_C_FLOAT (uffi:allocate-foreign-object :float))
+ (#.$SQL_REAL (uffi:allocate-foreign-object :float))
+ (#.$SQL_C_BIT (uffi:allocate-foreign-object :byte))
(#.$SQL_C_STINYINT (uffi:allocate-foreign-object :byte))
(#.$SQL_C_SSHORT (uffi:allocate-foreign-object :short))
(#.$SQL_C_CHAR (uffi:allocate-foreign-string (1+ size)))
(when *break-on-unknown-data-type*
(break "SQL type is ~A, precision ~D, size ~D, C type is ~A"
sql-type precision size c-type))
- (uffi:allocate-foreign-object :ptr (1+ size)))))
+ (uffi:allocate-foreign-object :pointer-void (1+ size)))))
(out-len-ptr (uffi:allocate-foreign-object :long)))
(values c-type data-ptr out-len-ptr size long-p)))
(defun fetch-all-rows (hstmt &key free-option flatp)
(let ((column-count (result-columns-count hstmt)))
(unless (zerop column-count)
- (let ((names (make-array column-count :element-type 'string))
+ (let ((names (make-array column-count))
(sql-types (make-array column-count :element-type 'fixnum))
(c-types (make-array column-count :element-type 'fixnum))
(precisions (make-array column-count :element-type 'fixnum))
(setf (svref names col-nr) name
(aref sql-types col-nr) sql-type
(aref c-types col-nr) (sql-to-c-type sql-type)
- (aref precisions col-nr) (if (zerop precision) nil precision)
+ (aref precisions col-nr) (if (zerop precision) 0 precision)
(aref scales col-nr) scale
(aref nullables-p col-nr) nullable-p
(aref data-ptrs col-nr) data-ptr
(aref c-types 0)
(aref sql-types 0)
(aref out-len-ptrs 0)
- nil)))
+ t)))
(t
(loop until (= (%sql-fetch hstmt) $SQL_NO_DATA_FOUND)
collect
(aref c-types col-nr)
(aref sql-types col-nr)
(aref out-len-ptrs col-nr)
- nil)))))))
+ t)))))))
names)
;; dispose of memory etc
(when free-option (%free-statement hstmt free-option))
;; depending on option, we return a long int or a string; string not implemented
(defun get-connection-option (hdbc option)
- (with-foreign-objects ((param-ptr :long #+ignore #.(1+ $SQL_MAX_OPTION_STRING_LENGTH)))
+ (with-foreign-objects ((param-ptr :long))
(with-error-handling (:hdbc hdbc)
(SQLGetConnectOption hdbc option param-ptr)
(deref-pointer param-ptr :long))))
(defconstant $sql-data-truncated (intern "01004" :keyword))
(defun read-data-in-chunks (hstmt column-nr data-ptr c-type sql-type
- out-len-ptr convert-to-string-p)
- (declare (ignore convert-to-string-p) ; prelimianary
- (type long-ptr-type out-len-ptr))
+ out-len-ptr result-type)
+ (declare (type long-ptr-type out-len-ptr))
(let* ((res (%sql-get-data hstmt column-nr c-type data-ptr
+max-precision+ out-len-ptr))
(out-len (deref-pointer out-len-ptr :long))
data-length)))
(error "wrong type. preliminary."))
while (and (= res $SQL_SUCCESS_WITH_INFO)
- (equal (sql-state (%null-ptr) (%null-ptr) hstmt)
+ (equal (sql-state +null-ptr+ +null-ptr+ hstmt)
"01004"))
do (setf res (%sql-get-data hstmt column-nr c-type data-ptr
+max-precision+ out-len-ptr)))
(error "wrong type. preliminary."))
while
(and (= res $SQL_SUCCESS_WITH_INFO)
- #+ingore(eq (sql-state (%null-ptr) (%null-ptr) hstmt)
+ #+ingore(eq (sql-state +null-ptr+ +null-ptr+ hstmt)
$sql-data-truncated)
- (equal (sql-state (%null-ptr) (%null-ptr) hstmt)
+ (equal (sql-state +null-ptr+ +null-ptr+ hstmt)
"01004"))
do (setf res (%sql-get-data hstmt column-nr c-type data-ptr
+max-precision+ out-len-ptr)
(read-from-string str))
str))))))
+(def-type c-timestamp-ptr-type '(* (:struct sql-c-timestamp)))
+
(defun timestamp-to-universal-time (ptr)
+ (declare (type c-timestamp-ptr-type ptr))
(values
(encode-universal-time
(get-slot-value ptr 'sql-c-timestamp 'second)
ptr)))
(defun %put-timestamp (ptr time &optional (fraction 0))
+ (declare (type c-timestamp-ptr-type ptr))
(multiple-value-bind (sec min hour day month year)
(decode-universal-time time)
(setf (get-slot-value ptr 'sql-c-timestamp 'second) sec
ptr))
(defun date-to-universal-time (ptr)
+ (declare (type c-timestamp-ptr-type ptr))
(encode-universal-time
0 0 0
(get-slot-value ptr 'sql-c-timestamp 'day)
(get-slot-value ptr 'sql-c-timestamp 'year)))
(defun time-to-universal-time (ptr)
+ (declare (type c-timestamp-type ptr))
(encode-universal-time
(get-slot-value ptr 'sql-c-timestamp 'second)
(get-slot-value ptr 'sql-c-timestamp 'minute)
(get-slot-value ptr 'sql-c-timestamp 'hour)
- 0 0 0))
+ 1 1 0))
+
+
+;;; Added by KMR
+
+(defun %set-attr-odbc-version (henv version)
+ (with-error-handling (:henv henv)
+ (SQLSetEnvAttr henv $SQL_ATTR_ODBC_VERSION
+ (make-pointer version :void) 0)))
+(defun %list-tables (hstmt)
+ (with-error-handling (:hstmt hstmt)
+ (SQLTables hstmt +null-ptr+ 0 +null-ptr+ 0 +null-ptr+ 0 +null-ptr+ 0)))
;;;;
;;;; Name: odbc-constants.lisp
;;;; Purpose: Constants for UFFI interface to ODBC
-;;;; Authors: Paul Meurer and Kevin M. Rosenberg
+;;;; Authors: Kevin M. Rosenberg and Paul Meurer
;;;;
;;;; $Id: odbc-package.lisp 7061 2003-09-07 06:34:45Z kevin $
;;;;
;; generally useful constants
(defconstant $SQL_SPEC_MAJOR 2) ;; Major version of specification
(defconstant $SQL_SPEC_MINOR 10) ;; Minor version of specification
-(defconstant $SQL_SPEC_STRING "02.10") ;; String constant for version
+(defvar $SQL_SPEC_STRING "02.10") ;; String constant for version
(defconstant $SQL_SQLSTATE_SIZE 5) ;; size of SQLSTATE
(defconstant $SQL_MAX_MESSAGE_LENGTH 512) ;; message buffer size
(defconstant $SQL_MAX_DSN_LENGTH 32) ;; maximum data source name size
(defconstant $SQL_USE_BOOKMARKS 12)
(defconstant $SQL_GET_BOOKMARK 13 /* GetStmtOption Only)
(defconstant $SQL_ROW_NUMBER 14 /* GetStmtOption Only)
-; #if (ODBCVER >= #x0200))
(defconstant $SQL_STMT_OPT_MAX SQL_ROW_NUMBER
-;; #else)
-(defconstant $SQL_STMT_OPT_MAX SQL_BIND_TYPE
-;; #endif ;; ODBCVER >= #x0200
)
(defconstant $SQL_STMT_OPT_MIN SQL_QUERY_TIMEOUT
(defconstant $SQL_FETCH_RELATIVE 6)
(defconstant $SQL_FETCH_BOOKMARK 8)
+;;; ODBC v3 constants
+
+(defconstant $SQL_ATTR_ODBC_VERSION 200)
+(defconstant $SQL_OV_ODBC2 2)
+(defconstant $SQL_OV_ODBC3 3)
+
(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)
"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)
- ;; FIXME: Check if connected
+ (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))
(when hstmt
(%free-statement hstmt :drop)
(setf hstmt nil)))))
+ (%free-statement (db-hstmt database) :drop)
(%disconnect hdbc)))
-(defun sql (expr &key db result-types row-count column-names query)
- (if query
- (db-query db expr)
- ;; fixme: don't return all query results.
- (db-query db expr)))
+(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-odbc-error :odbc-message "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 close-query (result-set)
- (warn "Not implemented."))
+(defun list-all-table-columns (table &key db hstmt)
+ (declare (ignore hstmt))
+ (db-describe-columns db "" "" table ""))
-(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))
(%commit (henv database) (hdbc database)))
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
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)
(db-fetch-query-results (db-query-object database) count))
(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
- (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)))))
-
-(defmethod db-query ((database odbc-db) query-expression)
- (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)))))
+
+(defmethod db-query ((database odbc-db) 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)
- ;; 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)
+ (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)
(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)))
"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 (clsql-base-sys:without-interrupts ;; not context switch allowed here
+ (or (clsql-base-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
+ 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+
(fill-pointer column-names) 0
(fill-pointer column-c-types) 0
(fill-pointer column-sql-types) 0
(%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
+ 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_BIGINT :short)
+ (t t))))
+ (t
+ t)))))
query)
(defmethod db-close-query ((query odbc-query) &key drop-p)
(%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
+ (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 (= (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-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
(error "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)
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))
(with-slots (hstmt parameter-data-ptrs) query
(prog1
- (db-fetch-query-results query nil
- 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)
(in-package #:odbc)
-(def-foreign-type sql-handle (* :void))
-(def-foreign-type sql-handle-ptr (* sql-handle))
-(def-foreign-type string-ptr (* :void))
-
+(def-foreign-type sql-handle :pointer-void)
+(def-foreign-type sql-handle-ptr '(* sql-handle))
+(def-foreign-type string-ptr '(* :unsigned-char))
(def-type long-ptr-type '(* :long))
(def-function "SQLAllocEnv"
((*phenv sql-handle-ptr) ; HENV FAR *phenv
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
(def-function "SQLAllocConnect"
((henv sql-handle) ; HENV henv
(*phdbc sql-handle-ptr) ; HDBC FAR *phdbc
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
(def-function "SQLConnect"
((hdbc sql-handle) ; HDBC hdbc
- (*szDSN string-ptr) ; UCHAR FAR *szDSN
+ (*szDSN :cstring) ; UCHAR FAR *szDSN
(cbDSN :short) ; SWORD cbDSN
- (*szUID string-ptr) ; UCHAR FAR *szUID
+ (*szUID :cstring) ; UCHAR FAR *szUID
(cbUID :short) ; SWORD cbUID
- (*szAuthStr string-ptr) ; UCHAR FAR *szAuthStr
+ (*szAuthStr :cstring) ; UCHAR FAR *szAuthStr
(cbAuthStr :short) ; SWORD cbAuthStr
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
(def-function "SQLDriverConnect"
(*pcbConnStrOut :pointer-void) ; SWORD FAR *pcbConnStrOut
(fDriverCompletion :short) ; UWORD fDriverCompletion
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
(def-function "SQLDisconnect"
((hdbc sql-handle)) ; HDBC hdbc
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
(def-function "SQLAllocStmt"
((hdbc sql-handle) ; HDBC hdbc
(*phstmt sql-handle-ptr) ; HSTMT FAR *phstmt
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
(def-function "SQLGetInfo"
(cbInfoValueMax :short) ; SWORD cbInfoValueMax
(*pcbInfoValue :pointer-void) ; SWORD FAR *pcbInfoValue
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
(def-function "SQLPrepare"
((hstmt sql-handle) ; HSTMT hstmt
- (*szSqlStr string-ptr) ; UCHAR FAR *szSqlStr
+ (*szSqlStr :cstring) ; UCHAR FAR *szSqlStr
(cbSqlStr :long) ; SDWORD cbSqlStr
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
(def-function "SQLExecute"
((hstmt sql-handle) ; HSTMT hstmt
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
(def-function "SQLExecDirect"
((hstmt sql-handle) ; HSTMT hstmt
- (*szSqlStr string-ptr) ; UCHAR FAR *szSqlStr
+ (*szSqlStr :cstring) ; UCHAR FAR *szSqlStr
(cbSqlStr :long) ; SDWORD cbSqlStr
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
(def-function "SQLFreeStmt"
((hstmt sql-handle) ; HSTMT hstmt
(fOption :short)) ; UWORD fOption
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
(def-function "SQLCancel"
((hstmt sql-handle) ; HSTMT hstmt
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
(def-function "SQLError"
(cbErrorMsgMax :short) ; SWORD cbErrorMsgMax
(*pcbErrorMsg :pointer-void) ; SWORD FAR *pcbErrorMsg
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
(def-function "SQLNumResultCols"
((hstmt sql-handle) ; HSTMT hstmt
(*pccol :pointer-void) ; SWORD FAR *pccol
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
(def-function "SQLRowCount"
((hstmt sql-handle) ; HSTMT hstmt
(*pcrow :pointer-void) ; SDWORD FAR *pcrow
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
(def-function "SQLDescribeCol"
(*pibScale :pointer-void) ; SWORD FAR *pibScale
(*pfNullable :pointer-void) ; SWORD FAR *pfNullable
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
(def-function "SQLColAttributes"
((hstmt sql-handle) ; HSTMT hstmt
(icol :short) ; UWORD icol
(fDescType :short) ; UWORD fDescType
- (rgbDesc :pointer-void) ; PTR rgbDesc
+ (rgbDesc :cstring) ; PTR rgbDesc
(cbDescMax :short) ; SWORD cbDescMax
- (*pcbDesc :pointer-void) ; SWORD FAR *pcbDesc
+ (*pcbDesc :cstring) ; SWORD FAR *pcbDesc
(*pfDesc :pointer-void) ; SDWORD FAR *pfDesc
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
(def-function "SQLColumns"
((hstmt sql-handle) ; HSTMT hstmt
- (*szTableQualifier string-ptr) ; UCHAR FAR *szTableQualifier
+ (*szTableQualifier :cstring) ; UCHAR FAR *szTableQualifier
(cbTableQualifier :short) ; SWORD cbTableQualifier
- (*szTableOwner string-ptr) ; UCHAR FAR *szTableOwner
+ (*szTableOwner :cstring) ; UCHAR FAR *szTableOwner
(cbTableOwner :short) ; SWORD cbTableOwner
- (*szTableName string-ptr) ; UCHAR FAR *szTableName
+ (*szTableName :cstring) ; UCHAR FAR *szTableName
(cbTableName :short) ; SWORD cbTableName
- (*szColumnName string-ptr) ; UCHAR FAR *szColumnName
+ (*szColumnName :cstring) ; UCHAR FAR *szColumnName
(cbColumnName :short) ; SWORD cbColumnName
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
(def-function "SQLBindCol"
(cbValueMax :long) ; SDWORD cbValueMax
(*pcbValue :pointer-void) ; SDWORD FAR *pcbValue
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
(def-function "SQLFetch"
((hstmt sql-handle) ; HSTMT hstmt
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
(def-function "SQLTransact"
(hdbc sql-handle) ; HDBC hdbc
(fType :short) ; UWORD fType ($SQL_COMMIT or $SQL_ROLLBACK)
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
;; ODBC 2.0
(*pibScale :pointer-void) ; SWORD FAR *pibScale
(*pfNullable :pointer-void) ; SWORD FAR *pfNullable
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
;; ODBC 2.0
(cbValueMax :long) ; SDWORD cbValueMax
(*pcbValue :pointer-void) ; SDWORD FAR *pcbValue
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
;; level 1
(cbValueMax :long) ; SDWORD cbValueMax
(*pcbValue :pointer-void) ; SDWORD FAR *pcbValue
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
(def-function "SQLParamData"
((hstmt sql-handle) ; HSTMT hstmt
(*prgbValue :pointer-void) ; PTR FAR *prgbValue
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
(def-function "SQLPutData"
(rgbValue :pointer-void) ; PTR rgbValue
(cbValue :long) ; SDWORD cbValue
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
(def-function "SQLGetConnectOption"
(fOption :short) ; UWORD fOption
(pvParam :pointer-void) ; PTR pvParam
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
(def-function "SQLSetConnectOption"
(fOption :short) ; UWORD fOption
(vParam :long) ; UDWORD vParam
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
(def-function "SQLSetPos"
(fOption :short) ; UWORD fOption
(fLock :short) ; UWORD fLock
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
; level 2
(*pcrow :pointer-void) ; UDWORD FAR *pcrow
(*rgfRowStatus :pointer-void) ; UWORD FAR *rgfRowStatus
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
(def-function "SQLDataSources"
(cbDescriptionMax :short) ; SWORD cbDescriptionMax
(*pcbDescription :pointer-void) ; SWORD *pcbDescription
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
(def-function "SQLFreeEnv"
((henv sql-handle) ; HSTMT hstmt
)
- :module :odbc
+ :module "odbc"
:returning :short) ; RETCODE_SQL_API
(second :short)
(fraction :long))
+
+;;; Added by KMR
+
+(def-function "SQLSetEnvAttr"
+ ((henv sql-handle) ; HENV henv
+ (attr :int)
+ (*value :pointer-void)
+ (szLength :int))
+ :module "odbc"
+ :returning :int)
+
+(def-function "SQLTables"
+ ((hstmt :pointer-void)
+ (catalog-name :pointer-void)
+ (catalog-name-length :short)
+ (schema-name :pointer-void)
+ (schema-name-length :short)
+ (table-name :pointer-void)
+ (table-name-length :short)
+ (table-type-name :pointer-void)
+ (table-type-name-length :short))
+ :returning :short)
+
+
*odbc-library-loaded*)
(defmethod clsql-base-sys:database-type-load-foreign ((database-type (eql :odbc)))
- (uffi:load-foreign-library *odbc-library-path*)
+ (uffi:load-foreign-library *odbc-library-path*
+ :module "odbc")
(setq *odbc-library-loaded* t))
(clsql-base-sys:database-type-load-foreign :odbc)
#:database-library-loaded
#:*null*
- #:*trace-sql*
+ #:+null-ptr+
#:+max-precision+
+ #:*info-output*
#:get-cast-long
#:%free-statement
#:%disconnect
#:%sql-connect
#:disable-autocommit
#:enable-autocommit
- #:%null-ptr
#:%sql-free-environment
#:%sql-data-sources
#:%sql-get-info
#:%sql-exec-direct
#:%put-str
#:result-columns-count
+ #:result-rows-count
#:sql-to-c-type
+ #:%list-tables
)
(:documentation "This is the low-level interface ODBC."))
;; ODBC interface
(defclass odbc-database (database)
- ((odbc-conn :accessor database-odbc-conn :initarg :odbc-conn)))
+ ((odbc-conn :accessor database-odbc-conn :initarg :odbc-conn)
+ (odbc-db-type :accessor database-odbc-db-type)))
(defmethod database-name-from-spec (connection-spec
(database-type (eql :odbc)))
(check-connection-spec connection-spec database-type (dsn user password))
(destructuring-bind (dsn user password) connection-spec
(handler-case
- (make-instance 'odbc-database
- :name (database-name-from-spec connection-spec :odbc)
- :odbc-conn
- (odbc-dbi:connect :user user
- :password password
- :data-source-name dsn))
- (error () ;; Init or Connect failed
- (error 'clsql-connect-error
- :database-type database-type
- :connection-spec connection-spec
- :errno nil
- :error "Connection failed")))))
-
-#+nil
+ (let ((db
+ (make-instance 'odbc-database
+ :name (database-name-from-spec connection-spec :odbc)
+ :database-type :odbc
+ :odbc-conn
+ (odbc-dbi:connect :user user
+ :password password
+ :data-source-name dsn))))
+ (store-type-of-connected-database db)
+ db)
+ (clsql-error (e)
+ (error e))
+ (error () ;; Init or Connect failed
+ (error 'clsql-connect-error
+ :database-type database-type
+ :connection-spec connection-spec
+ :errno nil
+ :error "Connection failed")))))
+
(defun store-type-of-connected-database (db)
- (let* ((odbc-db (odbc-db db))
- (server-name (get-odbc-info odbc-db odbc::$SQL_SERVER_NAME))
- (dbms-name (get-odbc-info odbc-db odbc::$SQL_DBMS_NAME))
+ (let* ((odbc-conn (database-odbc-conn db))
+ (server-name (odbc-dbi::get-odbc-info odbc-conn odbc::$SQL_SERVER_NAME))
+ (dbms-name (odbc-dbi::get-odbc-info odbc-conn odbc::$SQL_DBMS_NAME))
(type
;; need SERVER-NAME and DBMS-NAME because many drivers mix this up
(cond
((or (search "oracle" server-name :test #'char-equal)
(search "oracle" dbms-name :test #'char-equal))
:oracle))))
- (setf (database-type db) type)))
+ (setf (database-odbc-db-type db) type)))
-
(defmethod database-disconnect ((database odbc-database))
(odbc-dbi:disconnect (database-odbc-conn database))
(setf (database-odbc-conn database) nil)
result-types)
(handler-case
(odbc-dbi:sql query-expression :db (database-odbc-conn database)
- :query t :result-types result-types)
+ :result-types result-types)
+ (clsql-error (e)
+ (error e))
+ #+ignore
(error ()
(error 'clsql-sql-error
:database database
(defmethod database-execute-command (sql-expression
(database odbc-database))
(handler-case
- (odbc-dbi:sql sql-expression (database-odbc-conn database))
+ (odbc-dbi:sql sql-expression :db (database-odbc-conn database))
+ (clsql-error (e)
+ (error e))
(error ()
(error 'clsql-sql-error
:database database
(defstruct odbc-result-set
(query nil)
- (types nil :type cons)
+ (types nil)
(full-set nil :type boolean))
(defmethod database-query-result-set ((query-expression string)
:row-count nil
:column-names t
:query t
- :result-types result-types
- )
+ :result-types result-types)
(values
(make-odbc-result-set :query query :full-set full-set
:types result-types)
(let ((table-name (%sequence-name-to-table sequence-name)))
(database-execute-command
(concatenate 'string "CREATE TABLE " table-name
- " (id int NOT NULL PRIMARY KEY AUTO_INCREMENT)")
+ " (last_value int NOT NULL PRIMARY KEY, increment_by int, min_value int, is_called char(1))")
database)
(database-execute-command
(concatenate 'string "INSERT INTO " table-name
- " VALUES (0)")
+ " VALUES (1,1,1,'f')")
database)))
(defmethod database-drop-sequence (sequence-name
(database-query "SHOW TABLES LIKE '%clsql_seq%'"
database nil)))
+(defmethod database-list-tables ((database odbc-database)
+ &key (owner nil))
+ (declare (ignore owner))
+ (multiple-value-bind (rows col-names)
+ (odbc-dbi:list-all-database-tables :db (database-odbc-conn database))
+ (let ((pos (position "TABLE_NAME" col-names :test #'string-equal)))
+ (when pos
+ (loop for row in rows
+ collect (nth pos row))))))
+
+(defmethod database-list-attributes ((table string) (database odbc-database)
+ &key (owner nil))
+ (declare (ignore owner))
+ (multiple-value-bind (rows col-names)
+ (odbc-dbi:list-all-table-columns table :db (database-odbc-conn database))
+ (let ((pos (position "COLUMN_NAME" col-names :test #'string-equal)))
+ (when pos
+ (loop for row in rows
+ collect (nth pos row))))))
+
+(defmethod database-attribute-type ((attribute string) (table string) (database odbc-database)
+ &key (owner nil))
+ (declare (ignore owner))
+ (multiple-value-bind (rows col-names)
+ (odbc-dbi:list-all-table-columns table :db (database-odbc-conn database))
+ (let ((pos (position "TYPE_NAME" col-names :test #'string-equal)))
+ (when pos
+ (loop for row in rows
+ collect (nth pos row))))))
+
(defmethod database-set-sequence-position (sequence-name
(position integer)
(database odbc-database))
(database-execute-command
- (format nil "UPDATE ~A SET id=~A" (%sequence-name-to-table sequence-name)
+ (format nil "UPDATE ~A SET last_value=~A,is_called='t'"
+ (%sequence-name-to-table sequence-name)
position)
database)
position)
(defmethod database-sequence-next (sequence-name (database odbc-database))
- (warn "Not implemented."))
-
+ (without-interrupts
+ (let* ((table-name (%sequence-name-to-table sequence-name))
+ (tuple
+ (car (database-query
+ (concatenate 'string "SELECT last_value,is_called FROM "
+ table-name)
+ database
+ :auto))))
+ (cond
+ ((char-equal (schar (second tuple) 0) #\f)
+ (database-execute-command
+ (format nil "UPDATE ~A SET is_called='t'" table-name)
+ database)
+ (car tuple))
+ (t
+ (let ((new-pos (1+ (car tuple))))
+ (database-execute-command
+ (format nil "UPDATE ~A SET last_value=~D" table-name new-pos)
+ database)
+ new-pos))))))
+
(defmethod database-sequence-last (sequence-name (database odbc-database))
- (declare (ignore sequence-name)))
+ (without-interrupts
+ (caar (database-query
+ (concatenate 'string "SELECT last_value FROM "
+ (%sequence-name-to-table sequence-name))
+ database
+ :auto))))
(defmethod database-create (connection-spec (type (eql :odbc)))
(warn "Not implemented."))
-cl-sql (2.6.13-1) unstable; urgency=low
+cl-sql (2.7.0-1) unstable; urgency=low
* New upstream
- -- Kevin M. Rosenberg <kmr@debian.org> Tue, 13 Apr 2004 16:38:28 -0600
+ -- Kevin M. Rosenberg <kmr@debian.org> Thu, 15 Apr 2004 00:41:35 -0600
cl-sql (2.6.7-1) unstable; urgency=low
(test-table-row (list int float bigint str) nil type))
(do-query ((int float bigint str) "select * from test_clsql" :result-types :auto)
(test-table-row (list int float bigint str) :auto type))
- (drop-test-table db))
+ #+ignore (drop-test-table db))
(defun %test-basic-untyped (db type)
((eq types :auto)
(test (and (integerp int)
(typep float 'double-float)
- (or (eq db-type :aodbc) ;; aodbc doesn't handle bigint conversions
+ (or (eq db-type :aodbc) ;; aodbc considers bigints as strings
(integerp bigint))
(stringp str))
t
t
:fail-info
(format nil "Incorrect field type for row ~S (types nil)" row))
- (setq int (parse-integer int))
+ (when (stringp int)
+ (setq int (parse-integer int)))
(setq bigint (parse-integer bigint))
- (setq float (parse-double float)))
+ (when (stringp float)
+ (setq float (parse-double float))))
((listp types)
(error "NYI")
)
(unless (eq db-type :sqlite) ; SQLite is typeless.
(test (transform-float-1 int)
float
- :test #'eql
+ :test #'double-float-equal
:fail-info
(format nil "Wrong float value ~A for int ~A (row ~S)" float int row)))
(test float
(defvar *rt-ooddl*)
(defvar *rt-oodml*)
(defvar *rt-syntax*)
+(defvar *rt-time*)
(defvar *test-database-type* nil)
(defvar *test-database-user* nil)
(defparameter employee10 nil)
(defun test-initialise-database ()
- ;; Create the tables for our view classes
- (ignore-errors (clsql:drop-view-from-class 'employee))
- (ignore-errors (clsql:drop-view-from-class 'company))
+ ;; Remove the tables to support cases when destroy-database isn't supported, like odbc
+ (ignore-errors (clsql:drop-table "EMPLOYEE"))
+ (ignore-errors (clsql:drop-table "COMPANY"))
+ (ignore-errors (clsql:drop-table "FOO"))
(clsql:create-view-from-class 'employee)
(clsql:create-view-from-class 'company)
(ignore-errors (destroy-database spec :database-type db-type))
(ignore-errors (create-database spec :database-type db-type))
+ ;; Also manually delete the tables since destroy-database/create-database doesn't work on ODBC
+
(dolist (test (append *rt-connection* *rt-fddl* *rt-fdml*
*rt-ooddl* *rt-oodml* *rt-syntax*))
(eval test))
:type "config"))
(defvar +all-db-types+
- #-clisp '(:postgresql :postgresql-socket :sqlite :aodbc :mysql)
+ #-clisp '(:postgresql :postgresql-socket :sqlite :mysql :odbc :aodbc)
#+clisp '(:sqlite))
(defclass conn-specs ()
((aodbc-spec :accessor aodbc-spec :initform nil)
+ (odbc-spec :accessor odbc-spec :initform nil)
(mysql-spec :accessor mysql-spec :initform nil)
- (pgsql-spec :accessor postgresql-spec :initform nil)
- (pgsql-socket-spec :accessor postgresql-socket-spec :initform nil)
+ (postgresql-spec :accessor postgresql-spec :initform nil)
+ (postgresql-socket-spec :accessor postgresql-socket-spec :initform nil)
(sqlite-spec :accessor sqlite-spec :initform nil))
(:documentation "Connection specs for CLSQL testing"))
(with-open-file (stream path :direction :input)
(let ((config (read stream))
(specs (make-instance 'conn-specs)))
- (setf (aodbc-spec specs) (cadr (assoc :aodbc config)))
- (setf (mysql-spec specs) (cadr (assoc :mysql config)))
- (setf (postgresql-spec specs) (cadr (assoc :postgresql config)))
- (setf (postgresql-socket-spec specs)
- (cadr (assoc :postgresql-socket config)))
- (setf (sqlite-spec specs) (cadr (assoc :sqlite config)))
+ (dolist (db-type +all-db-types+)
+ (setf (slot-value specs (spec-fn db-type))
+ (cadr (assoc db-type config))))
specs))
(progn
(warn "CLSQL test config file ~S not found" path)
nil)))
+(defun spec-fn (db-type)
+ (intern (concatenate 'string (symbol-name db-type)
+ (symbol-name '#:-spec))
+ (find-package '#:clsql-tests)))
+
(defun db-type-spec (db-type specs)
- (let ((accessor (intern (concatenate 'string (symbol-name db-type)
- (symbol-name '#:-spec))
- (find-package '#:clsql-tests))))
- (funcall accessor specs)))
+ (funcall (spec-fn db-type) specs))
(defun db-type-ensure-system (db-type)
(unless (find-package (symbol-name db-type))
projects / clsql.git / commitdiff