X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fmetaclasses.lisp;h=1c9a6c5b34583fe882886bdb6c65b7ce70f665cd;hp=73c67cb732300a26ae526628be0be36e8be37b76;hb=142fb42d3502f82883f7a49c9b0587bfc3de57b1;hpb=fef88dce7304920c0a87ac28ad81126802ccbfcf diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp index 73c67cb..1c9a6c5 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 @@ -454,10 +439,33 @@ implementations." (defun compute-column-name (arg) (database-identifier arg nil)) +(defun %convert-db-info-to-hash (slot-def) + ;; 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 slot-def 'db-info) + (when (slot-boundp slot-def 'db-info) + (let ((info (view-class-slot-db-info slot-def))) + (etypecase info + (hash-table info) + (atom info) + (list + (cond ((and (> (length info) 1) + (atom (car info))) + (parse-db-info info)) + ((and (= 1 (length info)) + (listp (car info))) + (parse-db-info (car info))) + (t info)))))))) + (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))) + (%convert-db-info-to-hash obj)) (defmethod compute-effective-slot-definition ((class standard-db-class) #+kmr-normal-cesd slot-name @@ -487,24 +495,9 @@ implementations." ;; :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 - ;; :join becomes :db-kind (:join )? - - (setf (slot-value esd 'db-info) - (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))))))) + (safe-copy-value db-constraints) + (safe-copy-value db-info) + (%convert-db-info-to-hash esd)) (setf (specified-type esd) (delistify-dsd (specified-type dsd))) @@ -549,9 +542,7 @@ implementations." (defun slotdef-for-slot-with-class (slot class) (typecase slot (standard-slot-definition slot) - (symbol - (find-if #'(lambda (d) (eql slot (slot-definition-name d))) - (class-slots class))))) + (symbol (find-slot-by-name class slot)))) #+ignore (eval-when (:compile-toplevel :load-toplevel :execute) @@ -567,10 +558,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)) @@ -581,3 +574,67 @@ implementations." (and (setf cls (ignore-errors (find-class name))) (typep cls 'standard-db-class) cls)) + +(defun slots-for-possibly-normalized-class (class) + "Get the slots for this class, if normalized this is only the direct slots + otherwiese its all the slots" + (if (normalizedp class) + (ordered-class-direct-slots class) + (ordered-class-slots class))) + + +(defun key-slot-p (slot-def) + "takes a slot def and returns whether or not it is a key" + (eql :key (view-class-slot-db-kind slot-def))) + +(defun join-slot-p (slot-def) + "takes a slot def and returns whether or not it is a join slot" + (eql :join (view-class-slot-db-kind slot-def))) + +(defun join-slot-info-value (slot-def key) + "Get the join-slot db-info value associated with a key" + (when (join-slot-p slot-def) + (let ((dbi (view-class-slot-db-info slot-def))) + (when dbi (gethash key dbi))))) + +(defun join-slot-retrieval-method (slot-def) + "if this is a join slot return the retrieval param in the db-info" + (join-slot-info-value slot-def :retrieval)) + +(defun join-slot-class-name (slot-def) + "get the join class name for a given join slot" + (join-slot-info-value slot-def :join-class)) + +(defun join-slot-class (slot-def) + "Get the join class for a given join slot" + (let ((c (join-slot-class-name slot-def))) + (when c (find-class c)))) + +(defun key-or-base-slot-p (slot-def) + "takes a slot def and returns whether or not it is a key" + (member (view-class-slot-db-kind slot-def) '(:key :base))) + +(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 (typep class 'standard-db-class) + (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 (typep class 'standard-db-class) + (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))) +