[isidorus-cvs] r291 - in branches/new-datamodel/src: model unit_tests

[Lukas Giessmann]

Author: lgiessmann
Date: Thu Apr 29 06:47:46 2010
New Revision: 291

Log:
new-datamodel: fixed a bug when merging topics by adding an item-identifier to two different variants of the topic's names that are mergable

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	Thu Apr 29 06:47:46 2010
@@ -4101,7 +4101,10 @@
 					(find older-char
 					      (variants name
 							:revision revision)))
-				    (names active-parent :revision revision))))))
+				    (if (parent active-parent :revision revision)
+					(names (parent active-parent :revision revision)
+					       :revision revision)
+					(list active-parent)))))))
 		       (if found-older-char
 			   older-char
 			   newer-char))))

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	Thu Apr 29 06:47:46 2010
@@ -89,13 +89,8 @@
 	   :test-merge-constructs-TopicC-6
 	   :test-merge-constructs-TopicC-7
 	   :test-merge-constructs-TopicC-8
-	   :test-merge-constructs-TopicC-9))
-
-
-;;TODO: test merge-constructs --> associations when merge was caused by
-;;      item-identifier of two roles
-;;TODO: test mark-as-deleted
-
+	   :test-merge-constructs-TopicC-9
+	   :test-merge-constructs-TopicC-10))
 
 
 (declaim (optimize (debug 3)))
@@ -3644,8 +3639,87 @@
 	  (is-false (set-exclusive-or (list occ-2) (occurrences top-2))))))))
 
 
-;;TODO: merge topics caused by variant-item-identifiers
-;;TODO: merge associations caused by a merge of their characteristics
+
+(test test-merge-constructs-TopicC-10 ()
+  "Tests the generic move-referenced-constructs corresponding to TopicC."
+  (with-fixture with-empty-db (*db-dir*)
+    (let ((rev-1 100)
+	  (rev-2 200)
+	  (rev-3 300)
+	  (psi-1 (make-construct 'PersistentIdC :uri "psi-1"))
+	  (psi-2 (make-construct 'PersistentIdC :uri "psi-2"))
+	  (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
+	  (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))
+	  (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3"))
+	  (ii-4 (make-construct 'ItemIdentifierC :uri "ii-4")))
+      (let ((top-1 (make-construct 'TopicC
+				   :start-revision rev-1
+				   :psis (list psi-1)))
+	    (top-2 (make-construct 'TopicC
+				   :start-revision rev-2
+				   :psis (list psi-2)))
+	    (type-1 (make-construct 'TopicC :start-revision rev-1))
+	    (scope-1 (make-construct 'TopicC :start-revision rev-1)))
+	(let ((name-1 (make-construct 'NameC
+				      :start-revision rev-1
+				      :instance-of nil
+				      :charvalue "name"
+				      :themes (list scope-1)
+				      :item-identifiers (list ii-1)
+				      :parent top-1))
+	      (name-2 (make-construct 'NameC
+				      :start-revision rev-1
+				      :instance-of type-1
+				      :charvalue "name"
+				      :themes (list scope-1)
+				      :parent top-1))
+	      (name-3 (make-construct 'NameC
+				      :start-revision rev-2
+				      :instance-of nil
+				      :charvalue "name"
+				      :themes (list scope-1)
+				      :item-identifiers (list ii-2)
+				      :parent top-2))
+	      (name-4  (make-construct 'NameC
+				      :start-revision rev-2
+				      :instance-of type-1
+				      :charvalue "name"
+				      :themes nil
+				      :parent top-2)))
+	  (let ((variant-1 (make-construct 'VariantC
+					   :start-revision rev-1
+					   :charvalue "variant"
+					   :themes (list scope-1)
+					   :item-identifiers (list ii-3 ii-4)
+					   :parent name-1))
+		(variant-2 (make-construct 'VariantC
+					  :start-revision rev-1
+					  :charvalue "variant"
+					  :themes (list scope-1)
+					  :parent name-4))
+		(variant-3 (make-construct 'VariantC
+					   :start-revision rev-2
+					   :charvalue "variant"
+					   :themes (list scope-1)
+					   :parent name-3)))
+	    (setf *TM-REVISION* rev-3)
+	    (signals not-mergable-error (add-item-identifier variant-2 ii-4))
+	    (is-false (marked-as-deleted-p top-2))
+	    (is-false (marked-as-deleted-p top-1))
+	    (is-false (marked-as-deleted-p name-4))
+	    (is (eql (add-item-identifier variant-3 ii-4) variant-1))
+	    (is-true (marked-as-deleted-p top-2))
+	    (is-false (names top-2))
+	    (is-false (psis top-2))
+	    (is-false (set-exclusive-or (list name-1 name-2 name-4) (names top-1)))
+	    (is-false (set-exclusive-or (list psi-1 psi-2) (psis top-1)))
+	    (is-false (set-exclusive-or (list variant-1) (variants name-1)))
+	    (is-false (set-exclusive-or (list variant-2) (variants name-4)))
+	    (is (= (length (d::versions top-1)) 2))))))))
+				      
+
+
+;;TODO: merge associations caused by a merge of their roles
 
 
 
@@ -3717,4 +3791,5 @@
   (it.bese.fiveam:run! 'test-merge-constructs-TopicC-7)
   (it.bese.fiveam:run! 'test-merge-constructs-TopicC-8)
   (it.bese.fiveam:run! 'test-merge-constructs-TopicC-9)
+  (it.bese.fiveam:run! 'test-merge-constructs-TopicC-10)
   )
\ No newline at end of file