r9279: Handle differences in direct-slot-definition values which

        are now listify by openmcl 14.2

diff --git a/ChangeLog b/ChangeLog
index 891b6ba0bb4bee6b3b10380374abea417d56dddc..a8ae5fe531b684f961eeaedf0bf67e142cb91e32 100644 (file)
--- a/ChangeLog
+++ b/ChangeLog
@@ -9,6 +9,8 @@
        changing the type-specifier. Use a lisp type of (OR NULL FOO)
        for a specified-type of FOO unless :db-constraints :not-null.
        No need to specialize finalize-inheritance for openmcl.
+       Handle differences in direct-slot-definition values which
+       are now listify by openmcl 14.2.
        * tests/test-*.lisp: Rename fields so that joins occur on
        fields with different names. This ensures that join code is
        selecting the proper name.

diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp
index e59a00a5f491e9a61b97025ddec5fab39c2b918d..a8b1563e3f061d26ee83e0c92d4eccf217fec280 100644 (file)
--- a/sql/metaclasses.lisp
+++ b/sql/metaclasses.lisp
@@ -239,7 +239,9 @@ the slot name.")
     :accessor view-class-slot-db-kind
     :initarg :db-kind
     :initform :base
-    :type keyword
+    ;; openmcl 0.14.2 stores the value as list in the DSD
+    ;; :type (or list keyword)
+    #-openmcl :type #-openmcl keyword
     :documentation
     "The kind of DB mapping which is performed for this slot.  :base
 indicates the slot maps to an ordinary column of the DB view.  :key
@@ -355,9 +357,10 @@ column definition in the database.")
   (find-class 'view-class-effective-slot-definition))
 
 #+openmcl
-(defun compute-class-precedence-list (class)
-  ;; safe to call this in openmcl
-  (class-precedence-list class))
+(when (not (symbol-function 'compute-class-precedence-list))
+  (eval
+   (defun compute-class-precedence-list (class)
+     (class-precedence-list class))))
 
 #-(or sbcl cmu)
 (defmethod compute-slots ((class standard-db-class))
@@ -403,6 +406,20 @@ which does type checking before storing a value in a slot."
 ;; what kind of database value (if any) is stored there, generates and
 ;; verifies the column name.
 
+(declaim (inline delistify))
+(defun delistify (list)
+  "Some MOPs, like openmcl 0.14.2, cons attribute values in a list."
+  (if (listp list)
+      (car list)
+      list))
+
+(declaim (inline delistify))
+(defun delistify-dsd (list)
+  "Some MOPs, like openmcl 0.14.2, cons attribute values in a list."
+  (if (and (listp list) (null (cdr list)))
+      (car list)
+      list))
+
 (defmethod compute-effective-slot-definition ((class standard-db-class)
                                              #+kmr-normal-cesd slot-name
                                              direct-slots)
@@ -428,49 +445,58 @@ which does type checking before storing a value in a slot."
         (setf (slot-value esd 'column)
           (column-name-from-arg
            (if (slot-boundp dsd 'column)
-               (view-class-slot-column dsd)
+               (delistify-dsd (view-class-slot-column dsd))
              (column-name-from-arg
               (sql-escape (slot-definition-name dsd))))))
         
         (setf (slot-value esd 'db-type)
           (when (slot-boundp dsd 'db-type)
-            (view-class-slot-db-type dsd)))
+            (delistify-dsd
+             (view-class-slot-db-type dsd))))
         
         (setf (slot-value esd 'void-value)
-          (view-class-slot-void-value dsd))
+              (delistify-dsd
+               (view-class-slot-void-value dsd)))
         
         ;; :db-kind slot value defaults to :base (store slot value in
         ;; database)
         
         (setf (slot-value esd 'db-kind)
           (if (slot-boundp dsd 'db-kind)
-              (view-class-slot-db-kind dsd)
+              (delistify-dsd (view-class-slot-db-kind dsd))
             :base))
         
         (setf (slot-value esd 'db-writer)
           (when (slot-boundp dsd 'db-writer)
-            (view-class-slot-db-writer dsd)))
+            (delistify-dsd (view-class-slot-db-writer dsd))))
         (setf (slot-value esd 'db-constraints)
           (when (slot-boundp dsd 'db-constraints)
-            (view-class-slot-db-constraints dsd)))
+            (delistify-dsd (view-class-slot-db-constraints dsd))))
         
         ;; I wonder if this slot option and the previous could be merged,
         ;; so that :base and :key remain keyword options, but :db-kind
         ;; :join becomes :db-kind (:join <db info .... >)?
-        
+
         (setf (slot-value esd 'db-info)
-          (when (slot-boundp dsd 'db-info)
-            (if (listp (view-class-slot-db-info dsd))
-                (parse-db-info (view-class-slot-db-info dsd))
-              (view-class-slot-db-info dsd))))
+              (when (slot-boundp dsd 'db-info)
+                (let ((dsd-info (view-class-slot-db-info dsd)))
+                  (cond
+                    ((atom dsd-info)
+                     dsd-info)
+                    ((and (listp dsd-info) (> (length dsd-info) 1)
+                          (atom (car dsd-info)))
+                     (parse-db-info dsd-info))
+                    ((and (listp dsd-info) (= 1 (length dsd-info))
+                          (listp (car dsd-info)))
+                     (parse-db-info (car dsd-info)))))))
         
-        (setf (specified-type esd) (specified-type dsd))
+        (setf (specified-type esd)
+              (delistify-dsd (specified-type dsd)))
         
         )
        ;; all other slots
        (t
         (let ((type-predicate #+openmcl (slot-value esd 'ccl::type-predicate)))
-          
           (change-class esd 'view-class-effective-slot-definition
                         #+allegro :name 
                         #+allegro (slot-definition-name dsd))

diff --git a/sql/objects.lisp b/sql/objects.lisp
index 90505559e6e466f4076a7f443eda47b38af7ca53..e0d2cef682f51d1738885d4351cfb6f3c5bf3303 100644 (file)
--- a/sql/objects.lisp
+++ b/sql/objects.lisp
@@ -239,11 +239,6 @@ superclass of the newly-defined View Class."
 ;; Called by 'get-slot-values-from-view'
 ;;
 
-(declaim (inline delistify))
-(defun delistify (list)
-  (if (listp list)
-      (car list)
-      list))
 
 (defvar *update-context* nil)
 

diff --git a/tests/test-init.lisp b/tests/test-init.lisp
index 76a7bffc6496f97fc03f70d3b7a05ae5cf0312b6..c899867e2ea46dd2ffce5563906231ec40615e59 100644 (file)
--- a/tests/test-init.lisp
+++ b/tests/test-init.lisp
@@ -552,3 +552,10 @@
       (disconnect :database *default-database*))
   (test-connect-to-database :postgresql (car (postgresql-spec (read-specs))))
   (test-initialise-database))
+
+(defun rlm ()
+  "Rapid load for interactive testing."
+  (when *default-database*
+      (disconnect :database *default-database*))
+  (test-connect-to-database :mysql (car (mysql-spec (read-specs))))
+  (test-initialise-database))