r10845: 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

diff --git a/ChangeLog b/ChangeLog
index 4e2d6a2ee427e8db0a86af4fb241a2dd5ca22930..04aa5fba7253291be8748570a09fd9dc213ef296 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,15 @@
+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
 24 Nov 2005  Kevin Rosenberg <kevin@rosenberg.net>
        * Version 3.4.7
        * sql/time.lisp: Commit patch from Aleksandar Bakic for

diff --git a/db-odbc/odbc-api.lisp b/db-odbc/odbc-api.lisp
index 0dcefa4090491a558299e624ca9586389fd7d2d7..33734bc993450096052fbe1b240587c834d1ac1d 100644 (file)
--- a/db-odbc/odbc-api.lisp
+++ b/db-odbc/odbc-api.lisp
@@ -198,6 +198,20 @@ as possible second argument) to the desired representation of date/time/timestam
       (SQLConnect hdbc server-ptr $SQL_NTS uid-ptr 
                  $SQL_NTS pwd-ptr $SQL_NTS))))
 
       (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 %disconnect (hdbc)
   (with-error-handling 


@@ -560,7 +574,7 @@ as possible second argument) to the desired representation of date/time/timestam
 (defun sql-to-c-type (sql-type)
   (ecase sql-type
     ((#.$SQL_CHAR #.$SQL_VARCHAR #.$SQL_LONGVARCHAR 
 (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)
     (#.$SQL_INTEGER $SQL_C_SLONG)
     (#.$SQL_SMALLINT $SQL_C_SSHORT)
     (#.$SQL_DOUBLE $SQL_C_DOUBLE)


@@ -848,56 +862,59 @@ as possible second argument) to the desired representation of date/time/timestam
 
 (defun read-data-in-chunks (hstmt column-nr data-ptr c-type sql-type 
                                       out-len-ptr result-type)
 
 (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))
   (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)))
 
 (def-type c-timestamp-ptr-type (* (:struct sql-c-timestamp)))
 (def-type c-time-ptr-type (* (:struct sql-c-time)))

diff --git a/db-odbc/odbc-constants.lisp b/db-odbc/odbc-constants.lisp
index 0315e444e3a38627b2cd92fb3c8414a1d1b96a0d..6d8a1839a8f32ca2bc35e93ca2ce68a611ea30ce 100644 (file)
--- a/db-odbc/odbc-constants.lisp
+++ b/db-odbc/odbc-constants.lisp
@@ -953,6 +953,8 @@
 (defconstant $SQL_DRIVER_PROMPT 2)
 (defconstant $SQL_DRIVER_COMPLETE_REQUIRED 3)
 
 (defconstant $SQL_DRIVER_PROMPT 2)
 (defconstant $SQL_DRIVER_COMPLETE_REQUIRED 3)
 

+(defconstant $SQL_MAX_CONN_OUT 1024)
+

 ;; Level 2 Functions
 
 ;; SQLExtendedFetch "fFetchType" values
 ;; Level 2 Functions
 
 ;; SQLExtendedFetch "fFetchType" values

diff --git a/db-odbc/odbc-dbi.lisp b/db-odbc/odbc-dbi.lisp
index fc8f3000bed3380d7e0677bab1b7b625e398999b..2a60462ae0b8517530b285a2e7df173443a8228c 100644 (file)
--- a/db-odbc/odbc-dbi.lisp
+++ b/db-odbc/odbc-dbi.lisp
@@ -124,12 +124,21 @@ the query against." ))
 
 ;;; AODBC Compatible interface
 
 
 ;;; 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)))
   (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
     #+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


@@ -217,7 +226,7 @@ the query against." ))
 
 (defun list-all-table-columns (table &key db hstmt)
   (declare (ignore hstmt))
 
 (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)))
 
 (defun list-all-data-sources ()
   (let ((db (make-instance 'odbc-db)))


@@ -424,7 +433,8 @@ This makes the functions db-execute-command and db-query thread safe."
                   ;; 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)
                   ;; 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)
                       (%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)

diff --git a/db-odbc/odbc-ff-interface.lisp b/db-odbc/odbc-ff-interface.lisp
index e46db57a021b54e65df0878214fef2e6cd7a256a..9baec6a1431f84fc7c17f25d88c958b128951f43 100644 (file)
--- a/db-odbc/odbc-ff-interface.lisp
+++ b/db-odbc/odbc-ff-interface.lisp
@@ -61,7 +61,7 @@
 (def-function "SQLDriverConnect"
     ((hdbc sql-handle)          ; HDBC        hdbc
      (hwnd sql-handle)          ; SQLHWND     hwnd
 (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
      (cbConnStrIn :short)       ; SWORD       cbConnStrIn
      (*szConnStrOut string-ptr) ; UCHAR  FAR *szConnStrOut
      (cbConnStrOutMax :short)   ; SWORD       cbConnStrOutMax

diff --git a/db-odbc/odbc-package.lisp b/db-odbc/odbc-package.lisp
index baedbedd0c7eb6406efb8174efffeaf8a7bfcb6b..011b6b4b044f24adc4faaa9e11f7e91f2adc5f72 100644 (file)
--- a/db-odbc/odbc-package.lisp
+++ b/db-odbc/odbc-package.lisp
@@ -39,6 +39,7 @@
      #:%new-db-connection-handle
      #:%new-environment-handle
      #:%sql-connect
      #:%new-db-connection-handle
      #:%new-environment-handle
      #:%sql-connect

+     #:%sql-driver-connect

      #:disable-autocommit
      #:enable-autocommit
      #:%sql-free-environment
      #:disable-autocommit
      #:enable-autocommit
      #:%sql-free-environment

diff --git a/db-odbc/odbc-sql.lisp b/db-odbc/odbc-sql.lisp
index 1f00008493be1d9ccaf7375c70f6cfd977bc3895..e76b9d0bdf45d13fd3a897d15382d9d4b7e46f4b 100644 (file)
--- a/db-odbc/odbc-sql.lisp
+++ b/db-odbc/odbc-sql.lisp
@@ -30,14 +30,14 @@
 
 (defmethod database-name-from-spec (connection-spec
                                    (database-type (eql :odbc)))
 
 (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)))
     (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)
     (handler-case
        (let ((db (make-instance 'odbc-database
                                 :name (database-name-from-spec connection-spec :odbc)


@@ -46,7 +46,10 @@
                                 :odbc-conn
                                 (odbc-dbi:connect :user user
                                                   :password password
                                 :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
          (store-type-of-connected-database db)
          ;; Ensure this database type is initialized so can check capabilities of
          ;; underlying database


@@ -74,6 +77,9 @@
            (unless (find-package 'clsql-postgresql)
              (ignore-errors (asdf:operate 'asdf:load-op 'clsql-postgresql-socket)))
            :postgresql)
            (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)
           ((or (search "mysql" server-name :test #'char-equal)
                (search "mysql" dbms-name :test #'char-equal))
            (unless (find-package 'clsql-mysql)


@@ -127,7 +133,7 @@
        ((null loop-rows) (nreverse results))
       (let* ((row (car loop-rows))
             (col (nth 5 row)))
        ((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
          (push col results))))))
 
 ;;; Database capabilities

diff --git a/debian/changelog b/debian/changelog
index bb531ff9965bdb0c1a3501f30e35bf00dbc61e4d..c67186824563a19a88c172de8335f72d4656692a 100644 (file)
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,10 @@
+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
 cl-sql (3.4.7-1) unstable; urgency=low
 
   * New upstream

diff --git a/debian/control b/debian/control
index 0140eaf2b06c4e5b8d14437415c0988a20661e01..727fa1fb0a36dff5fd911639c60c24d5c910f2b4 100644 (file)
--- a/debian/control
+++ b/debian/control
@@ -2,7 +2,7 @@ Source: cl-sql
 Section: devel
 Priority: extra
 Maintainer: Kevin M. Rosenberg <kmr@debian.org>
 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
 
 Build-Depends-Indep: debhelper (>= 4.0.0)
 Standards-Version: 3.6.2.1
 


@@ -26,7 +26,7 @@ Description: Common UFFI functions for CLSQL database backends
 
 Package: cl-sql-mysql
 Architecture: any
 
 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
 Provides: cl-sql-backend
 Description: CLSQL database backend, MySQL
  This package enables you to use the CLSQL data access package

diff --git a/doc/csql.xml b/doc/csql.xml
index 272c62536b0674330ef0e90f4cfd0bd74c741ab5..f84dd50691c54b8e748cd2f1ef344caeda7d9df8 100644 (file)
--- a/doc/csql.xml
+++ b/doc/csql.xml
@@ -250,7 +250,7 @@ mapped into a database).  They would be defined as follows:
 
   <listitem>
     <para>
 
   <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>
 
       type specifier for this slots column definition in the database.
       </para></listitem>
 

diff --git a/sql/db-interface.lisp b/sql/db-interface.lisp
index 0d67bb0147a25e7a85e581bedbbab6f620cfcee3..298214ae0cdcfd9c734f9428942212bf1c5a7c6b 100644 (file)
--- a/sql/db-interface.lisp
+++ b/sql/db-interface.lisp
@@ -296,6 +296,12 @@ of TYPE_NAME (keyword) PRECISION SCALE NULLABLE.")
           nil)
   (:documentation "NIL [default] if database-type does not use column name on DROP INDEX."))
 
           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))
 (defgeneric db-type-has-views? (db-type)
   (:method (db-type)
           (declare (ignore db-type))


@@ -359,6 +365,17 @@ of TYPE_NAME (keyword) PRECISION SCALE NULLABLE.")
     nil)
   (:documentation "T if database backend supports prepared statements."))
 
     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)
 
 
 ;;; Large objects support (Marc Battyani)
 

diff --git a/sql/fddl.lisp b/sql/fddl.lisp
index 51f8f05d5d5954b9a174d0bcc7bbd362c39fee67..3b5b1bd195b6a7e66a5d0c6626e909452c6565f6 100644 (file)
--- a/sql/fddl.lisp
+++ b/sql/fddl.lisp
@@ -216,14 +216,14 @@ the index from."
        (unless (index-exists-p index-name :database database)
          (return-from drop-index)))
       (:error t))
        (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
 
 (defun list-indexes (&key (owner nil) (database *default-database*) (on nil))
   "Returns a list of strings representing index names in DATABASE

diff --git a/sql/generic-odbc.lisp b/sql/generic-odbc.lisp
index eb3430f4b4d44dea933f031ba790bea31f729a2d..563e1f8b1ba40513a2194a256f8b2bdcb5374621 100644 (file)
--- a/sql/generic-odbc.lisp
+++ b/sql/generic-odbc.lisp
@@ -58,7 +58,68 @@
                           (db-type (eql :postgresql)))
   (if (string= "0" val) nil t))
 
                           (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))
 ;;; Backend methods
 
 (defmethod database-disconnect ((database generic-odbc-database))


@@ -66,8 +127,8 @@
   (setf (odbc-conn database) nil)
   t)
 
   (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)
   (handler-case
       (funcall (sql-fn database)
               query-expression :db (odbc-conn database)


@@ -105,19 +166,19 @@
 
 
 (defmethod database-query-result-set ((query-expression string)
 
 
 (defmethod database-query-result-set ((query-expression string)

-                                     (database generic-odbc-database) 
+                                     (database generic-odbc-database)

                                      &key full-set result-types)
                                      &key full-set result-types)

-  (handler-case 
+  (handler-case

       (multiple-value-bind (query column-names)
          (funcall (sql-fn database)
       (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
                   :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
                               :types result-types)
         (length column-names)
         nil ;; not able to return number of rows with odbc


@@ -156,7 +217,9 @@
     ;; 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)))
     ;; 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))))
 
 
          collect (nth 2 row))))
 
 


@@ -170,7 +233,9 @@
     ;; 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)))
     ;; 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))))
 
 
          collect (nth 2 row))))
 
 

