of ODBC longs since this type can vary on 64-bit platforms depending
upon the compilation options of unixODBC.
11 May 2004 Kevin Rosenberg (kevin@rosenberg.net)
11 May 2004 Kevin Rosenberg (kevin@rosenberg.net)
+ * db-odbc/*.lisp: Add a layer of indirection to foreign-type
+ of ODBC longs since this type can vary on 64-bit platforms depending
+ upon the compilation options of unixODBC.
* db-mysql/mysql-api.lisp: Fix int vs. long slots in foreign
structures found by testing with AllegroCL 7.0b AMD64.
* db-*/*-loader.lisp: Load 64-bit libraries on 64-bit platorms
* db-mysql/mysql-api.lisp: Fix int vs. long slots in foreign
structures found by testing with AllegroCL 7.0b AMD64.
* db-*/*-loader.lisp: Load 64-bit libraries on 64-bit platorms
((:file "odbc-package")
(:file "odbc-loader" :depends-on ("odbc-package"))
(:file "odbc-constants" :depends-on ("odbc-loader"))
((:file "odbc-package")
(:file "odbc-loader" :depends-on ("odbc-package"))
(:file "odbc-constants" :depends-on ("odbc-loader"))
- (:file "odbc-ff-interface" :depends-on ("odbc-loader"))
+ (:file "odbc-ff-interface" :depends-on ("odbc-constants"))
(:file "odbc-api" :depends-on ("odbc-ff-interface" "odbc-constants"))
(:file "odbc-dbi" :depends-on ("odbc-api"))
(:file "odbc-sql" :depends-on ("odbc-dbi"))))))
(:file "odbc-api" :depends-on ("odbc-ff-interface" "odbc-constants"))
(:file "odbc-dbi" :depends-on ("odbc-api"))
(:file "odbc-sql" :depends-on ("odbc-dbi"))))))
(defun handle-error (henv hdbc hstmt)
(let ((sql-state (allocate-foreign-string 256))
(error-message (allocate-foreign-string #.$SQL_MAX_MESSAGE_LENGTH)))
(defun handle-error (henv hdbc hstmt)
(let ((sql-state (allocate-foreign-string 256))
(error-message (allocate-foreign-string #.$SQL_MAX_MESSAGE_LENGTH)))
- (with-foreign-objects ((error-code :long)
+ (with-foreign-objects ((error-code #.$ODBC-LONG-TYPE)
(msg-length :short))
(SQLError henv hdbc hstmt sql-state
error-code error-message
(msg-length :short))
(SQLError henv hdbc hstmt sql-state
error-code error-message
err
state
(deref-pointer msg-length :short)
err
state
(deref-pointer msg-length :short)
- (deref-pointer error-code :long))))))
+ (deref-pointer error-code #.$ODBC-LONG-TYPE))))))
(defun sql-state (henv hdbc hstmt)
(let ((sql-state (allocate-foreign-string 256))
(error-message (allocate-foreign-string #.$SQL_MAX_MESSAGE_LENGTH)))
(defun sql-state (henv hdbc hstmt)
(let ((sql-state (allocate-foreign-string 256))
(error-message (allocate-foreign-string #.$SQL_MAX_MESSAGE_LENGTH)))
- (with-foreign-objects ((error-code :long)
+ (with-foreign-objects ((error-code #.$ODBC-LONG-TYPE)
(msg-length :short))
(SQLError henv hdbc hstmt sql-state error-code
error-message #.$SQL_MAX_MESSAGE_LENGTH msg-length)
(msg-length :short))
(SQLError henv hdbc hstmt sql-state error-code
error-message #.$SQL_MAX_MESSAGE_LENGTH msg-length)
(SQLFetch hstmt)))
(defun %new-statement-handle (hdbc)
(SQLFetch hstmt)))
(defun %new-statement-handle (hdbc)
- (with-foreign-object (hstmt-ptr 'sql-handle)
- (with-error-handling
- (:hdbc hdbc)
- (SQLAllocStmt hdbc hstmt-ptr)
- (deref-pointer hstmt-ptr 'sql-handle))))
-
+ (let ((statement-handle
+ (with-foreign-object (hstmt-ptr 'sql-handle)
+ (with-error-handling
+ (:hdbc hdbc)
+ (SQLAllocStmt hdbc hstmt-ptr)
+ (deref-pointer hstmt-ptr 'sql-handle)))))
+ (if (uffi:null-pointer-p statement-handle)
+ (error "Received null statement handle.")
+ statement-handle)))
+
(defun %sql-get-info (hdbc info-type)
(ecase info-type
;; those return string
(defun %sql-get-info (hdbc info-type)
(ecase info-type
;; those return string
#.$SQL_TIMEDATE_FUNCTIONS
#.$SQL_TXN_ISOLATION_OPTION
#.$SQL_UNION)
#.$SQL_TIMEDATE_FUNCTIONS
#.$SQL_TXN_ISOLATION_OPTION
#.$SQL_UNION)
- (with-foreign-objects ((info-ptr :long)
+ (with-foreign-objects ((info-ptr #.$ODBC-LONG-TYPE)
(info-length-ptr :short))
(with-error-handling
(:hdbc hdbc)
(info-length-ptr :short))
(with-error-handling
(:hdbc hdbc)
info-ptr
255
info-length-ptr)
info-ptr
255
info-length-ptr)
- (deref-pointer info-ptr :long)))
+ (deref-pointer info-ptr #.$ODBC-LONG-TYPE)))
)
;; those returning a long integer
((#.$SQL_DEFAULT_TXN_ISOLATION
)
;; those returning a long integer
((#.$SQL_DEFAULT_TXN_ISOLATION
#.$SQL_MAX_CHAR_LITERAL_LEN
#.$SQL_ACTIVE_ENVIRONMENTS
)
#.$SQL_MAX_CHAR_LITERAL_LEN
#.$SQL_ACTIVE_ENVIRONMENTS
)
- (with-foreign-objects ((info-ptr :long)
+ (with-foreign-objects ((info-ptr #.$ODBC-LONG-TYPE)
(info-length-ptr :short))
(with-error-handling
(:hdbc hdbc)
(SQLGetInfo hdbc info-type info-ptr 255 info-length-ptr)
(info-length-ptr :short))
(with-error-handling
(:hdbc hdbc)
(SQLGetInfo hdbc info-type info-ptr 255 info-length-ptr)
- (deref-pointer info-ptr :long))))))
+ (deref-pointer info-ptr #.$ODBC-LONG-TYPE))))))
(defun %sql-exec-direct (sql hstmt henv hdbc)
(with-cstring (sql-ptr sql)
(defun %sql-exec-direct (sql hstmt henv hdbc)
(with-cstring (sql-ptr sql)
(deref-pointer columns-nr-ptr :short))))
(defun result-rows-count (hstmt)
(deref-pointer columns-nr-ptr :short))))
(defun result-rows-count (hstmt)
- (with-foreign-objects ((row-count-ptr :long))
+ (with-foreign-objects ((row-count-ptr #.$ODBC-LONG-TYPE))
(with-error-handling (:hstmt hstmt)
(SQLRowCount hstmt row-count-ptr)
(with-error-handling (:hstmt hstmt)
(SQLRowCount hstmt row-count-ptr)
- (deref-pointer row-count-ptr :long))))
+ (deref-pointer row-count-ptr #.$ODBC-LONG-TYPE))))
;; column counting is 1-based
(defun %describe-column (hstmt column-nr)
(let ((column-name-ptr (allocate-foreign-string 256)))
(with-foreign-objects ((column-name-length-ptr :short)
(column-sql-type-ptr :short)
;; column counting is 1-based
(defun %describe-column (hstmt column-nr)
(let ((column-name-ptr (allocate-foreign-string 256)))
(with-foreign-objects ((column-name-length-ptr :short)
(column-sql-type-ptr :short)
- (column-precision-ptr :unsigned-long)
+ (column-precision-ptr #.$ODBC-ULONG-TYPE)
(column-scale-ptr :short)
(column-nullable-p-ptr :short))
(with-error-handling (:hstmt hstmt)
(column-scale-ptr :short)
(column-nullable-p-ptr :short))
(with-error-handling (:hstmt hstmt)
(values
column-name
(deref-pointer column-sql-type-ptr :short)
(values
column-name
(deref-pointer column-sql-type-ptr :short)
- (deref-pointer column-precision-ptr :unsigned-long)
+ (deref-pointer column-precision-ptr #.$ODBC-ULONG-TYPE)
(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-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)
- (column-precision-ptr :unsigned-long)
+ (column-precision-ptr #.$ODBC-ULONG-TYPE)
(column-scale-ptr :short)
(column-nullable-p-ptr :short))
(with-error-handling
(column-scale-ptr :short)
(column-nullable-p-ptr :short))
(with-error-handling
column-nullable-p-ptr)
(values
(deref-pointer column-sql-type-ptr :short)
column-nullable-p-ptr)
(values
(deref-pointer column-sql-type-ptr :short)
- (deref-pointer column-precision-ptr :unsigned-long)
+ (deref-pointer column-precision-ptr #.$ODBC-ULONG-TYPE)
(deref-pointer column-scale-ptr :short)
(deref-pointer column-nullable-p-ptr :short)))))
(defun %column-attributes (hstmt column-nr descriptor-type)
(let ((descriptor-info-ptr (allocate-foreign-string 256)))
(with-foreign-objects ((descriptor-length-ptr :short)
(deref-pointer column-scale-ptr :short)
(deref-pointer column-nullable-p-ptr :short)))))
(defun %column-attributes (hstmt column-nr descriptor-type)
(let ((descriptor-info-ptr (allocate-foreign-string 256)))
(with-foreign-objects ((descriptor-length-ptr :short)
- (numeric-descriptor-ptr :long))
+ (numeric-descriptor-ptr #.$ODBC-LONG-TYPE))
(with-error-handling
(:hstmt hstmt)
(SQLColAttributes hstmt column-nr descriptor-type descriptor-info-ptr
(with-error-handling
(:hstmt hstmt)
(SQLColAttributes hstmt column-nr descriptor-type descriptor-info-ptr
(free-foreign-object descriptor-info-ptr)
(values
desc
(free-foreign-object descriptor-info-ptr)
(values
desc
- (deref-pointer numeric-descriptor-ptr :long)))))))
+ (deref-pointer numeric-descriptor-ptr #.$ODBC-LONG-TYPE)))))))
(defun %prepare-describe-columns (hstmt table-qualifier table-owner
table-name column-name)
(defun %prepare-describe-columns (hstmt table-qualifier table-owner
table-name column-name)
(def-type byte-pointer-type '(* :byte))
(def-type short-pointer-type '(* :short))
(def-type int-pointer-type '(* :int))
(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 long-pointer-type '(* #.$ODBC-LONG-TYPE))
(def-type float-pointer-type '(* :float))
(def-type double-pointer-type '(* :double))
(def-type string-pointer-type '(* :unsigned-char))
(def-type float-pointer-type '(* :float))
(def-type double-pointer-type '(* :double))
(def-type string-pointer-type '(* :unsigned-char))
(defun get-cast-long (ptr)
(locally (declare (type long-pointer-type ptr))
(defun get-cast-long (ptr)
(locally (declare (type long-pointer-type ptr))
- (deref-pointer ptr :long)))
+ (deref-pointer ptr #.$ODBC-LONG-TYPE)))
(defun get-cast-single-float (ptr)
(locally (declare (type float-pointer-type ptr))
(defun get-cast-single-float (ptr)
(locally (declare (type float-pointer-type ptr))
(defun read-data (data-ptr c-type sql-type out-len-ptr result-type)
(declare (type long-ptr-type out-len-ptr))
(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))
+ (let* ((out-len (deref-pointer out-len-ptr #.$ODBC-LONG-TYPE))
(value
(cond ((= out-len $SQL_NULL_DATA)
*null*)
(value
(cond ((= out-len $SQL_NULL_DATA)
*null*)
(long-p (= size +max-precision+))
(data-ptr
(case c-type ;; add more?
(long-p (= size +max-precision+))
(data-ptr
(case c-type ;; add more?
- (#.$SQL_C_SLONG (uffi:allocate-foreign-object :long))
+ (#.$SQL_C_SLONG (uffi:allocate-foreign-object #.$ODBC-LONG-TYPE))
(#.$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))
(#.$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))
(break "SQL type is ~A, precision ~D, size ~D, C type is ~A"
sql-type precision size c-type))
(uffi:allocate-foreign-object :byte (1+ size)))))
(break "SQL type is ~A, precision ~D, size ~D, C type is ~A"
sql-type precision size c-type))
(uffi:allocate-foreign-object :byte (1+ size)))))
- (out-len-ptr (uffi:allocate-foreign-object :long)))
+ (out-len-ptr (uffi:allocate-foreign-object #.$ODBC-LONG-TYPE)))
(values c-type data-ptr out-len-ptr size long-p)))
(defun fetch-all-rows (hstmt &key free-option flatp)
(values c-type data-ptr out-len-ptr size long-p)))
(defun fetch-all-rows (hstmt &key free-option flatp)
;; depending on option, we return a long int or a string; string not implemented
(defun get-connection-option (hdbc option)
;; depending on option, we return a long int or a string; string not implemented
(defun get-connection-option (hdbc option)
- (with-foreign-object (param-ptr :long)
+ (with-foreign-object (param-ptr #.$ODBC-LONG-TYPE)
(with-error-handling (:hdbc hdbc)
(SQLGetConnectOption hdbc option param-ptr)
(with-error-handling (:hdbc hdbc)
(SQLGetConnectOption hdbc option param-ptr)
- (deref-pointer param-ptr :long))))
+ (deref-pointer param-ptr #.$ODBC-LONG-TYPE))))
(defun set-connection-option (hdbc option param)
(with-error-handling (:hdbc hdbc)
(defun set-connection-option (hdbc option param)
(with-error-handling (:hdbc hdbc)
(SQLSetPos hstmt row option lock)))
(defun %sql-extended-fetch (hstmt fetch-type row)
(SQLSetPos hstmt row option lock)))
(defun %sql-extended-fetch (hstmt fetch-type row)
- (with-foreign-objects ((row-count-ptr :unsigned-long)
+ (with-foreign-objects ((row-count-ptr #.$ODBC-ULONG-TYPE)
(row-status-ptr :short))
(with-error-handling (:hstmt hstmt)
(SQLExtendedFetch hstmt fetch-type row row-count-ptr
row-status-ptr)
(row-status-ptr :short))
(with-error-handling (:hstmt hstmt)
(SQLExtendedFetch hstmt fetch-type row row-count-ptr
row-status-ptr)
- (values (deref-pointer row-count-ptr :unsigned-long)
+ (values (deref-pointer row-count-ptr #.$ODBC-ULONG-TYPE)
(deref-pointer row-status-ptr :short)))))
; column-nr is zero-based
(deref-pointer row-status-ptr :short)))))
; column-nr is zero-based
(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))
(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))
+ (out-len (deref-pointer out-len-ptr #.$ODBC-LONG-TYPE))
(offset 0))
(case out-len
(#.$SQL_NULL_DATA
(offset 0))
(case out-len
(#.$SQL_NULL_DATA
"01004"))
do (setf res (%sql-get-data hstmt column-nr c-type data-ptr
+max-precision+ out-len-ptr)
"01004"))
do (setf res (%sql-get-data hstmt column-nr c-type data-ptr
+max-precision+ out-len-ptr)
- out-len (deref-pointer out-len-ptr :long)))
+ out-len (deref-pointer out-len-ptr #.$ODBC-LONG-TYPE)))
(if (= sql-type $SQL_DECIMAL)
(let ((*read-base* 10))
(read-from-string str))
(if (= sql-type $SQL_DECIMAL)
(let ((*read-base* 10))
(read-from-string str))
+;; on SuSE AMD64 9.0, unixODBC is compiled with with SQLLEN being 4 bytes long
+(defconstant $ODBC-LONG-TYPE :int)
+(defconstant $ODBC-ULONG-TYPE :unsigned-int)
+
(defconstant $ODBCVER #x0210)
;; generally useful constants
(defconstant $ODBCVER #x0210)
;; generally useful constants
(ecase sql-type
((#.odbc::$SQL_CHAR #.odbc::$SQL_VARCHAR #.odbc::$SQL_LONGVARCHAR) :string)
((#.odbc::$SQL_NUMERIC #.odbc::$SQL_DECIMAL #.odbc::$SQL_BIGINT) :string) ; ??
(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_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)
(#.odbc::$SQL_DATE 'sql-c-date)
(#.odbc::$SQL_TIME 'sql-c-time)
(#.odbc::$SQL_TIMESTAMP 'sql-c-timestamp)
(def-foreign-type sql-handle :pointer-void)
(def-foreign-type sql-handle-ptr '(* sql-handle))
(def-foreign-type string-ptr '(* :unsigned-char))
(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 '(* :int))
+(def-type long-ptr-type '(* #.$ODBC-LONG-TYPE))
(def-function "SQLAllocEnv"
(def-function "SQLAllocEnv"
(values (nreverse test-forms) (nreverse skip-tests))))
(values (nreverse test-forms) (nreverse skip-tests))))
+(defun rapid-load (type)
"Rapid load for interactive testing."
(when *default-database*
(disconnect :database *default-database*))
"Rapid load for interactive testing."
(when *default-database*
(disconnect :database *default-database*))
- (test-connect-to-database :postgresql (car (postgresql-spec (read-specs))))
+ (test-connect-to-database type (car (db-type-spec type (read-specs))))
(test-initialise-database))
(test-initialise-database))
+(defun rl ()
+ (rapid-load :postgresql))
+
- "Rapid load for interactive testing."
- (when *default-database*
- (disconnect :database *default-database*))
- (test-connect-to-database :mysql (car (mysql-spec (read-specs))))
- (test-initialise-database))
+ (rapid-load :mysql))
+
+(defun rlo ()
+ (rapid-load :odbc))