X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=sql%2Fmetaclasses.lisp;h=d6ea70f9a9bd38d8be085e9c813f24f0c5698cd5;hb=47d5ae2b1454553fa6d71c08862c7dfc5df97a92;hp=c3c81bb0aeffa3be4398a3b4fbb4c5eb36c9df22;hpb=3b7cb72a2117fe5e4599da811c9e2821de02824b;p=clsql.git

diff --git a/sql/metaclasses.lisp b/sql/metaclasses.lisp
index c3c81bb..d6ea70f 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
 
@@ -570,10 +555,12 @@ implementations."
                                 &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))
@@ -584,3 +571,31 @@ 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 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)
+       (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)
+       (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)))
+