+26 Nov 2005 Kevin Rosenberg <kevin@rosenberg.net>
+ * Version 3.5.0
+ * tests/test-init.lisp, tests/test-fddl.lisp, tests/test-fdml.lisp,
+ * db-odbc/odbc-api.lisp, db-odbc/odbc-ff-interface.lisp,
+ * db-odbc/odbc-package.lisp, db-odbc/odbc-constants.lisp
+ * db-odbc/odbc-dbi.lisp, db-odbc/odbc-sql.lisp
+ * sql/fddl.lisp, sql/generic-odbc.lisp, sql/db-interface.lisp
+ * sql/transaction.lisp, sql/package.lisp, sql/time.lisp
+ Commit patch from Dominic Robinson providing support for
+ Microsoft SQL Server
+ * doc/csql.lisp: Fix typo in slot name
+
24 Nov 2005 Kevin Rosenberg <kevin@rosenberg.net>
* Version 3.4.7
* sql/time.lisp: Commit patch from Aleksandar Bakic for
(SQLConnect hdbc server-ptr $SQL_NTS uid-ptr
$SQL_NTS pwd-ptr $SQL_NTS))))
+(defun %sql-driver-connect (hdbc connection-string completion window-handle)
+ (with-cstring (connection-ptr connection-string)
+ (let ((completed-connection-string (allocate-foreign-string $SQL_MAX_CONN_OUT)))
+ (unwind-protect
+ (with-foreign-object (completed-connection-length :short)
+ (with-error-handling
+ (:hdbc hdbc)
+ (SQLDriverConnect hdbc
+ window-handle
+ connection-ptr $SQL_NTS
+ completed-connection-string $SQL_MAX_CONN_OUT
+ completed-connection-length
+ completion)))
+ (free-foreign-object completed-connection-string)))))
(defun %disconnect (hdbc)
(with-error-handling
(defun sql-to-c-type (sql-type)
(ecase sql-type
((#.$SQL_CHAR #.$SQL_VARCHAR #.$SQL_LONGVARCHAR
- #.$SQL_NUMERIC #.$SQL_DECIMAL #.$SQL_BIGINT -8 -9) $SQL_C_CHAR)
+ #.$SQL_NUMERIC #.$SQL_DECIMAL #.$SQL_BIGINT -8 -9 -10) $SQL_C_CHAR) ;; Added -10 for MSSQL ntext type
(#.$SQL_INTEGER $SQL_C_SLONG)
(#.$SQL_SMALLINT $SQL_C_SSHORT)
(#.$SQL_DOUBLE $SQL_C_DOUBLE)
(defun read-data-in-chunks (hstmt column-nr data-ptr c-type sql-type
out-len-ptr result-type)
- (declare (type long-ptr-type out-len-ptr))
+ (declare (type long-ptr-type out-len-ptr)
+ (ignore result-type))
(let* ((res (%sql-get-data hstmt column-nr c-type data-ptr
+max-precision+ out-len-ptr))
(out-len (deref-pointer out-len-ptr #.$ODBC-LONG-TYPE))
- (offset 0))
- (case out-len
- (#.$SQL_NULL_DATA
- (return-from read-data-in-chunks *null*))
- (#.$SQL_NO_TOTAL ;; don't know how long it is going to be
- (let ((str (make-array 0 :element-type 'character :adjustable t)))
- (loop do (if (= c-type #.$SQL_CHAR)
- (let ((data-length (foreign-string-length data-ptr)))
- (adjust-array str (+ offset data-length)
- :initial-element #\?)
- (setf offset (%cstring-into-vector
- data-ptr str
- offset
- data-length)))
- (error 'clsql:sql-database-error :message "wrong type. preliminary."))
- while (and (= res $SQL_SUCCESS_WITH_INFO)
- (equal (sql-state +null-handle-ptr+ +null-handle-ptr+ hstmt)
- "01004"))
- do (setf res (%sql-get-data hstmt column-nr c-type data-ptr
- +max-precision+ out-len-ptr)))
- (setf str (coerce str 'string))
- (if (= sql-type $SQL_DECIMAL)
- (let ((*read-base* 10))
- (read-from-string str))
- str)))
- (otherwise
- (let ((str (make-string out-len)))
- (loop do (if (= c-type #.$SQL_CHAR)
- (setf offset (%cstring-into-vector ;string
- data-ptr str
- offset
- (min out-len (1- +max-precision+))))
- (error 'clsql:sql-database-error :message "wrong type. preliminary."))
- while
- (and (= res $SQL_SUCCESS_WITH_INFO)
- #+ingore(eq (sql-state +null-handle-ptr+ +null-handle-ptr+ hstmt)
- $sql-data-truncated)
- (equal (sql-state +null-handle-ptr+ +null-handle-ptr+ hstmt)
- "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 #.$ODBC-LONG-TYPE)))
- (if (= sql-type $SQL_DECIMAL)
- (let ((*read-base* 10))
- (read-from-string str))
- str))))))
+ (offset 0)
+ (result (case out-len
+ (#.$SQL_NULL_DATA
+ (return-from read-data-in-chunks *null*))
+ (#.$SQL_NO_TOTAL ;; don't know how long it is going to be
+ (let ((str (make-array 0 :element-type 'character :adjustable t)))
+ (loop do (if (= c-type #.$SQL_CHAR)
+ (let ((data-length (foreign-string-length data-ptr)))
+ (adjust-array str (+ offset data-length)
+ :initial-element #\?)
+ (setf offset (%cstring-into-vector
+ data-ptr str
+ offset
+ data-length)))
+ (error 'clsql:sql-database-error :message "wrong type. preliminary."))
+ while (and (= res $SQL_SUCCESS_WITH_INFO)
+ (equal (sql-state +null-handle-ptr+ +null-handle-ptr+ hstmt)
+ "01004"))
+ do (setf res (%sql-get-data hstmt column-nr c-type data-ptr
+ +max-precision+ out-len-ptr)))
+ (setf str (coerce str 'string))
+ (if (= sql-type $SQL_DECIMAL)
+ (let ((*read-base* 10))
+ (read-from-string str))
+ str)))
+ (otherwise
+ (let ((str (make-string out-len)))
+ (loop do (if (= c-type #.$SQL_CHAR)
+ (setf offset (%cstring-into-vector ;string
+ data-ptr str
+ offset
+ (min out-len (1- +max-precision+))))
+ (error 'clsql:sql-database-error :message "wrong type. preliminary."))
+ while
+ (and (= res $SQL_SUCCESS_WITH_INFO)
+ #+ingore(eq (sql-state +null-handle-ptr+ +null-handle-ptr+ hstmt)
+ $sql-data-truncated)
+ (equal (sql-state +null-handle-ptr+ +null-handle-ptr+ hstmt)
+ "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 #.$ODBC-LONG-TYPE)))
+ (if (= sql-type $SQL_DECIMAL)
+ (let ((*read-base* 10))
+ (read-from-string str))
+ str))))))
+ (setf (deref-pointer out-len-ptr #.$ODBC-LONG-TYPE) #.$SQL_NO_TOTAL) ;; reset the out length for the next row
+ result))
(def-type c-timestamp-ptr-type (* (:struct sql-c-timestamp)))
(def-type c-time-ptr-type (* (:struct sql-c-time)))
(defconstant $SQL_DRIVER_PROMPT 2)
(defconstant $SQL_DRIVER_COMPLETE_REQUIRED 3)
+(defconstant $SQL_MAX_CONN_OUT 1024)
+
;; Level 2 Functions
;; SQLExtendedFetch "fFetchType" values
;;; AODBC Compatible interface
-(defun connect (&key data-source-name user password (autocommit t))
+(defun connect (&key data-source-name user password connection-string completion window-handle (autocommit t))
(let ((db (make-instance 'odbc-db)))
(unless (henv db) ;; has class allocation!
(setf (henv db) (%new-environment-handle)))
(setf (hdbc db) (%new-db-connection-handle (henv db)))
- (%sql-connect (hdbc db) data-source-name user password)
+ (if connection-string
+ (%sql-driver-connect (hdbc db)
+ connection-string
+ (ecase completion
+ (:no-prompt odbc::$SQL_DRIVER_NOPROMPT)
+ (:complete odbc::$SQL_DRIVER_COMPLETE)
+ (:prompt odbc::$SQL_DRIVER_PROMPT)
+ (:complete-required odbc::$SQL_DRIVER_COMPLETE_REQUIRED))
+ window-handle)
+ (%sql-connect (hdbc db) data-source-name user password))
#+ignore (setf (db-hstmt db) (%new-statement-handle (hdbc db)))
(when (/= (get-odbc-info db odbc::$SQL_TXN_CAPABLE) odbc::$SQL_TC_NONE)
(if autocommit
(defun list-all-table-columns (table &key db hstmt)
(declare (ignore hstmt))
- (db-describe-columns db "" "" table ""))
+ (db-describe-columns db nil nil table nil)) ;; use nil rather than "" for unspecified values
(defun list-all-data-sources ()
(let ((db (make-instance 'odbc-db)))
;; allocate space to bind result rows to
(multiple-value-bind (c-type data-ptr out-len-ptr size long-p)
(%allocate-bindings sql-type precision)
- (unless long-p ;; if long-p we fetch in chunks with %sql-get-data
+ (if long-p ;; if long-p we fetch in chunks with %sql-get-data but must ensure that out_len_ptr is non zero
+ (setf (uffi:deref-pointer out-len-ptr #.odbc::$ODBC-LONG-TYPE) #.odbc::$SQL_NO_TOTAL)
(%bind-column hstmt col-nr c-type data-ptr (1+ size) out-len-ptr))
(vector-push-extend name column-names)
(vector-push-extend sql-type column-sql-types)
(def-function "SQLDriverConnect"
((hdbc sql-handle) ; HDBC hdbc
(hwnd sql-handle) ; SQLHWND hwnd
- (*szConnStrIn string-ptr) ; UCHAR FAR *szConnStrIn
+ (*szConnStrIn :cstring) ; UCHAR FAR *szConnStrIn
(cbConnStrIn :short) ; SWORD cbConnStrIn
(*szConnStrOut string-ptr) ; UCHAR FAR *szConnStrOut
(cbConnStrOutMax :short) ; SWORD cbConnStrOutMax
#:%new-db-connection-handle
#:%new-environment-handle
#:%sql-connect
+ #:%sql-driver-connect
#:disable-autocommit
#:enable-autocommit
#:%sql-free-environment
(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
- (declare (ignore password))
+ (check-connection-spec connection-spec database-type (dsn user password &key connection-string completion window-handle))
+ (destructuring-bind (dsn user password &key connection-string completion window-handle) connection-spec
+ (declare (ignore password connection-string completion window-handle))
(concatenate 'string dsn "/" user)))
(defmethod database-connect (connection-spec (database-type (eql :odbc)))
- (check-connection-spec connection-spec database-type (dsn user password))
- (destructuring-bind (dsn user password) connection-spec
+ (check-connection-spec connection-spec database-type (dsn user password &key connection-string completion window-handle))
+ (destructuring-bind (dsn user password &key connection-string (completion :no-prompt) window-handle) connection-spec
(handler-case
(let ((db (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))))
+ :data-source-name dsn
+ :connection-string connection-string
+ :completion completion
+ :window-handle window-handle))))
(store-type-of-connected-database db)
;; Ensure this database type is initialized so can check capabilities of
;; underlying database
(unless (find-package 'clsql-postgresql)
(ignore-errors (asdf:operate 'asdf:load-op 'clsql-postgresql-socket)))
:postgresql)
+ ((or (search "Microsoft SQL Server" server-name :test #'char-equal)
+ (search "Microsoft SQL Server" dbms-name :test #'char-equal))
+ :mssql)
((or (search "mysql" server-name :test #'char-equal)
(search "mysql" dbms-name :test #'char-equal))
(unless (find-package 'clsql-mysql)
((null loop-rows) (nreverse results))
(let* ((row (car loop-rows))
(col (nth 5 row)))
- (unless (find col results :test #'string-equal)
+ (unless (or (null col) (find col results :test #'string-equal))
(push col results))))))
;;; Database capabilities
+cl-sql (3.5.0-1) unstable; urgency=low
+
+ * New upstream (closes: 339842)
+ * Change libmyclient run-time requirement (closes: 339824)
+
+ -- Kevin M. Rosenberg <kmr@debian.org> Sat, 26 Nov 2005 08:58:22 -0700
+
cl-sql (3.4.7-1) unstable; urgency=low
* New upstream
Section: devel
Priority: extra
Maintainer: Kevin M. Rosenberg <kmr@debian.org>
-Build-Depends: debhelper (>= 4.0.0), libmysqlclient14-dev | libmysqlclient15-dev, libpq-dev
+Build-Depends: debhelper (>= 4.0.0), libmysqlclient15-dev, libpq-dev
Build-Depends-Indep: debhelper (>= 4.0.0)
Standards-Version: 3.6.2.1
Package: cl-sql-mysql
Architecture: any
-Depends: cl-sql (>= ${Source-Version}), libmysqlclient14-dev | libmysqlclient15-dev, cl-sql-uffi (>= ${Source-Version})
+Depends: cl-sql (>= ${Source-Version}), libmysqlclient15, cl-sql-uffi (>= ${Source-Version})
Provides: cl-sql-backend
Description: CLSQL database backend, MySQL
This package enables you to use the CLSQL data access package
<listitem>
<para>
- <symbol>:column-</symbol> - A string which will be used as the
+ <symbol>:db-type</symbol> - A string which will be used as the
type specifier for this slots column definition in the database.
</para></listitem>
nil)
(:documentation "NIL [default] if database-type does not use column name on DROP INDEX."))
+(defgeneric db-type-use-fully-qualified-column-on-drop-index? (db-type)
+ (:method (db-type)
+ (declare (ignore db-type))
+ nil)
+ (:documentation "NIL [default] if database-type does not require fully qualified column name on DROP INDEX."))
+
(defgeneric db-type-has-views? (db-type)
(:method (db-type)
(declare (ignore db-type))
nil)
(:documentation "T if database backend supports prepared statements."))
+(defgeneric db-type-has-intersect? (db-type)
+ (:method (db-type)
+ (declare (ignore db-type))
+ t)
+ (:documentation "T [default] if database-type supports INTERSECT."))
+
+(defgeneric db-type-has-except? (db-type)
+ (:method (db-type)
+ (declare (ignore db-type))
+ t)
+ (:documentation "T [default] if database-type supports EXCEPT."))
;;; Large objects support (Marc Battyani)
(unless (index-exists-p index-name :database database)
(return-from drop-index)))
(:error t))
- (unless (db-type-use-column-on-drop-index?
- (database-underlying-type database))
- (setq on nil))
- (execute-command (format nil "DROP INDEX ~A~A" index-name
- (if (null on) ""
- (concatenate 'string " ON "
- (database-identifier on database))))
- :database database)))
+ (let* ((db-type (database-underlying-type database))
+ (index-identifier (cond ((db-type-use-fully-qualified-column-on-drop-index? db-type)
+ (format nil "~A.~A" (database-identifier on database) index-name))
+ ((db-type-use-column-on-drop-index? db-type)
+ (format nil "~A ON ~A" index-name (database-identifier on database)))
+ (t index-name))))
+ (execute-command (format nil "DROP INDEX ~A" index-identifier)
+ :database database))))
(defun list-indexes (&key (owner nil) (database *default-database*) (on nil))
"Returns a list of strings representing index names in DATABASE
(db-type (eql :postgresql)))
(if (string= "0" val) nil t))
-
+(defmethod read-sql-value (val (type (eql 'boolean)) database
+ (db-type (eql :mssql)))
+ (declare (ignore database))
+ (etypecase val
+ (string (if (string= "0" val) nil t))
+ (integer (if (zerop val) nil t))))
+
+(defmethod read-sql-value (val (type (eql 'generalized-boolean)) database
+ (db-type (eql :mssql)))
+ (declare (ignore database))
+ (etypecase val
+ (string (if (string= "0" val) nil t))
+ (integer (if (zerop val) nil t))))
+
+;;; Type methods
+
+(defmethod database-get-type-specifier ((type (eql 'wall-time)) args database
+ (db-type (eql :mssql)))
+ (declare (ignore args database))
+ "DATETIME")
+
+(defmethod database-get-type-specifier ((type (eql 'boolean)) args database
+ (db-type (eql :mssql)))
+ (declare (ignore args database))
+ "BIT")
+
+(defmethod database-get-type-specifier ((type (eql 'generalized-boolean)) args database
+ (db-type (eql :mssql)))
+ (declare (ignore args database))
+ "BIT")
+
+;;; Generation of SQL strings from lisp expressions
+
+(defmethod database-output-sql ((tee (eql t)) (database generic-odbc-database))
+ (case (database-underlying-type database)
+ (:mssql "1")
+ (t "'Y'")))
+
+(defmethod database-output-sql-as-type ((type (eql 'boolean)) val database
+ (db-type (eql :mssql)))
+ (declare (ignore database))
+ (if val 1 0))
+
+(defmethod database-output-sql-as-type ((type (eql 'generalized-boolean)) val database
+ (db-type (eql :mssql)))
+ (declare (ignore database))
+ (if val 1 0))
+
+;;; Database backend capabilities
+
+(defmethod db-type-use-fully-qualified-column-on-drop-index? ((db-type (eql :mssql)))
+ t)
+
+(defmethod db-type-has-boolean-where? ((db-type (eql :mssql)))
+ nil)
+
+(defmethod db-type-has-intersect? ((db-type (eql :mssql)))
+ nil)
+
+(defmethod db-type-has-except? ((db-type (eql :mssql)))
+ nil)
+
;;; Backend methods
(defmethod database-disconnect ((database generic-odbc-database))
(setf (odbc-conn database) nil)
t)
-(defmethod database-query (query-expression (database generic-odbc-database)
- result-types field-names)
+(defmethod database-query (query-expression (database generic-odbc-database)
+ result-types field-names)
(handler-case
(funcall (sql-fn database)
query-expression :db (odbc-conn database)
(defmethod database-query-result-set ((query-expression string)
- (database generic-odbc-database)
+ (database generic-odbc-database)
&key full-set result-types)
- (handler-case
+ (handler-case
(multiple-value-bind (query column-names)
(funcall (sql-fn database)
- query-expression
- :db (odbc-conn database)
+ query-expression
+ :db (odbc-conn database)
:row-count nil
:column-names t
:query t
:result-types result-types)
(values
- (make-odbc-result-set :query query :full-set full-set
+ (make-odbc-result-set :query query :full-set full-set
:types result-types)
(length column-names)
nil ;; not able to return number of rows with odbc
;; TABLE_NAME in third column, TABLE_TYPE in fourth column
(loop for row in rows
when (and (not (string-equal "information_schema" (nth 1 row)))
- (string-equal "TABLE" (nth 3 row)))
+ (string-equal "TABLE" (nth 3 row))
+ (not (and (eq :mssql (database-underlying-type database))
+ (string-equal "dtproperties" (nth 2 row)))))
collect (nth 2 row))))
;; TABLE_NAME in third column, TABLE_TYPE in fourth column
(loop for row in rows
when (and (not (string-equal "information_schema" (nth 1 row)))
- (string-equal "VIEW" (nth 3 row)))
+ (string-equal "VIEW" (nth 3 row))
+ (not (and (eq :mssql (database-underlying-type database))
+ (member (nth 2 row) '("sysconstraints" "syssegments") :test #'string-equal))))
collect (nth 2 row))))
#:db-type-has-fancy-math?
#:db-type-default-case
#:db-type-use-column-on-drop-index?
+ #:db-type-use-fully-qualified-column-on-drop-index?
+ #:db-type-has-intersect?
+ #:db-type-has-except?
#:database-underlying-type
#:database-get-type-specifier
#:read-sql-value
(char= #\. (char string 19))))
(multiple-value-bind (parsed-usec usec-end)
(parse-integer string :start 20 :junk-allowed t)
- (setf usec parsed-usec
+ (setf usec (or parsed-usec 0)
gmt-sec-offset (if (<= (+ 3 usec-end) strlen)
(let ((skip-to (or (position #\+ string :start 19)
(position #\- string :start 19))))
(setf (commit-hooks transaction) nil
(rollback-hooks transaction) nil
(transaction-status transaction) nil)
- (unless (eq :oracle (database-underlying-type database))
- (execute-command "BEGIN" :database database)))))
+ (case (database-underlying-type database)
+ (:oracle nil)
+ (:mssql (execute-command "BEGIN TRANSACTION" :database database))
+ (t (execute-command "BEGIN" :database database))))))
(defmethod database-commit-transaction ((database database))
(with-slots (transaction transaction-level autocommit) database
'(:postgresql :postgresql-socket))
:ignore
:warn)))
- (clsql:create-table [foo]
- '(([bar] integer :not-null :unique :primary-key)
- ([baz] string :not-null :unique))))
+ (case *test-database-underlying-type*
+ (:mssql (clsql:create-table [foo]
+ '(([bar] integer :not-null :primary-key)
+ ([baz] string :not-null :unique))))
+ (t (clsql:create-table [foo]
+ '(([bar] integer :not-null :unique :primary-key)
+ ([baz] string :not-null :unique))))))
(clsql:table-exists-p [foo]))
(progn
(clsql:drop-table [foo])
("Vlad" "Jose" "Leon" "Niki" "Leon" "Yuri" "Kons" "Mikh" "Bori" "Vlad"))
(deftest :fdml/select/22
- (clsql:select [|| [first-name] " " [last-name]] :from [employee]
- :flatp t :order-by [emplid] :field-names nil)
+ (case *test-database-underlying-type*
+ (:mssql (clsql:select [+ [first-name] " " [last-name]] :from [employee]
+ :flatp t :order-by [emplid] :field-names nil))
+ (t (clsql:select [|| [first-name] " " [last-name]] :from [employee]
+ :flatp t :order-by [emplid] :field-names nil)))
("Vladimir Lenin" "Josef Stalin" "Leon Trotsky" "Nikita Kruschev"
"Leonid Brezhnev" "Yuri Andropov" "Konstantin Chernenko" "Mikhail Gorbachev"
"Boris Yeltsin" "Vladimir Putin"))
'(:postgresql :oracle)))
(clsql-sys:in test :fddl/owner/1))
(push (cons test "table ownership not supported") skip-tests))
+ ((and (null (clsql-sys:db-type-has-intersect? db-underlying-type))
+ (clsql-sys:in test :fdml/query/7))
+ (push (cons test "intersect not supported") skip-tests))
+ ((and (null (clsql-sys:db-type-has-except? db-underlying-type))
+ (clsql-sys:in test :fdml/query/8))
+ (push (cons test "except not supported") skip-tests))
+ ((and (eq *test-database-underlying-type* :mssql)
+ (clsql-sys:in test :fdml/select/9))
+ (push (cons test "mssql uses integer math for AVG") skip-tests))
(t
(push test-form test-forms)))))
(values (nreverse test-forms) (nreverse skip-tests))))
projects / clsql.git / commitdiff