X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fmetaclasses.lisp;h=d6ea70f9a9bd38d8be085e9c813f24f0c5698cd5;hb=47d5ae2b1454553fa6d71c08862c7dfc5df97a92;hp=df3c36e0e12f51836fc21e9c3557e0e02ce7cee3;hpb=f1d668746523a72a6893a46380468a9e033545e4;p=clsql.git diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp index df3c36e..d6ea70f 100644 --- a/sql/metaclasses.lisp +++ b/sql/metaclasses.lisp @@ -103,17 +103,6 @@ base-table)) (class-name class))))) -(defgeneric ordered-class-direct-slots (class)) -(defmethod ordered-class-direct-slots ((self standard-db-class)) - (let ((direct-slot-names - (mapcar #'slot-definition-name (class-direct-slots self))) - (ordered-direct-class-slots '())) - (dolist (slot (ordered-class-slots self)) - (let ((slot-name (slot-definition-name slot))) - (when (find slot-name direct-slot-names) - (push slot ordered-direct-class-slots)))) - (nreverse ordered-direct-class-slots))) - (defmethod initialize-instance :around ((class standard-db-class) &rest all-keys &key direct-superclasses base-table @@ -201,18 +190,14 @@ (setf (key-slots class) (remove-if-not (lambda (slot) (eql (slot-value slot 'db-kind) :key)) - (if (normalizedp class) - (ordered-class-direct-slots class) - (ordered-class-slots class)))))) + (slots-for-possibly-normalized-class class))))) #+(or sbcl allegro) (defmethod finalize-inheritance :after ((class standard-db-class)) (setf (key-slots class) (remove-if-not (lambda (slot) (eql (slot-value slot 'db-kind) :key)) - (if (normalizedp class) - (ordered-class-direct-slots class) - (ordered-class-slots class))))) + (slots-for-possibly-normalized-class class)))) ;; return the deepest view-class ancestor for a given view class @@ -457,7 +442,10 @@ implementations." (defmethod initialize-instance :after ((obj view-class-direct-slot-definition) &key &allow-other-keys) - (setf (view-class-slot-column obj) (compute-column-name obj))) + (setf (view-class-slot-column obj) (compute-column-name obj) + (view-class-slot-autoincrement-sequence obj) + (dequote + (view-class-slot-autoincrement-sequence obj)))) (defmethod compute-effective-slot-definition ((class standard-db-class) #+kmr-normal-cesd slot-name @@ -472,32 +460,22 @@ implementations." (view-class-slot-definition-mixin (setf (slot-value esd 'column) (compute-column-name dsd)) - (setf (slot-value esd 'db-type) - (when (slot-boundp dsd 'db-type) - (delistify-dsd - (view-class-slot-db-type dsd)))) - - (setf (slot-value esd 'void-value) - (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) - (delistify-dsd (view-class-slot-db-kind dsd)) - :base)) - - (setf (slot-value esd 'db-reader) - (when (slot-boundp dsd 'db-reader) - (delistify-dsd (view-class-slot-db-reader dsd)))) - (setf (slot-value esd 'db-writer) - (when (slot-boundp dsd 'db-writer) - (delistify-dsd (view-class-slot-db-writer dsd)))) - (setf (slot-value esd 'db-constraints) - (when (slot-boundp dsd 'db-constraints) - (delistify-dsd (view-class-slot-db-constraints dsd)))) + (macrolet + ((safe-copy-value (name &optional default) + (let ((fn (intern (format nil "~A~A" 'view-class-slot- name )))) + `(setf (slot-value esd ',name) + (or (when (slot-boundp dsd ',name) + (delistify-dsd (,fn dsd))) + ,default))))) + (safe-copy-value autoincrement-sequence) + (safe-copy-value db-type) + (safe-copy-value void-value) + (safe-copy-value db-reader) + (safe-copy-value db-writer) + ;; :db-kind slot value defaults to :base (store slot value in + ;; database) + (safe-copy-value db-kind :base) + (safe-copy-value db-constraints)) ;; I wonder if this slot option and the previous could be merged, ;; so that :base and :key remain keyword options, but :db-kind @@ -577,10 +555,12 @@ implementations." &optional database find-class-p) "the majority of this function is in expressions.lisp this is here to make loading be less painful (try-recompiles) in SBCL" + (declare (ignore find-class-p)) (database-identifier (view-table name) database)) (defmethod database-identifier ((name view-class-slot-definition-mixin) &optional database find-class-p) + (declare (ignore find-class-p)) (database-identifier (if (slot-boundp name 'column) (delistify-dsd (view-class-slot-column name)) @@ -591,3 +571,31 @@ implementations." (and (setf cls (ignore-errors (find-class name))) (typep cls 'standard-db-class) cls)) + +(defun slots-for-possibly-normalized-class (class) + (if (normalizedp class) + (ordered-class-direct-slots class) + (ordered-class-slots class))) + +(defun direct-normalized-slot-p (class slot-name) + "Is this a normalized class and if so is the slot one of our direct slots?" + (setf slot-name (to-slot-name slot-name)) + (and (normalizedp class) + (member slot-name (ordered-class-direct-slots class) + :key #'slot-definition-name))) + +(defun not-direct-normalized-slot-p (class slot-name) + "Is this a normalized class and if so is the slot not one of our direct slots?" + (setf slot-name (to-slot-name slot-name)) + (and (normalizedp class) + (not (member slot-name (ordered-class-direct-slots class) + :key #'slot-definition-name)))) + +(defun slot-has-default-p (slot) + "returns nil if the slot does not have a default constraint" + (let* ((constraints + (when (typep slot '(or view-class-direct-slot-definition + view-class-effective-slot-definition)) + (listify (view-class-slot-db-constraints slot))))) + (member :default constraints))) +