diff --git a/sql/package.lisp b/sql/package.lisp
index ad785ecabba8260cea21d0591e2b2f65bde5abde..4c82b0aae4dc683e64d3e8d0c6918a1664a63a50 100644 (file)
--- a/sql/package.lisp
+++ b/sql/package.lisp
@@ -150,6 +150,9 @@
      #:db-type-has-fancy-math?
      #:db-type-default-case
      #:db-type-use-column-on-drop-index? 
      #: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
      #:database-underlying-type
      #:database-get-type-specifier
      #:read-sql-value

diff --git a/sql/time.lisp b/sql/time.lisp
index 464d9cd00506388ee6a6a72de3eb09a728ae4ab6..75f3faafbc9cebef9af607acfa4fa3e35be30333 100644 (file)
--- a/sql/time.lisp
+++ b/sql/time.lisp
@@ -1274,7 +1274,7 @@ Will throw a hissy fit if the date string is a duration. Will ignore any precisi
                      (char= #\. (char string 19))))
              (multiple-value-bind (parsed-usec usec-end)
                  (parse-integer string :start 20 :junk-allowed t)
                      (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))))
                      gmt-sec-offset (if (<= (+ 3 usec-end)  strlen)
                                         (let ((skip-to (or (position #\+ string :start 19)
                                                            (position #\- string :start 19))))

diff --git a/sql/transaction.lisp b/sql/transaction.lisp
index 089ce0c2aa899147849a12e939be26b78b779c1a..a9df87fd59f9f579c4aadf19a9b804c832397b30 100644 (file)
--- a/sql/transaction.lisp
+++ b/sql/transaction.lisp
@@ -49,8 +49,10 @@ is called on DATABASE which defaults to *DEFAULT-DATABASE*."
       (setf (commit-hooks transaction) nil
             (rollback-hooks transaction) nil
             (transaction-status transaction) nil)
       (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
 
 (defmethod database-commit-transaction ((database database))
   (with-slots (transaction transaction-level autocommit) database

diff --git a/tests/test-fddl.lisp b/tests/test-fddl.lisp
index f5527c773f7cce25f3ff017cc3f6c40cddb7f28f..34c956a79a7918595556303c146beb15aa39d703 100644 (file)
--- a/tests/test-fddl.lisp
+++ b/tests/test-fddl.lisp
@@ -88,9 +88,13 @@
                           '(:postgresql :postgresql-socket))
                   :ignore
                   :warn)))
                           '(: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])
        (clsql:table-exists-p [foo]))
      (progn
        (clsql:drop-table [foo])

diff --git a/tests/test-fdml.lisp b/tests/test-fdml.lisp
index aa887770e3fd250e2052da2445ad2d5e1c060c40..d2606c14b4419f038d8d0eecbb6a6d4a107af670 100644 (file)
--- a/tests/test-fdml.lisp
+++ b/tests/test-fdml.lisp
@@ -373,8 +373,11 @@
  ("Vlad" "Jose" "Leon" "Niki" "Leon" "Yuri" "Kons" "Mikh" "Bori" "Vlad"))
 
 (deftest :fdml/select/22 
  ("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"))
  ("Vladimir Lenin" "Josef Stalin" "Leon Trotsky" "Nikita Kruschev"
  "Leonid Brezhnev" "Yuri Andropov" "Konstantin Chernenko" "Mikhail Gorbachev"
  "Boris Yeltsin" "Vladimir Putin"))

diff --git a/tests/test-init.lisp b/tests/test-init.lisp
index d77505476aed0fd3fee86f4a5c97e3629b95f98a..d745ff0698e3823e4b2c7881d7f760e25eaac0a8 100644 (file)
--- a/tests/test-init.lisp
+++ b/tests/test-init.lisp
@@ -614,6 +614,15 @@
                              '(:postgresql :oracle)))
                (clsql-sys:in test :fddl/owner/1))
            (push (cons test "table ownership not supported") skip-tests))
                              '(: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))))
          (t
           (push test-form test-forms)))))
       (values (nreverse test-forms) (nreverse skip-tests))))