Simplify slotdefs-for-slots-with-class by using existing function.

[clsql.git] / sql / metaclasses.lisp

diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp
index d6ea70f9a9bd38d8be085e9c813f24f0c5698cd5..1c9a6c5b34583fe882886bdb6c65b7ce70f665cd 100644 (file)
--- a/sql/metaclasses.lisp
+++ b/sql/metaclasses.lisp
@@ -439,13 +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 <db info .... >)?
+  (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))))
+         (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
@@ -475,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 <db info .... >)?
-
-         (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)))
@@ -537,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)
@@ -573,21 +576,57 @@ implementations."
        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 (normalizedp class)
+  (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 (normalizedp class)
+  (and (typep class 'standard-db-class)
+       (normalizedp class)
        (not (member slot-name (ordered-class-direct-slots class)
                     :key #'slot-definition-name))))