Author: lgiessmann Date: Fri Feb 26 03:07:41 2010 New Revision: 212 Log: new-datamodel: added some unit-test for NameC; fixed a bug in delete-name and add-name Modified: branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/unit_tests/datamodel_test.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Fri Feb 26 03:07:41 2010 @@ -948,15 +948,16 @@ an error is thrown.") (:method ((construct TopicC) (name NameC) &key (revision *TM-REVISION*)) - (when (and (parent name) - (not (eql (parent name) construct))) + (when (and (parent name :revision revision) + (not (eql (parent name :revision revision) construct))) (error "From add-name(): ~a can't be owned by ~a since it is already owned by the topic ~a" - name construct (parent name))) + name construct (parent name :revision revision))) (let ((all-names (map 'list #'characteristic (slot-p construct 'names)))) (if (find name all-names) (let ((name-assoc (loop for name-assoc in (slot-p construct 'names) - when (eql (parent-construct name-assoc) name) + when (eql (parent-construct name-assoc) + construct) return name-assoc))) (add-to-version-history name-assoc :start-revision revision)) (let ((assoc @@ -973,7 +974,7 @@ (:method ((construct TopicC) (name NameC) &key (revision (error "From delete-name(): revision must be set"))) (let ((assoc-to-delete (loop for name-assoc in (slot-p construct 'names) - when (eql (parent-construct name-assoc) name) + when (eql (parent-construct name-assoc) construct) return name-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/datamodel_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp Fri Feb 26 03:07:41 2010 @@ -29,7 +29,8 @@ :test-get-item-by-psi :test-ReifiableConstructC :test-OccurrenceC - :test-VariantC)) + :test-VariantC + :test-NameC)) ;;TODO: test delete-construct @@ -573,7 +574,7 @@ (test test-VariantC () -"Tests various functions of VariantC." + "Tests various functions of VariantC." (with-fixture with-empty-db (*db-dir*) (let ((v-1 (make-instance 'VariantC)) (v-2 (make-instance 'VariantC)) @@ -618,7 +619,6 @@ (is (eql (parent v-1) name-2)) (is (eql (parent v-1 :revision revision-2) name-1)) (delete-parent v-2 name-1 :revision revision-4) - (format t "-->") (is-false (parent v-2 :revision revision-4)) (is (eql name-1 (parent v-2 :revision revision-3))) (add-parent v-2 name-1 :revision revision-5) @@ -630,6 +630,65 @@ (is-false (parent v-2)) (add-parent v-2 name-1 :revision revision-8) (is (eql name-1 (parent v-2)))))) + + +(test test-NameC () + "Tests various functions of NameC." + (with-fixture with-empty-db (*db-dir*) + (let ((name-1 (make-instance 'NameC)) + (name-2 (make-instance 'NameC)) + (top-1 (make-instance 'TopicC)) + (top-2 (make-instance 'TopicC)) + (revision-1 100) + (revision-2 200) + (revision-3 300) + (revision-4 400) + (revision-5 500) + (revision-6 600) + (revision-7 700) + (revision-8 800)) + (setf *TM-REVISION* revision-1) + (is-false (parent name-1)) + (is-false (names top-1)) + (add-name top-1 name-1 :revision revision-1) + (is (= (length (union (list name-1) + (names top-1))) 1)) + (add-name top-1 name-2 :revision revision-2) + (is (= (length (union (list name-1 name-2) + (names top-1))) 2)) + (is (= (length (union (list name-1) + (names top-1 :revision revision-1))) 1)) + (add-name top-1 name-2 :revision revision-3) + (is (= (length (d::slot-p top-1 'd::names)) 2)) + (delete-name top-1 name-1 :revision revision-4) + (is (= (length (union (list name-2) + (names top-1 :revision revision-4))) 1)) + (is (= (length (union (list name-2) + (names top-1))) 1)) + (is (= (length (union (list name-1 name-2) + (names top-1 :revision revision-2))) 2)) + (add-name top-1 name-1 :revision revision-4) + (is (= (length (union (list name-2 name-1) + (names top-1))) 2)) + (signals error (add-name top-2 name-1 :revision revision-4)) + (delete-name top-1 name-1 :revision revision-5) + (is (= (length (union (list name-2) + (names top-1 :revision revision-5))) 1)) + (add-name top-2 name-1 :revision revision-5) + (is (eql (parent name-1) top-2)) + (is (eql (parent name-1 :revision revision-2) top-1)) + (delete-parent name-2 top-1 :revision revision-4) + (is-false (parent name-2 :revision revision-4)) + (is (eql top-1 (parent name-2 :revision revision-3))) + (add-parent name-2 top-1 :revision revision-5) + (is-false (parent name-2 :revision revision-4)) + (is (eql top-1 (parent name-2))) + (delete-parent name-2 top-1 :revision revision-6) + (add-parent name-2 top-2 :revision revision-7) + (delete-parent name-2 top-2 :revision revision-8) + (is-false (parent name-2)) + (add-parent name-2 top-1 :revision revision-8) + (is (eql top-1 (parent name-2)))))) @@ -647,4 +706,5 @@ (it.bese.fiveam:run! 'test-ReifiableConstructC) (it.bese.fiveam:run! 'test-OccurrenceC) (it.bese.fiveam:run! 'test-VariantC) + (it.bese.fiveam:run! 'test-NameC) ) \ No newline at end of file