From 39e2802cd264ddacb3ca59b3b2c5c38f202149de Mon Sep 17 00:00:00 2001
From: Russ Tyndall <russ@acceleration.net>
Date: Tue, 20 Nov 2012 13:59:08 -0500
Subject: [PATCH] introduced slot-def kind predicates (eg: join-slot-p
 key-slot-p)

---
 sql/kmr-mop.lisp     | 25 ++++++++++++++++++-------
 sql/metaclasses.lisp | 18 ++++++++++++++++--
 sql/ooddl.lisp       |  2 +-
 sql/oodml.lisp       |  9 +++------
 4 files changed, 38 insertions(+), 16 deletions(-)

diff --git a/sql/kmr-mop.lisp b/sql/kmr-mop.lisp
index 75ccb5e..017aa0b 100644
--- a/sql/kmr-mop.lisp
+++ b/sql/kmr-mop.lisp
@@ -66,14 +66,25 @@
   #+mop-slot-order-reversed (reverse (class-direct-slots class))
   #-mop-slot-order-reversed (class-direct-slots class))
 
-(defun find-class-slot-by-name (class slot-name &optional direct?)
+(defun find-slot-by-name (class slot-name &optional direct? recurse?)
   "Looks up a direct-slot-definition by name"
-  (setf class (to-class class))
-  (find (to-slot-name slot-name)
-        (if direct?
-            (ordered-class-direct-slots class)
-            (ordered-class-slots class))
-        :key #'slot-definition-name))
+  (setf class (to-class class)
+        slot-name (to-slot-name slot-name))
+  (labels ((find-it (class)
+             (let* ((slots (if direct?
+                               (ordered-class-direct-slots class)
+                               (ordered-class-slots class)))
+                    (it (find slot-name
+                              slots
+                              :key #'slot-definition-name)))
+               (if it
+                   it
+                   (when recurse?
+                     (loop for sup in (class-direct-superclasses class)
+                           for rtn = (find-it sup)
+                           until rtn
+                           finally (return rtn)))))))
+    (find-it class)))
 
 ;; Lispworks has symbol for slot rather than the slot instance
 (defun %svuc-slot-name (slot)
diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp
index 61c12e0..1fde1ee 100644
--- a/sql/metaclasses.lisp
+++ b/sql/metaclasses.lisp
@@ -582,17 +582,31 @@ implementations."
       (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 (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))))
 
diff --git a/sql/ooddl.lisp b/sql/ooddl.lisp
index 9fb218f..25308e1 100644
--- a/sql/ooddl.lisp
+++ b/sql/ooddl.lisp
@@ -137,7 +137,7 @@ in DATABASE which defaults to *DEFAULT-DATABASE*."
 
 (defmethod database-generate-column-definition (class slotdef database)
   (declare (ignore class))
-  (when (member (view-class-slot-db-kind slotdef) '(:base :key))
+  (when (key-or-base-slot-p slotdef)
     (let ((cdef
            (list (sql-expression :attribute (database-identifier slotdef database))
                  (specified-type slotdef))))
diff --git a/sql/oodml.lisp b/sql/oodml.lisp
index 5469a03..bf9026b 100644
--- a/sql/oodml.lisp
+++ b/sql/oodml.lisp
@@ -219,7 +219,7 @@
                "Find the best class to associate with the slot. If it is
                 normalized then it needs to be a direct slot otherwise it just
                 needs to be on the class."
-               (let ((sd (find-class-slot-by-name class slot normalizedp)))
+               (let ((sd (find-slot-by-name class slot normalizedp nil)))
                  (if sd
                      ;;we found it directly or it's (not normalized)
                      (pushnew sd (slot-defs (get-c&s-obj class)))
@@ -310,10 +310,7 @@
     ((obj standard-db-object) slot &key (database *default-database*))
   (update-record-from-slots obj slot :database database))
 
-(defun %slot-storedp (slot-def)
-  "Whether or not a slot should be stored in the database based on its db-kind
-   and whether it is bound"
-  (member (view-class-slot-db-kind slot-def) '(:base :key)))
+
 
 (defmethod view-classes-and-storable-slots-for-instance ((obj standard-db-object))
   "Get a list of all the tables we need to update and the slots on them
@@ -327,7 +324,7 @@
          rtns)
     (labels ((storable-slots (class)
                (loop for sd in (slots-for-possibly-normalized-class class)
-                     when (%slot-storedp sd)
+                     when (key-or-base-slot-p sd)
                      collect sd))
              (get-classes-and-slots (class &aux (normalizedp (normalizedp class)))
                (let ((slots (storable-slots class)))
-- 
2.34.1