Expand relational keys in table-class.

fukamachi · Jun 2, 2017 · 32805f1 · 32805f1
1 parent ba3a445
commit 32805f1
Show file tree

Hide file tree

Showing 2 changed files with 33 additions and 36 deletions.
diff --git a/src/core/class/table.lisp b/src/core/class/table.lisp
@@ -77,11 +77,41 @@
                 collect column))
     (values initargs parent-column-map)))
 
+(defun expand-relational-keys (class slot-name)
+  (let ((keys (slot-value class slot-name))
+        (direct-slots (c2mop:class-direct-slots class))
+        (db-slots (database-column-slots class)))
+    (labels ((expand-key (key)
+               (let ((slot (find key direct-slots
+                                 :key #'c2mop:slot-definition-name
+                                 :test #'eq)))
+                 (unless slot
+                   (error "Unknown column ~S is found in ~S." key slot-name))
+                 (if (ghost-slot-p slot)
+                     (mapcar #'c2mop:slot-definition-name
+                             (remove-if-not (lambda (ds)
+                                              (eq (table-column-type ds)
+                                                  (table-column-type slot)))
+                                            db-slots))
+                     (list key))))
+             (expand-keys (keys)
+               (loop for key in keys
+                     append (expand-key key))))
+      (setf (slot-value class slot-name)
+            (loop for key in keys
+                  if (listp key)
+                    collect (expand-keys key)
+                  else
+                    append (expand-key key))))))
+
 (defmethod initialize-instance :around ((class table-class) &rest initargs)
   (multiple-value-bind (initargs parent-column-map)
       (add-referencing-slots initargs)
     (let ((class (apply #'call-next-method class initargs)))
       (setf (slot-value class 'parent-column-map) parent-column-map)
+      (expand-relational-keys class 'primary-key)
+      (expand-relational-keys class 'unique-keys)
+      (expand-relational-keys class 'keys)
       class)))
 
 (defmethod reinitialize-instance :around ((class table-class) &rest initargs)
@@ -97,6 +127,9 @@
       (setf (getf initargs :table-name) nil))
     (let ((class (apply #'call-next-method class initargs)))
       (setf (slot-value class 'parent-column-map) parent-column-map)
+      (expand-relational-keys class 'primary-key)
+      (expand-relational-keys class 'unique-keys)
+      (expand-relational-keys class 'keys)
       class)))
 
 (defmethod c2mop:direct-slot-definition-class ((class table-class) &key &allow-other-keys)

diff --git a/src/core/dao/table.lisp b/src/core/dao/table.lisp
@@ -12,10 +12,7 @@
                 #:table-column-type
                 #:table-column-slots
                 #:table-column-references-column
-                #:table-primary-key
-                #:database-column-slots
                 #:create-table-sxql
-                #:ghost-slot-p
                 #:find-slot-by-name
                 #:find-child-columns)
   (:import-from #:mito.dao.column
@@ -149,33 +146,6 @@
                (dolist (reader (getf column :readers))
                  (make-relational-reader-method reader class name rel-class)))))
 
-(defun expand-relational-keys (class slot-name)
-  (let ((keys (slot-value class slot-name))
-        (direct-slots (c2mop:class-direct-slots class))
-        (db-slots (database-column-slots class)))
-    (labels ((expand-key (key)
-               (let ((slot (find key direct-slots
-                                 :key #'c2mop:slot-definition-name
-                                 :test #'eq)))
-                 (unless slot
-                   (error "Unknown column ~S is found in ~S." key slot-name))
-                 (if (ghost-slot-p slot)
-                     (mapcar #'c2mop:slot-definition-name
-                             (remove-if-not (lambda (ds)
-                                              (eq (table-column-type ds)
-                                                  (table-column-type slot)))
-                                            db-slots))
-                     (list key))))
-             (expand-keys (keys)
-               (loop for key in keys
-                     append (expand-key key))))
-      (setf (slot-value class slot-name)
-            (loop for key in keys
-                  if (listp key)
-                    collect (expand-keys key)
-                  else
-                    append (expand-key key))))))
-
 (defun depending-table-classes (class)
   (let ((class-name (class-name class)))
     (delete-duplicates
@@ -206,9 +176,6 @@
 
   (let ((class (apply #'call-next-method class initargs)))
     (add-relational-readers class initargs)
-    (expand-relational-keys class 'mito.class.table::primary-key)
-    (expand-relational-keys class 'mito.class.table::unique-keys)
-    (expand-relational-keys class 'mito.class.table::keys)
     class))
 
 (defmethod reinitialize-instance :around ((class dao-table-class) &rest initargs
@@ -226,9 +193,6 @@
 
   (let ((class (apply #'call-next-method class initargs)))
     (add-relational-readers class initargs)
-    (expand-relational-keys class 'mito.class.table::primary-key)
-    (expand-relational-keys class 'mito.class.table::unique-keys)
-    (expand-relational-keys class 'mito.class.table::keys)
     class))
 
 (defmethod c2mop:ensure-class-using-class :around ((class dao-table-class) name &rest keys