Commit 657b84eb authored by ryszard.szopa's avatar ryszard.szopa
Browse files

bugfix in many-to-many definition+unit-tests.

darcs-hash:d559958191588620fee3a699a6100a8585f4e188
parent a0e44295
...@@ -211,12 +211,14 @@ be used to create the link table." ...@@ -211,12 +211,14 @@ be used to create the link table."
(mapcar #',class2-name (select-dao-fun ',table-name (list := ',class1-name (get-id object))))) (mapcar #',class2-name (select-dao-fun ',table-name (list := ',class1-name (get-id object)))))
(defmethod ,class2-method-name ((object ,class2-name)) (defmethod ,class2-method-name ((object ,class2-name))
(mapcar #',class1-name (select-dao-fun ',table-name (list := ',class2-name (get-id object))))) (mapcar #',class1-name (select-dao-fun ',table-name (list := ',class2-name (get-id object)))))
(defmethod relatedp-method ((object1 ,class1-name) (object2 ,class2-name) (relation ,(if name '(eql name) 'null))) (defmethod relatedp-method ((object1 ,class1-name) (object2 ,class2-name) (relation ,(if name `(eql ',name) 'null)))
(select-dao-fun ',table-name `(and (select-dao-fun ',table-name `(and
(:= ,',class1-name ,(get-id object1)) (:= ,',class1-name ,(get-id object1))
(:= ,',class2-name ,(get-id object2))))) (:= ,',class2-name ,(get-id object2)))))
(defmethod relatedp-method ((object2 ,class2-name) (object1 ,class1-name) relation)
(relatedp-method object1 object2 relation))
(defmethod relate-method (defmethod relate-method
((object1 ,class1-name) (object2 ,class2-name) (relation ,(if name '(eql name) 'null)) weight) ((object1 ,class1-name) (object2 ,class2-name) (relation ,(if name `(eql ',name) 'null)) weight)
(let ((instance (make-instance ',table-name :weight weight))) (let ((instance (make-instance ',table-name :weight weight)))
(setf (slot-value instance ',class1-name) object1) (setf (slot-value instance ',class1-name) object1)
(setf (slot-value instance ',class2-name) object2) (setf (slot-value instance ',class2-name) object2)
...@@ -225,8 +227,8 @@ be used to create the link table." ...@@ -225,8 +227,8 @@ be used to create the link table."
(defmethod relate-method ((object1 ,class2-name) (object2 ,class1-name) relation weight) (defmethod relate-method ((object1 ,class2-name) (object2 ,class1-name) relation weight)
(relate-method object2 object1 relation weight)) (relate-method object2 object1 relation weight))
(defmethod unrelate-method ((object1 ,class1-name) (object2 ,class2-name) (relation ,(if name '(eql name) 'null))) (defmethod unrelate-method ((object1 ,class1-name) (object2 ,class2-name) (relation ,(if name `(eql ',name) 'null)))
(delete-dao (car (relatedp object1 object2)))) (delete-dao (car (relatedp object1 object2 relation))))
(defmethod unrelate-method ((object2 ,class2-name) (object1 ,class1-name) relation) (defmethod unrelate-method ((object2 ,class2-name) (object1 ,class1-name) relation)
(unrelate-method object1 object2 relation))))) (unrelate-method object1 object2 relation)))))
...@@ -256,6 +258,7 @@ assumed." ...@@ -256,6 +258,7 @@ assumed."
"Make a DAO and immediately save it. Takes the same arguments as "Make a DAO and immediately save it. Takes the same arguments as
\(make-instance \(\(dao dao\)\)\)." \(make-instance \(\(dao dao\)\)\)."
`(save-dao (make-instance ,type ,@rest))) `(save-dao (make-instance ,type ,@rest)))
;;; Copyright (C) 2007 ;;; Copyright (C) 2007
;;; Ryszard Szopa <ryszard.szopa@gmail.com> & ;;; Ryszard Szopa <ryszard.szopa@gmail.com> &
;;; Streamtech http://streamtech.nl/ ;;; Streamtech http://streamtech.nl/
......
...@@ -101,6 +101,31 @@ metaclass set to HTML and the right connection-spec." ...@@ -101,6 +101,31 @@ metaclass set to HTML and the right connection-spec."
((bar :type integer))) ((bar :type integer)))
(defmany foo bar))) (defmany foo bar)))
(db-test (named-many-to-many-definition :depends-on many-to-many-definition)
(defdao-example foo ()
((foo :type integer)))
(defdao-example bar ()
((bar :type integer)))
(finishes (defmany foo bar :name barfoo)))
(db-test (named-many-to-many :depends-on named-many-to-many-definition)
(defdao-example foo ()
())
(defdao-example bar ()
())
(defmany foo bar :name barfoo-1)
(defmany foo bar :name barfoo-2)
(let ((bar (make-and-save 'bar))
(foo (make-and-save 'foo))
(foo2 (make-and-save 'foo)))
(relate bar foo :relation 'barfoo-1)
(relate bar foo2 :relation 'barfoo-2)
(is (relatedp foo bar 'barfoo-1))
(is-false (relatedp bar foo2 'barfoo-1))
(is (relatedp bar foo2 'barfoo-2))
(unrelate bar foo2 :relation 'barfoo-2)
(is-false (relatedp foo2 bar 'barfoo-2))))
(db-test (many-to-many-redefinition :depends-on many-to-many-definition) (db-test (many-to-many-redefinition :depends-on many-to-many-definition)
(finishes (finishes
(defdao-example foo () (defdao-example foo ()
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment