From d0f147d0e7d942b379bd7cd472f26b00c33916bc Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Thu, 15 Apr 2004 11:41:17 +0000 Subject: [PATCH] r9014: odbc backend now working on allegro and lispworks --- ChangeLog | 15 +- base/conditions.lisp | 10 + base/package.lisp | 4 +- base/utils.lisp | 2 +- db-aodbc/aodbc-sql.lisp | 45 ++- db-odbc/odbc-api.lisp | 489 +++++++++++++++++++-------------- db-odbc/odbc-constants.lisp | 14 +- db-odbc/odbc-dbi.lisp | 267 +++++++++++------- db-odbc/odbc-ff-interface.lisp | 117 ++++---- db-odbc/odbc-loader.lisp | 3 +- db-odbc/odbc-package.lisp | 6 +- db-odbc/odbc-sql.lisp | 126 ++++++--- debian/changelog | 4 +- tests/test-basic.lisp | 12 +- tests/test-init.lisp | 10 +- tests/utils.lisp | 26 +- 16 files changed, 720 insertions(+), 430 deletions(-) diff --git a/ChangeLog b/ChangeLog index 8e958a3..1ee7ac9 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,8 +1,17 @@ -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 diff --git a/base/conditions.lisp b/base/conditions.lisp index f6f7e7f..a84f654 100644 --- a/base/conditions.lisp +++ b/base/conditions.lisp @@ -151,6 +151,16 @@ and signal an clsql-invalid-spec-error if they don't match." (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 diff --git a/base/package.lisp b/base/package.lisp index 42789b3..e79dddb 100644 --- a/base/package.lisp +++ b/base/package.lisp @@ -112,7 +112,9 @@ #: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* diff --git a/base/utils.lisp b/base/utils.lisp index ae1a4b0..55f2bc9 100644 --- a/base/utils.lisp +++ b/base/utils.lisp @@ -68,7 +68,7 @@ (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)) diff --git a/db-aodbc/aodbc-sql.lisp b/db-aodbc/aodbc-sql.lisp index 4cd8a6e..0981591 100644 --- a/db-aodbc/aodbc-sql.lisp +++ b/db-aodbc/aodbc-sql.lisp @@ -53,10 +53,13 @@ (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 @@ -75,6 +78,8 @@ (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 @@ -87,6 +92,8 @@ #+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 @@ -118,6 +125,8 @@ (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 @@ -179,11 +188,45 @@ (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) diff --git a/db-odbc/odbc-api.lisp b/db-odbc/odbc-api.lisp index b5c1387..915de7e 100644 --- a/db-odbc/odbc-api.lisp +++ b/db-odbc/odbc-api.lisp @@ -2,9 +2,9 @@ ;;;; ************************************************************************* ;;;; 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 $ ;;;; @@ -18,9 +18,21 @@ (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)) @@ -31,42 +43,51 @@ (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)) @@ -79,32 +100,44 @@ (#.$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 @@ -112,11 +145,11 @@ (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 @@ -187,7 +220,7 @@ scale ;0 data-ptr max-value - out-len-ptr ;#.(%null-ptr) + out-len-ptr ;#.+null-ptr+ ))) (defun %sql-fetch (hstmt) @@ -196,11 +229,11 @@ (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 @@ -238,15 +271,14 @@ #.$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 @@ -392,26 +424,28 @@ ;; 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) @@ -432,18 +466,20 @@ (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) @@ -466,26 +502,30 @@ (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 @@ -493,8 +533,9 @@ #.$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) @@ -502,44 +543,45 @@ (#.$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)))) @@ -552,64 +594,72 @@ (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) @@ -630,8 +680,9 @@ (#.$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))) @@ -641,14 +692,14 @@ (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)) @@ -670,7 +721,7 @@ (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 @@ -686,7 +737,7 @@ (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 @@ -696,7 +747,7 @@ (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)) @@ -716,7 +767,7 @@ ;; 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)))) @@ -764,9 +815,8 @@ (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)) @@ -786,7 +836,7 @@ 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))) @@ -805,9 +855,9 @@ (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) @@ -817,7 +867,10 @@ (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) @@ -842,6 +895,7 @@ 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 @@ -854,6 +908,7 @@ 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) @@ -861,9 +916,21 @@ (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))) diff --git a/db-odbc/odbc-constants.lisp b/db-odbc/odbc-constants.lisp index 91b09c8..2f52d9d 100644 --- a/db-odbc/odbc-constants.lisp +++ b/db-odbc/odbc-constants.lisp @@ -4,7 +4,7 @@ ;;;; ;;;; 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 $ ;;;; @@ -23,7 +23,7 @@ ;; 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 @@ -671,11 +671,7 @@ (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 @@ -948,3 +944,9 @@ (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) + diff --git a/db-odbc/odbc-dbi.lisp b/db-odbc/odbc-dbi.lisp index 6e299d1..08a8df6 100644 --- a/db-odbc/odbc-dbi.lisp +++ b/db-odbc/odbc-dbi.lisp @@ -52,6 +52,8 @@ (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 @@ -67,8 +69,10 @@ ;; 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) @@ -98,13 +102,15 @@ "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)) @@ -119,43 +125,68 @@ the query against." )) (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))) @@ -184,7 +215,7 @@ the query against." )) 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 @@ -204,62 +235,68 @@ the query against." )) 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) @@ -269,7 +306,6 @@ the query against." )) (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))) @@ -279,19 +315,21 @@ the query against." )) "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 @@ -320,18 +358,21 @@ This makes the functions db-execute-command and db-query thread safe." (%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) @@ -354,7 +395,26 @@ This makes the functions db-execute-command and db-query thread safe." (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) @@ -384,23 +444,25 @@ This makes the functions db-execute-command and db-query thread safe." (%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 @@ -409,18 +471,18 @@ This makes the functions db-execute-command and db-query thread safe." (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 @@ -478,7 +540,7 @@ This makes the functions db-execute-command and db-query thread safe." (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) @@ -504,7 +566,7 @@ This makes the functions db-execute-command and db-query thread safe." 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 @@ -512,7 +574,7 @@ This makes the functions db-execute-command and db-query thread safe." 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))) @@ -520,8 +582,7 @@ This makes the functions db-execute-command and db-query thread safe." (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)) @@ -530,7 +591,7 @@ This makes the functions db-execute-command and db-query thread safe." (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) diff --git a/db-odbc/odbc-ff-interface.lisp b/db-odbc/odbc-ff-interface.lisp index 48bbe1c..6dd6997 100644 --- a/db-odbc/odbc-ff-interface.lisp +++ b/db-odbc/odbc-ff-interface.lisp @@ -18,36 +18,35 @@ (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" @@ -60,19 +59,19 @@ (*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" @@ -82,41 +81,41 @@ (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" @@ -129,21 +128,21 @@ (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" @@ -157,33 +156,33 @@ (*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" @@ -194,13 +193,13 @@ (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" @@ -208,7 +207,7 @@ (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 @@ -220,7 +219,7 @@ (*pibScale :pointer-void) ; SWORD FAR *pibScale (*pfNullable :pointer-void) ; SWORD FAR *pfNullable ) - :module :odbc + :module "odbc" :returning :short) ; RETCODE_SQL_API ;; ODBC 2.0 @@ -236,7 +235,7 @@ (cbValueMax :long) ; SDWORD cbValueMax (*pcbValue :pointer-void) ; SDWORD FAR *pcbValue ) - :module :odbc + :module "odbc" :returning :short) ; RETCODE_SQL_API ;; level 1 @@ -248,14 +247,14 @@ (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" @@ -263,7 +262,7 @@ (rgbValue :pointer-void) ; PTR rgbValue (cbValue :long) ; SDWORD cbValue ) - :module :odbc + :module "odbc" :returning :short) ; RETCODE_SQL_API (def-function "SQLGetConnectOption" @@ -271,7 +270,7 @@ (fOption :short) ; UWORD fOption (pvParam :pointer-void) ; PTR pvParam ) - :module :odbc + :module "odbc" :returning :short) ; RETCODE_SQL_API (def-function "SQLSetConnectOption" @@ -279,7 +278,7 @@ (fOption :short) ; UWORD fOption (vParam :long) ; UDWORD vParam ) - :module :odbc + :module "odbc" :returning :short) ; RETCODE_SQL_API (def-function "SQLSetPos" @@ -288,7 +287,7 @@ (fOption :short) ; UWORD fOption (fLock :short) ; UWORD fLock ) - :module :odbc + :module "odbc" :returning :short) ; RETCODE_SQL_API ; level 2 @@ -299,7 +298,7 @@ (*pcrow :pointer-void) ; UDWORD FAR *pcrow (*rgfRowStatus :pointer-void) ; UWORD FAR *rgfRowStatus ) - :module :odbc + :module "odbc" :returning :short) ; RETCODE_SQL_API (def-function "SQLDataSources" @@ -312,13 +311,13 @@ (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 @@ -347,3 +346,27 @@ (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) + + diff --git a/db-odbc/odbc-loader.lisp b/db-odbc/odbc-loader.lisp index 658da2e..ef14d47 100644 --- a/db-odbc/odbc-loader.lisp +++ b/db-odbc/odbc-loader.lisp @@ -41,7 +41,8 @@ set to the right path before compiling or loading the system.") *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) diff --git a/db-odbc/odbc-package.lisp b/db-odbc/odbc-package.lisp index ce96084..e70debe 100644 --- a/db-odbc/odbc-package.lisp +++ b/db-odbc/odbc-package.lisp @@ -24,8 +24,9 @@ #:database-library-loaded #:*null* - #:*trace-sql* + #:+null-ptr+ #:+max-precision+ + #:*info-output* #:get-cast-long #:%free-statement #:%disconnect @@ -39,7 +40,6 @@ #:%sql-connect #:disable-autocommit #:enable-autocommit - #:%null-ptr #:%sql-free-environment #:%sql-data-sources #:%sql-get-info @@ -60,7 +60,9 @@ #:%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.")) diff --git a/db-odbc/odbc-sql.lisp b/db-odbc/odbc-sql.lisp index c42d93c..1d39272 100644 --- a/db-odbc/odbc-sql.lisp +++ b/db-odbc/odbc-sql.lisp @@ -26,7 +26,8 @@ ;; 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))) @@ -39,24 +40,29 @@ (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 @@ -69,9 +75,8 @@ ((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) @@ -81,7 +86,10 @@ 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 @@ -92,7 +100,9 @@ (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 @@ -102,7 +112,7 @@ (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) @@ -115,8 +125,7 @@ :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) @@ -162,11 +171,11 @@ (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 @@ -182,20 +191,75 @@ (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.")) diff --git a/debian/changelog b/debian/changelog index 713b228..fe9c67b 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,8 +1,8 @@ -cl-sql (2.6.13-1) unstable; urgency=low +cl-sql (2.7.0-1) unstable; urgency=low * New upstream - -- Kevin M. Rosenberg Tue, 13 Apr 2004 16:38:28 -0600 + -- Kevin M. Rosenberg Thu, 15 Apr 2004 00:41:35 -0600 cl-sql (2.6.7-1) unstable; urgency=low diff --git a/tests/test-basic.lisp b/tests/test-basic.lisp index 7664720..556deb8 100644 --- a/tests/test-basic.lisp +++ b/tests/test-basic.lisp @@ -53,7 +53,7 @@ (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) @@ -113,7 +113,7 @@ ((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 @@ -127,9 +127,11 @@ 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") ) @@ -140,7 +142,7 @@ (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 diff --git a/tests/test-init.lisp b/tests/test-init.lisp index ae0c6b4..4fe9c2e 100644 --- a/tests/test-init.lisp +++ b/tests/test-init.lisp @@ -22,6 +22,7 @@ (defvar *rt-ooddl*) (defvar *rt-oodml*) (defvar *rt-syntax*) +(defvar *rt-time*) (defvar *test-database-type* nil) (defvar *test-database-user* nil) @@ -142,9 +143,10 @@ (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) @@ -319,6 +321,8 @@ (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)) diff --git a/tests/utils.lisp b/tests/utils.lisp index 27cbf94..bd51cb8 100644 --- a/tests/utils.lisp +++ b/tests/utils.lisp @@ -24,14 +24,15 @@ :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")) @@ -41,22 +42,21 @@ (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)) -- 2.34.1