From fcb0cac1b206dacdb3d1043b5393bbb510a00882 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Fri, 7 May 2004 05:53:13 +0000 Subject: [PATCH] r9279: Handle differences in direct-slot-definition values which are now listify by openmcl 14.2 --- ChangeLog | 2 ++ sql/metaclasses.lisp | 60 +++++++++++++++++++++++++++++++------------- sql/objects.lisp | 5 ---- tests/test-init.lisp | 7 ++++++ 4 files changed, 52 insertions(+), 22 deletions(-) diff --git a/ChangeLog b/ChangeLog index 891b6ba..a8ae5fe 100644 --- 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 e59a00a..a8b1563 100644 --- 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 )? - + (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 9050555..e0d2cef 100644 --- 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 76a7bff..c899867 100644 --- 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)) -- 2.34.1