X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fmetaclasses.lisp;h=1fde1eef9f2319b7045396d3d113b0f51bf1a17a;hp=6ee6d4d062062c536035f297e5a1d337e4b194e3;hb=39e2802cd264ddacb3ca59b3b2c5c38f202149de;hpb=9eb15c4b2f22f73c9a0692921904bb20b5d60673 diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp index 6ee6d4d..1fde1ee 100644 --- a/sql/metaclasses.lisp +++ b/sql/metaclasses.lisp @@ -83,15 +83,6 @@ ((stringp arg) (sql-escape arg)))) -(defun column-name-from-arg (arg) - (cond ((symbolp arg) - arg) - ((typep arg 'sql-ident) - (slot-value arg 'name)) - ((stringp arg) - (intern (symbol-name-default-case arg))))) - - (defun remove-keyword-arg (arglist akey) (let ((mylist arglist) (newlist ())) @@ -112,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 @@ -210,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 @@ -445,12 +421,7 @@ implementations." list)) (declaim (inline delistify-dsd)) -(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)) - +;; there is an :after method below too (defmethod initialize-instance :around ((obj view-class-direct-slot-definition) &rest initargs &key db-constraints db-kind type &allow-other-keys) @@ -465,6 +436,37 @@ implementations." type db-constraints)) initargs)) +(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) + (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 direct-slots) @@ -476,59 +478,26 @@ implementations." (let ((esd (call-next-method))) (typecase dsd (view-class-slot-definition-mixin - ;; Use the specified :column argument if it is supplied, otherwise - ;; the column slot is filled in with the slot-name, but transformed - ;; to be sql safe, - to _ and such. - (setf (slot-value esd 'column) - (column-name-from-arg - (if (slot-boundp dsd 'column) - (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) - (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)))) - - ;; 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))))))) + (setf (slot-value esd 'column) (compute-column-name 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) + (safe-copy-value db-info) + (%convert-db-info-to-hash esd)) (setf (specified-type esd) (delistify-dsd (specified-type dsd))) @@ -555,10 +524,8 @@ implementations." #+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)))) - + ;; has no column name if it is not a database column + (setf (slot-value esd 'column) nil) (setf (slot-value esd 'db-info) nil) (setf (slot-value esd 'db-kind) :virtual) (setf (specified-type esd) (slot-definition-type dsd))) @@ -573,8 +540,11 @@ implementations." result)) (defun slotdef-for-slot-with-class (slot class) - (find-if #'(lambda (d) (eql slot (slot-definition-name d))) - (class-slots class))) + (typecase slot + (standard-slot-definition slot) + (symbol + (find-if #'(lambda (d) (eql slot (slot-definition-name d))) + (class-slots class))))) #+ignore (eval-when (:compile-toplevel :load-toplevel :execute) @@ -585,3 +555,66 @@ implementations." #+kmr-normal-esdc (setq cl:*features* (delete :kmr-normal-esdc cl:*features*)) ) + +(defmethod database-identifier ( (name standard-db-class) + &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)) + (slot-definition-name name)) + database)) + +(defun find-standard-db-class (name &aux cls) + (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 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 key" + (eql :join (view-class-slot-db-kind slot-def))) + +(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))) +