X-Git-Url: http://git.kpe.io/?p=clsql.git;a=blobdiff_plain;f=sql%2Fmetaclasses.lisp;h=1fde1eef9f2319b7045396d3d113b0f51bf1a17a;hp=ddaee4f0dc1da84bd7276c1e0f7e17ecbdcbb0f9;hb=39e2802cd264ddacb3ca59b3b2c5c38f202149de;hpb=2edf7f68a1dc681db575cda999283cac7e290a77

diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp
index ddaee4f..1fde1ee 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,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
@@ -490,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)))
@@ -586,3 +576,45 @@ implementations."
   (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)))
+