Merge pull request #137 from fukamachi/self-reference

Self referencing

Author: fukamachi

docker-compose.yml

@@ -15,24 +15,26 @@ services:
       - postgres
       - mysql
     environment:
-      POSTGRES_HOST: postgres
+      POSTGRES_HOST: mito-test-postgres
       POSTGRES_USER: mito
       POSTGRES_PASS: mito
-      MYSQL_HOST: mysql
+      MYSQL_HOST: mito-test-mysql
       MYSQL_USER: root
       MYSQL_PASS: mito
 
   postgres:
     container_name: mito-postgres
     image: "postgres:10"
+    hostname: mito-test-postgres
     restart: always
     environment:
       POSTGRES_USER: mito
       POSTGRES_PASSWORD: mito
 
   mysql:
     container_name: mito-mysql
-    image: "mysql:8"
+    image: "mysql:8.4"
+    hostname: mito-test-mysql
     restart: always
     command: --mysql_native_password=ON
     environment:

src/core/class/table.lisp

@@ -42,27 +42,37 @@
    (format nil "~:@(~A-~A~)" name pk-name)))
 
 (defun add-referencing-slots (initargs)
-  (let ((parent-column-map (make-hash-table :test 'eq)))
+  (let ((parent-column-map (make-hash-table :test 'eq))
+        (class-name (getf initargs :name)))
     (setf (getf initargs :direct-slots)
           (loop for column in (getf initargs :direct-slots)
                 for (col-type not-null) = (multiple-value-list (parse-col-type (getf column :col-type)))
 
                 if (typep col-type '(and symbol (not null) (not keyword)))
                   append
-                  (let* ((name (getf column :name))
-                         ;; FIXME: find-class raises an error if the class is this same class or not defined yet.
-                         (rel-class (find-class col-type))
-                         (pk-names (table-primary-key rel-class)))
+                  (let* ((column-name (getf column :name))
+                         ;; FIXME: find-class raises an error if the class is not defined yet.
+                         (pk-names (if (eq col-type class-name)
+                                       (or (getf initargs :primary-key)
+                                           (getf (find-if (lambda (column-def)
+                                                            (getf column-def :primary-key))
+                                                          (getf initargs :direct-slots))
+                                                 :name)
+                                           (loop for superclass in (getf initargs :direct-superclasses)
+                                                 for pk-names = (table-primary-key superclass)
+                                                 until pk-names
+                                                 finally (return pk-names)))
+                                       (table-primary-key (find-class col-type)))))
                     (unless pk-names
-                      (error "Foreign class ~S has no primary keys."
-                             (class-name rel-class)))
+                      (error "Primary keys can not be determined for ~A."
+                             col-type))
                     (rplacd (cdr column)
                             `(:ghost t ,@(cddr column)))
 
                     (cons column
                           (mapcar (lambda (pk-name)
-                                    (let ((rel-column-name (rel-column-name name pk-name)))
-                                      (setf (gethash rel-column-name parent-column-map) name)
+                                    (let ((rel-column-name (rel-column-name column-name pk-name)))
+                                      (setf (gethash rel-column-name parent-column-map) column-name)
                                       `(:name ,rel-column-name
                                         :initargs (,(intern (symbol-name rel-column-name) :keyword))
                                         :col-type ,(if not-null

src/core/dao/mixin.lisp

@@ -68,7 +68,7 @@
       (setf (dao-synced obj) t)
       obj)))
 
-(defun make-relational-reader-method (func-name class slot-name rel-class)
+(defun make-relational-reader-method (func-name class slot-name rel-class-name)
   (let ((generic-function
           (ensure-generic-function func-name :lambda-list '(object))))
     (add-method
@@ -99,7 +99,7 @@
                                                   (first
                                                    (mito.db:retrieve-by-sql
                                                     (sxql:select :*
-                                                      (sxql:from (sxql:make-sql-symbol (table-name rel-class)))
+                                                      (sxql:from (sxql:make-sql-symbol (table-name (find-class rel-class-name))))
                                                       (sxql:where
                                                        `(:and
                                                          ,@(mapcar (lambda (slot-name)
@@ -111,7 +111,7 @@
                                                                    child-columns)))
                                                       (sxql:limit 1))))))
                                             (and result
-                                                 (apply #'make-dao-instance rel-class result))))))
+                                                 (apply #'make-dao-instance rel-class-name result))))))
                               (setf calledp t
                                     (slot-value object slot-name) foreign-object)))))))))
 
@@ -121,11 +121,9 @@
         when (and (symbolp col-type)
                   (not (null col-type))
                   (not (keywordp col-type)))
-        do (let* ((name (c2mop:slot-definition-name column))
-                  ;; FIXME: find-class returns NIL if the class is this same class
-                  (rel-class (find-class col-type)))
+        do (let ((name (c2mop:slot-definition-name column)))
              (dolist (reader (c2mop:slot-definition-readers column))
-               (make-relational-reader-method reader class name rel-class)))))
+               (make-relational-reader-method reader class name col-type)))))
 
 (defmethod initialize-instance :around ((class dao-table-mixin) &rest initargs
                                         &key conc-name &allow-other-keys)

t/class.lisp

@@ -299,3 +299,29 @@
                   "CREATE TABLE tweet_tags (
     tweet1_id BIGINT UNSIGNED
 )"))
+
+(deftest self-reference
+  (is-table-class :mysql
+                  (defclass category ()
+                    ((parent :col-type category
+                             :initarg :parent
+                             :accessor parent))
+                    (:metaclass mito:dao-table-class))
+                  "CREATE TABLE category (
+    id BIGINT UNSIGNED NOT NULL AUTO_INCREMENT PRIMARY KEY,
+    parent_id BIGINT UNSIGNED NOT NULL,
+    created_at TIMESTAMP,
+    updated_at TIMESTAMP
+)")
+  (is-table-class :postgres
+                  (defclass category ()
+                    ((parent :col-type category
+                             :initarg :parent
+                             :accessor parent))
+                    (:metaclass mito:dao-table-class))
+                  "CREATE TABLE category (
+    id BIGSERIAL NOT NULL PRIMARY KEY,
+    parent_id BIGINT NOT NULL,
+    created_at TIMESTAMPTZ,
+    updated_at TIMESTAMPTZ
+)"))

t/migration/postgres.lisp

@@ -294,12 +294,12 @@
         "No migration after migrating"))
 
   (testing "composite primary keys"
-    (when (find-class 'tag nil)
-      (setf (find-class 'tag) nil))
-    (execute-sql "DROP TABLE IF EXISTS tag")
     (when (find-class 'tweets-tag nil)
       (setf (find-class 'tweets-tag) nil))
     (execute-sql "DROP TABLE IF EXISTS tweets_tag")
+    (when (find-class 'tag nil)
+      (setf (find-class 'tag) nil))
+    (execute-sql "DROP TABLE IF EXISTS tag")
 
     (defclass tag ()
       ((name :col-type (:varchar 10)