X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fmetaclasses.lisp;h=f4c87e09843314ec36897de2bb567b46eb8d2305;hp=082b1d3c111079a487953b643751d1ad5a8cd231;hb=e622ee6f4bf2b9fe81af59d566e651c983a4833b;hpb=2d4e5fd3f01bd461e573e246c0fd9b6a944d8e5a diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp index 082b1d3..f4c87e0 100644 --- a/sql/metaclasses.lisp +++ b/sql/metaclasses.lisp @@ -12,7 +12,7 @@ ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* -(in-package #:clsql) +(in-package #:clsql-sys) (eval-when (:compile-toplevel :load-toplevel :execute) (when (>= (length (generic-function-lambda-list @@ -60,11 +60,13 @@ :db-writer :db-info)) (defvar +extra-class-options+ '(:base-table)) +#+lispworks (dolist (slot-option +extra-slot-options+) - (process-slot-option standard-db-class slot-option)) + (eval `(process-slot-option standard-db-class ,slot-option))) +#+lispworks (dolist (class-option +extra-class-options+) - (process-class-option standard-db-class class-option)) + (eval `(process-class-option standard-db-class ,class-option))) (defmethod validate-superclass ((class standard-db-class) (superclass standard-class)) @@ -190,13 +192,13 @@ (setq all-slots (remove-if #'not-db-col all-slots)) (setq all-slots (stable-sort all-slots #'string< :key #'car)) (setf (object-definition class) all-slots)) - #-(or allegro openmcl) + #-allegro (setf (key-slots class) (remove-if-not (lambda (slot) (eql (slot-value slot 'db-kind) :key)) (ordered-class-slots class))))) -#+(or allegro openmcl) +#+allegro (defmethod finalize-inheritance :after ((class standard-db-class)) (setf (key-slots class) (remove-if-not (lambda (slot) (eql (slot-value slot 'db-kind) @@ -237,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 @@ -353,11 +357,12 @@ 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) +#-mop-slot-order-reversed (defmethod compute-slots ((class standard-db-class)) "Need to sort order of class slots so they are the same across implementations." @@ -378,7 +383,6 @@ implementations." (defun compute-lisp-type-from-slot-specification (slotd specified-type) "Computes the Lisp type for a user-specified type. Needed for OpenMCL which does type checking before storing a value in a slot." - (declare (ignore slotd)) ;; This function is called after the base compute-effective-slots is called. ;; OpenMCL sets the type-predicate based on the initial value of the slots type. ;; so we have to override the type-predicates here @@ -392,9 +396,9 @@ which does type checking before storing a value in a slot." specified-type))) ((eq (ensure-keyword specified-type) :bigint) 'integer) - #+openmcl - ((null specified-type) - t) + ((and specified-type + (not (eql :not-null (slot-value slotd 'db-constraints)))) + `(or null ,specified-type)) (t specified-type))) @@ -402,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) @@ -427,58 +445,73 @@ 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 - (change-class esd 'view-class-effective-slot-definition - #+allegro :name - #+allegro (slot-definition-name dsd)) + (let ((type-predicate #+openmcl (slot-value esd 'ccl::type-predicate))) + #-openmcl (declare (ignore type-predicate)) + (change-class esd 'view-class-effective-slot-definition + #+allegro :name + #+allegro (slot-definition-name dsd)) + #+openmcl (setf (slot-value esd 'ccl::type-predicate) + type-predicate)) (setf (slot-value esd 'column) (column-name-from-arg (sql-escape (slot-definition-name dsd)))) - + (setf (slot-value esd 'db-info) nil) - (setf (slot-value esd 'db-kind) - :virtual))) + (setf (slot-value esd 'db-kind) :virtual) + (setf (specified-type esd) (slot-definition-type dsd))) + ) esd))) (defun slotdefs-for-slots-with-class (slots class)