Merge branch 'uncontroversial' into accel

diff --git a/clsql-mysql.asd b/clsql-mysql.asd
index a176f85d4fa8bc0d0c6bd1db09e50db10f2c48d7..70bb57dfa38abe4a04a20e22627a3cff133b71d0 100644 (file)
--- a/clsql-mysql.asd
+++ b/clsql-mysql.asd
@@ -80,7 +80,7 @@
   :description "Common Lisp SQL MySQL Driver"
   :long-description "cl-sql-mysql package provides a database driver to the MySQL database system."
 
-  :depends-on (uffi clsql clsql-uffi)
+  :depends-on (cffi-uffi-compat clsql clsql-uffi)
   :components
   ((:module :db-mysql
            :components

diff --git a/clsql-odbc.asd b/clsql-odbc.asd
index 5913bede6092b975d60873a67b0a567cd7c39eff..d556d15c781417f967229ba123b87059b51e1c3e 100644 (file)
--- a/clsql-odbc.asd
+++ b/clsql-odbc.asd
@@ -27,7 +27,7 @@
   :description "Common Lisp SQL ODBC Driver"
   :long-description "cl-sql-odbc package provides a database driver to the ODBC database system."
 
-  :depends-on (uffi clsql clsql-uffi)
+  :depends-on (cffi-uffi-compat clsql clsql-uffi)
   :components
   ((:module :db-odbc
            :components

diff --git a/clsql-postgresql-socket.asd b/clsql-postgresql-socket.asd
index e5e1320b52846c0f590b30f0a3b98b855b9bf190..cb1194907a5bba0c9b958c5fd45c5e26f2db758a 100644 (file)
--- a/clsql-postgresql-socket.asd
+++ b/clsql-postgresql-socket.asd
@@ -29,7 +29,7 @@
   :description "Common Lisp SQL PostgreSQL Socket Driver"
   :long-description "cl-sql-postgresql-socket package provides a database driver to the PostgreSQL database via a socket interface."
 
-  :depends-on (clsql uffi md5 #+sbcl sb-bsd-sockets)
+  :depends-on (clsql cffi-uffi-compat md5 #+sbcl sb-bsd-sockets)
   :components
   ((:module :db-postgresql-socket
            :components

diff --git a/clsql-postgresql.asd b/clsql-postgresql.asd
index 84e3606e80776e85b202aaea567a2071289b1fd0..e4102e06ec620904c1acca1cb9dce151761a875c 100644 (file)
--- a/clsql-postgresql.asd
+++ b/clsql-postgresql.asd
@@ -29,7 +29,7 @@
   :description "Common Lisp PostgreSQL API Driver"
   :long-description "cl-sql-postgresql package provides a the database driver for the PostgreSQL API."
 
-  :depends-on (uffi clsql clsql-uffi)
+  :depends-on (cffi-uffi-compat clsql clsql-uffi)
   :components
   ((:module :db-postgresql
            :components

diff --git a/clsql-uffi.asd b/clsql-uffi.asd
index e5a75f6a3c830ae72e2ad887faaa296d7283df54..3903eb0df58a7b3f7c1e596e1a4e2c38fcbabca4 100644 (file)
--- a/clsql-uffi.asd
+++ b/clsql-uffi.asd
@@ -79,7 +79,7 @@
   :description "Common UFFI Helper functions for Common Lisp SQL Interface Library"
   :long-description "cl-sql-uffi package provides common helper functions using the UFFI for the CLSQL package."
 
-  :depends-on (uffi clsql)
+  :depends-on (cffi-uffi-compat clsql)
 
   :components
   ((:module :uffi

diff --git a/clsql.asd b/clsql.asd
index 35e172ac40ef9440ed3037b4c60af5a4b589f638..0c9c6546edbad44ce9bfc3244c226152c54d5dab 100644 (file)
--- a/clsql.asd
+++ b/clsql.asd
@@ -27,7 +27,7 @@
 ;; need to load uffi for below perform :after method
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (unless (find-package 'uffi)
-    (asdf:operate 'asdf:load-op 'uffi)))
+    (asdf:operate 'asdf:load-op 'cffi-uffi-compat)))
 
 (defsystem clsql
     :name "CLSQL"

diff --git a/db-odbc/odbc-api.lisp b/db-odbc/odbc-api.lisp
index 2d3e234d50b49c364459632ca4cf20693a7303c7..49a6e1f6fc7a03da30960a203875639f815ae46f 100644 (file)
--- a/db-odbc/odbc-api.lisp
+++ b/db-odbc/odbc-api.lisp
@@ -240,7 +240,7 @@ as possible second argument) to the desired representation of date/time/timestam
     (SQLTransact
      henv hdbc $SQL_ROLLBACK)))
 
-; col-nr is zero-based in Lisp
+; col-nr is zero-based in Lisp but 1 based in sql
 ; col-nr = :bookmark retrieves a bookmark.
 (defun %bind-column (hstmt column-nr c-type data-ptr precision out-len-ptr)
   (with-error-handling
@@ -493,6 +493,7 @@ as possible second argument) to the desired representation of date/time/timestam
            (deref-pointer column-scale-ptr :short)
            (deref-pointer column-nullable-p-ptr :short)))))))
 
+;; this function isn't used, which is good because FreeTDS dosn't support it.
 ;; parameter counting is 1-based
 (defun %describe-parameter (hstmt parameter-nr)
   (with-foreign-objects ((column-sql-type-ptr :short)
@@ -584,9 +585,10 @@ 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
-      #.$SQL_NUMERIC #.$SQL_DECIMAL #.$SQL_BIGINT -8 -9 -10) $SQL_C_CHAR) ;; Added -10 for MSSQL ntext type
+      #.$SQL_NUMERIC #.$SQL_DECIMAL -8 -9 -10) $SQL_C_CHAR) ;; Added -10 for MSSQL ntext type
     (#.$SQL_INTEGER $SQL_C_SLONG)
     (#.$SQL_SMALLINT $SQL_C_SSHORT)
+    (#.$SQL_BIGINT $SQL_C_SBIGINT)
     (#.$SQL_DOUBLE $SQL_C_DOUBLE)
     (#.$SQL_FLOAT $SQL_C_DOUBLE)
     (#.$SQL_REAL $SQL_C_FLOAT)
@@ -604,6 +606,7 @@ as possible second argument) to the desired representation of date/time/timestam
 (def-type short-pointer-type (* :short))
 (def-type int-pointer-type (* :int))
 (def-type long-pointer-type (* #.$ODBC-LONG-TYPE))
+(def-type big-pointer-type (* #.$ODBC-BIG-TYPE))
 (def-type float-pointer-type (* :float))
 (def-type double-pointer-type (* :double))
 (def-type string-pointer-type (* :unsigned-char))
@@ -624,6 +627,10 @@ as possible second argument) to the desired representation of date/time/timestam
   (locally (declare (type long-pointer-type ptr))
     (deref-pointer ptr #.$ODBC-LONG-TYPE)))
 
+(defun get-cast-big (ptr)
+  (locally (declare (type big-pointer-type ptr))
+    (deref-pointer ptr #.$ODBC-BIG-TYPE)))
+
 (defun get-cast-single-float (ptr)
   (locally (declare (type float-pointer-type ptr))
     (deref-pointer ptr :float)))
@@ -670,8 +677,7 @@ as possible second argument) to the desired representation of date/time/timestam
                    (#.$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_BIGINT (get-cast-big data-ptr))
                    (#.$SQL_DECIMAL
                     (let ((*read-base* 10))
                       (read-from-string (get-cast-foreign-string data-ptr))))
@@ -741,6 +747,7 @@ as possible second argument) to the desired representation of date/time/timestam
             (#.$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_SBIGINT (uffi:allocate-foreign-object #.$ODBC-BIG-TYPE))
             (#.$SQL_C_CHAR (uffi:allocate-foreign-string (1+ size)))
             (#.$SQL_C_BINARY (uffi:allocate-foreign-string (1+ (* 2 size))))
             (t

diff --git a/db-odbc/odbc-constants.lisp b/db-odbc/odbc-constants.lisp
index 4dfef884a28a1cf3219fbac43b1c894bd770eeda..479c6fafcf4bbc53536364ffb134d16ea8269946 100644 (file)
--- a/db-odbc/odbc-constants.lisp
+++ b/db-odbc/odbc-constants.lisp
@@ -21,6 +21,7 @@
 ;; on SuSE AMD64 9.0, unixODBC is compiled with with SQLLEN being 4 bytes long
 (defconstant $ODBC-LONG-TYPE :int)
 (defconstant $ODBC-ULONG-TYPE :unsigned-int)
+(defconstant $ODBC-BIG-TYPE :long-long)
 
 ;; (defconstant $ODBCVER        #x0210)
 
@@ -934,6 +935,7 @@
 (defconstant $SQL_C_BINARY $SQL_BINARY)
 (defconstant $SQL_C_BIT $SQL_BIT)
 (defconstant $SQL_C_TINYINT $SQL_TINYINT)
+(defconstant $SQL_C_SBIGINT (+ $SQL_BIGINT $SQL_SIGNED_OFFSET))
 (defconstant $SQL_C_SLONG (+ $SQL_C_LONG $SQL_SIGNED_OFFSET)) ;; SIGNED INTEGER
 (defconstant $SQL_C_SSHORT (+ $SQL_C_SHORT $SQL_SIGNED_OFFSET)) ;; SIGNED SMALLINT
 (defconstant $SQL_C_STINYINT (+ $SQL_TINYINT $SQL_SIGNED_OFFSET)) ;; SIGNED TINYINT

diff --git a/db-odbc/odbc-dbi.lisp b/db-odbc/odbc-dbi.lisp
index 6723a1a6d280702bff950c5d4d1fb378a9174012..caa549e94c72f6db9b6771a071c0c48eff09c461 100644 (file)
--- a/db-odbc/odbc-dbi.lisp
+++ b/db-odbc/odbc-dbi.lisp
@@ -454,22 +454,19 @@ This makes the functions db-execute-command and db-query thread safe."
     (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_C_STINYINT :short)
-              (#.odbc::$SQL_BIGINT :short)
-              (t t))))
-          (t
-           t)))))
+           (cond
+             ((consp result-types)
+              (nth i result-types))
+             ((eq result-types :auto)
+              (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_C_STINYINT :short)
+                (#.odbc::$SQL_C_SBIGINT #.odbc::$ODBC-BIG-TYPE)
+                (t t)))
+             (t t)))))
   query)
 
 (defun db-close-query (query &key drop-p)
@@ -564,7 +561,8 @@ This makes the functions db-execute-command and db-query thread safe."
 (defun sql-to-lisp-type (sql-type)
   (ecase sql-type
     ((#.odbc::$SQL_CHAR #.odbc::$SQL_VARCHAR #.odbc::$SQL_LONGVARCHAR) :string)
-    ((#.odbc::$SQL_NUMERIC #.odbc::$SQL_DECIMAL #.odbc::$SQL_BIGINT) :string) ; ??
+    ((#.odbc::$SQL_NUMERIC #.odbc::$SQL_DECIMAL ) :string) ; ??
+    (#.odbc::$SQL_BIGINT #.odbc::$ODBC-BIG-TYPE)
     (#.odbc::$SQL_INTEGER #.odbc::$ODBC-LONG-TYPE)
     (#.odbc::$SQL_SMALLINT :short)
     ((#.odbc::$SQL_FLOAT #.odbc::$SQL_DOUBLE) #.odbc::$ODBC-LONG-TYPE)

diff --git a/sql/expressions.lisp b/sql/expressions.lisp
index 6aaededd7c6b32aa1c58337c9257fc6e400d29a8..63885153259d9fad208f1a9bc3636372936e340e 100644 (file)
--- a/sql/expressions.lisp
+++ b/sql/expressions.lisp
@@ -967,7 +967,9 @@ uninclusive, and the args from that keyword to the end."
    (cons (symbol-name-default-case "UNSIGNED") "UNSIGNED")
    (cons (symbol-name-default-case "ZEROFILL") "ZEROFILL")
    (cons (symbol-name-default-case "AUTO-INCREMENT") "AUTO_INCREMENT")
-   (cons (symbol-name-default-case "UNIQUE") "UNIQUE")))
+   (cons (symbol-name-default-case "UNIQUE") "UNIQUE")
+   (cons (symbol-name-default-case "IDENTITY") "IDENTITY (1,1)") ;Added Identity for MS-SQLServer support
+   ))
 
 (defmethod database-constraint-statement (constraint-list database)
   (declare (ignore database))

diff --git a/sql/generics.lisp b/sql/generics.lisp
index 792a9dec90c5ac7277369e4905b1755a995908e0..d0d69d3444a404494e94d3da9e067e236473f8ae 100644 (file)
--- a/sql/generics.lisp
+++ b/sql/generics.lisp
@@ -21,6 +21,13 @@
 
 ;; FDML
 
+(defgeneric choose-database-for-instance (object &optional database)
+  (:documentation "Used by the oodml functions to select which
+ database object to use. Chooses the database associated with the
+ object primarily, falls back to the database provided as an argument
+ or the *DEFAULT-DATABASE*."))
+
+
 (defgeneric execute-command (expression &key database)
   (:documentation
    "Executes the SQL command EXPRESSION, which may be an SQL
@@ -84,7 +91,7 @@ case, a record is created in the appropriate table of DATABASE
 using values from the slot values of OBJECT, and OBJECT becomes
 associated with DATABASE."))
 
-(defgeneric delete-instance-records (object)
+(defgeneric delete-instance-records (object &key database)
   (:documentation
    "Deletes the records represented by OBJECT in the appropriate
 table of the database associated with OBJECT. If OBJECT is not

diff --git a/sql/oodml.lisp b/sql/oodml.lisp
index fb76c55743fe7ff464377d42c08ac5958ec5dae6..3e7ec9af023c31fc1c5d0e4cdd538c4ab2e8cfa5 100644 (file)
--- a/sql/oodml.lisp
+++ b/sql/oodml.lisp
@@ -95,9 +95,9 @@
     (cond ((and value (null slot-reader))
            (setf (slot-value instance slot-name)
                  (read-sql-value value (delistify slot-type)
-                                 (view-database instance)
+                                (choose-database-for-instance instance)
                                  (database-underlying-type
-                                  (view-database instance)))))
+                                  (choose-database-for-instance instance)))))
           ((null value)
            (update-slot-with-null instance slot-name slotdef))
           ((typep slot-reader 'string)
@@ -158,44 +158,36 @@
       (mapc #'update-slot slotdeflist values)
       obj))
 
-(defmethod update-record-from-slot ((obj standard-db-object) slot &key
-                                    (database *default-database*))
-  (let* ((database (or (view-database obj) database))
-         (vct (view-table (class-of obj)))
-         (sd (slotdef-for-slot-with-class slot (class-of obj))))
-    (check-slot-type sd (slot-value obj slot))
-    (let* ((att (view-class-slot-column sd))
-           (val (db-value-from-slot sd (slot-value obj slot) database)))
-      (cond ((and vct sd (view-database obj))
-             (update-records (sql-expression :table vct)
-                             :attributes (list (sql-expression :attribute att))
-                             :values (list val)
-                             :where (key-qualifier-for-instance
-                                     obj :database database)
-                             :database database))
-            ((and vct sd (not (view-database obj)))
-             (insert-records :into (sql-expression :table vct)
-                             :attributes (list (sql-expression :attribute att))
-                             :values (list val)
-                             :database database)
-             (setf (slot-value obj 'view-database) database))
-            (t
-             (error "Unable to update record.")))))
-  (values))
-
-(defmethod update-record-from-slots ((obj standard-db-object) slots &key
-                                     (database *default-database*))
-  (let* ((database (or (view-database obj) database))
-         (vct (view-table (class-of obj)))
-         (sds (slotdefs-for-slots-with-class slots (class-of obj)))
+(defmethod choose-database-for-instance ((obj standard-db-object) &optional database)
+  "Determine which database connection to use for a standard-db-object.
+        Errs if none is available."
+  (or (find-if #'(lambda (db)
+                  (and db (is-database-open db)))
+               (list (view-database obj)
+                     database
+                     *default-database*))
+      (signal-no-database-error nil)))
+
+(defmethod update-record-from-slot ((obj standard-db-object) slot
+                                   &key database)
+  (update-record-from-slots obj (list slot) :database database))
+
+(defmethod update-record-from-slots ((obj standard-db-object) slots
+                                    &key database)
+  (let* ((database (choose-database-for-instance obj database))
+        (vct (view-table (class-of obj)))
+        (view-class (class-of obj))
          (avps (mapcar #'(lambda (s)
-                           (let ((val (slot-value
-                                       obj (slot-definition-name s))))
-                             (check-slot-type s val)
+                           (let* ((slot (etypecase s
+                                         (symbol (slotdef-for-slot-with-class s view-class))
+                                         (view-class-effective-slot-definition s)))
+                                 (val (slot-value
+                                       obj (slot-definition-name slot))))
+                             (check-slot-type slot val)
                              (list (sql-expression
-                                    :attribute (view-class-slot-column s))
-                                   (db-value-from-slot s val database))))
-                       sds)))
+                                    :attribute (view-class-slot-column slot))
+                                   (db-value-from-slot slot val database))))
+                       slots)))
     (cond ((and avps (view-database obj))
            (update-records (sql-expression :table vct)
                            :av-pairs avps
@@ -208,75 +200,54 @@
                            :database database)
            (setf (slot-value obj 'view-database) database))
           (t
-           (error "Unable to update records"))))
+           (error "Unable to update record."))))
   (values))
 
 (defmethod update-records-from-instance ((obj standard-db-object) &key database)
-  (let ((database (or database (view-database obj) *default-database*)))
-    (labels ((slot-storedp (slot)
-               (and (member (view-class-slot-db-kind slot) '(:base :key))
-                    (slot-boundp obj (slot-definition-name slot))))
-             (slot-value-list (slot)
-               (let ((value (slot-value obj (slot-definition-name slot))))
-                 (check-slot-type slot value)
-                 (list (sql-expression :attribute (view-class-slot-column slot))
-                       (db-value-from-slot slot value database)))))
-      (let* ((view-class (class-of obj))
-             (view-class-table (view-table view-class))
-             (slots (remove-if-not #'slot-storedp
-                                   (ordered-class-slots view-class)))
-             (record-values (mapcar #'slot-value-list slots)))
-        (unless record-values
-          (error "No settable slots."))
-        (if (view-database obj)
-            (update-records (sql-expression :table view-class-table)
-                            :av-pairs record-values
-                            :where (key-qualifier-for-instance
-                                    obj :database database)
-                            :database database)
-            (progn
-              (insert-records :into (sql-expression :table view-class-table)
-                              :av-pairs record-values
-                              :database database)
-              (setf (slot-value obj 'view-database) database))))))
-  (values))
-
-(defmethod delete-instance-records ((instance standard-db-object))
+  (labels ((slot-storedp (slot)
+            (and (member (view-class-slot-db-kind slot) '(:base :key))
+                 (slot-boundp obj (slot-definition-name slot)))))
+    (let* ((view-class (class-of obj))
+          (slots (remove-if-not #'slot-storedp
+                                (ordered-class-slots view-class))))
+      (update-record-from-slots obj slots :database database )))
+  )
+
+(defmethod delete-instance-records ((instance standard-db-object) &key database)
   (let ((vt (sql-expression :table (view-table (class-of instance))))
-        (vd (view-database instance)))
-    (if vd
-        (let ((qualifier (key-qualifier-for-instance instance :database vd)))
-          (delete-records :from vt :where qualifier :database vd)
-          (setf (record-caches vd) nil)
-          (setf (slot-value instance 'view-database) nil)
-          (values))
-        (signal-no-database-error vd))))
+       (database (choose-database-for-instance instance database)))
+    (let ((qualifier (key-qualifier-for-instance instance :database database)))
+      (delete-records :from vt :where qualifier :database database)
+      (setf (record-caches database) nil)
+      (setf (slot-value instance 'view-database) nil)
+      (values))))
 
 (defmethod update-instance-from-records ((instance standard-db-object)
-                                         &key (database *default-database*))
+                                         &key database)
   (let* ((view-class (find-class (class-name (class-of instance))))
          (view-table (sql-expression :table (view-table view-class)))
-         (vd (or (view-database instance) database))
-         (view-qual (key-qualifier-for-instance instance :database vd))
+         (database (choose-database-for-instance instance database))
+         (view-qual (key-qualifier-for-instance instance :database database))
          (sels (generate-selection-list view-class))
          (res (apply #'select (append (mapcar #'cdr sels)
                                       (list :from  view-table
                                             :where view-qual
-                                            :result-types nil
-                                            :database vd)))))
+                                           :result-types nil
+                                           :database database)))))
     (when res
+      (setf (slot-value instance 'view-database) database)
       (get-slot-values-from-view instance (mapcar #'car sels) (car res)))))
 
 (defmethod update-slot-from-record ((instance standard-db-object)
-                                    slot &key (database *default-database*))
+                                    slot &key database)
   (let* ((view-class (find-class (class-name (class-of instance))))
          (view-table (sql-expression :table (view-table view-class)))
-         (vd (or (view-database instance) database))
-         (view-qual (key-qualifier-for-instance instance :database vd))
+         (database (choose-database-for-instance instance database))
+         (view-qual (key-qualifier-for-instance instance :database database))
          (slot-def (slotdef-for-slot-with-class slot view-class))
          (att-ref (generate-attribute-reference view-class slot-def))
          (res (select att-ref :from  view-table :where view-qual
-                      :result-types nil)))
+                     :result-types nil)))
     (when res
       (get-slot-values-from-view instance (list slot-def) (car res)))))
 
@@ -655,10 +626,10 @@
                                 :table jc-view-table))
                           :where jq
                           :result-types :auto
-                          :database (view-database object))))
+                          :database (choose-database-for-instance object))))
            (mapcar #'(lambda (i)
                        (let* ((instance (car i))
-                              (jcc (make-instance jc :view-database (view-database instance))))
+                              (jcc (make-instance jc :view-database (choose-database-for-instance object))))
                          (setf (slot-value jcc (gethash :foreign-key dbi))
                                key)
                          (setf (slot-value jcc (gethash :home-key tdbi))
@@ -669,8 +640,8 @@
             ;; just fill in minimal slots
             (mapcar
              #'(lambda (k)
-                 (let ((instance (make-instance tsc :view-database (view-database object)))
-                       (jcc (make-instance jc :view-database (view-database object)))
+                 (let ((instance (make-instance tsc :view-database (choose-database-for-instance object)))
+                       (jcc (make-instance jc :view-database (choose-database-for-instance object)))
                        (fk (car k)))
                    (setf (slot-value instance (gethash :home-key tdbi)) fk)
                    (setf (slot-value jcc (gethash :foreign-key dbi))
@@ -681,7 +652,7 @@
              (select (sql-expression :attribute (gethash :foreign-key tdbi) :table jc-view-table)
                      :from (sql-expression :table jc-view-table)
                      :where jq
-                     :database (view-database object))))))))
+                     :database (choose-database-for-instance object))))))))
 
 
 ;;; Remote Joins
@@ -779,7 +750,7 @@ maximum of MAX-LEN instances updated in each query."
     (let ((jq (join-qualifier class object slot-def)))
       (when jq
         (select jc :where jq :flatp t :result-types nil
-                :database (view-database object))))))
+                :database (choose-database-for-instance object))))))
 
 (defun fault-join-slot (class object slot-def)
   (let* ((dbi (view-class-slot-db-info slot-def))