added docstrings and some join-slot-info accessor helper functions

diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp
index 1fde1eef9f2319b7045396d3d113b0f51bf1a17a..7a2fce71445b311a62a3dd27a6ad09a0f7f71aad 100644 (file)
--- a/sql/metaclasses.lisp
+++ b/sql/metaclasses.lisp
@@ -578,18 +578,40 @@ 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 key"
+  "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)))

diff --git a/sql/oodml.lisp b/sql/oodml.lisp
index 03aa551eb3ef4927c38054b15bf5f649ebef6d52..3b3ef5748c9ead8ddc77c5871a860049f2900f11 100644 (file)
--- a/sql/oodml.lisp
+++ b/sql/oodml.lisp
@@ -13,6 +13,7 @@
 (in-package #:clsql-sys)
 
 (defun find-normalized-key (obj)
+  "Find the first / primary key of a normalized object"
   (find-slot-if obj #'key-slot-p T T))
 
 (defun normalized-key-value (obj)
@@ -21,6 +22,7 @@
     (easy-slot-value obj (find-normalized-key obj))))
 
 (defun key-qualifier-for-instance (obj &key (database *default-database*) this-class)
+  "Generate a boolean sql-expression that identifies an object by its keys"
   (let* ((obj-class (or this-class (class-of obj)))
          (keys (keyslots-for-class obj-class))
          (normal-db-value (normalized-key-value obj)))
@@ -105,6 +107,7 @@
 
 
 (defmethod update-slot-with-null ((object standard-db-object) slotdef)
+  "sets a slot to the void value of the slot-def (usually nil)"
   (setf (easy-slot-value object slotdef)
         (slot-value slotdef 'void-value)))
 
@@ -131,6 +134,7 @@
                   (format nil slot-reader value))))))))
 
 (defmethod key-value-from-db (slotdef value database)
+  "TODO: is this deprecated? there are no uses anywhere in clsql"
   (declare (optimize (speed 3) #+cmu (extensions:inhibit-warnings 3)))
   (let ((slot-reader (view-class-slot-db-reader slotdef))
         (slot-type (specified-type slotdef)))
@@ -321,9 +325,7 @@
     ((obj standard-db-object) slot &key (database *default-database*))
   (update-record-from-slots obj slot :database database))
 
-
-
-(defmethod view-classes-and-storable-slots-for-instance ((obj standard-db-object))
+(defun view-classes-and-storable-slots (class)
   "Get a list of all the tables we need to update and the slots on them
 
    for non normalized classes we return the class and all its storable slots
@@ -331,8 +333,8 @@
    for normalized classes we return a list of direct slots and the class they
    came from for each normalized view class
   "
-  (let* ((view-class (class-of obj))
-         rtns)
+  (setf class (to-class class))
+  (let* (rtns)
     (labels ((storable-slots (class)
                (loop for sd in (slots-for-possibly-normalized-class class)
                      when (key-or-base-slot-p sd)
@@ -345,7 +347,7 @@
                  (loop for new-class in (class-direct-superclasses class)
                        do (when (typep new-class 'standard-db-class)
                             (get-classes-and-slots new-class))))))
-      (get-classes-and-slots view-class))
+      (get-classes-and-slots class))
     rtns))
 
 (defmethod primary-key-slot-values ((obj standard-db-object)
@@ -373,7 +375,7 @@
    view-database slot on the object is nil then the object is assumed to be
    new and is inserted"
   (let ((database (choose-database-for-instance obj database))
-        (classes-and-slots (view-classes-and-storable-slots-for-instance obj)))
+        (classes-and-slots (view-classes-and-storable-slots obj)))
     (loop for class-and-slots in classes-and-slots
           do (%update-instance-helper class-and-slots obj database))
     (setf (slot-value obj 'view-database) database)