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

[Lukas Giessmann]

Author: lgiessmann
Date: Thu Apr  8 11:00:35 2010
New Revision: 270

Log:
new-datamodel: modified "move-referenced-constructs" --> "NameC"; added some unti-tests

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  8 11:00:35 2010
@@ -3539,28 +3539,30 @@
     (move-identifiers source destination :revision revision)
     (let ((source-reifier (reifier source :revision revision))
 	  (destination-reifier (reifier destination :revision revision)))
-      (list
-       (cond ((and source-reifier destination-reifier)
-	      (delete-reifier (reified-construct source-reifier
-						 :revision revision)
-			      source-reifier :revision revision)
-	      (delete-reifier (reified-construct destination-reifier
-						 :revision revision)
-			      destination-reifier :revision revision)
-	      (let ((merged-reifier
-		     (merge-constructs source-reifier destination-reifier
-				       :revision revision)))
-		(add-reifier destination merged-reifier :revision revision)
-		merged-reifier))
-	     (source-reifier
-	      (delete-reifier (reified-construct source-reifier
-						 :revision revision)
-			      source-reifier :revision revision)
-	      (add-reifier destination source-reifier :revision revision)
-	      source-reifier)
-	     (destination-reifier
-	      (add-reifier destination destination-reifier :revision revision)
-	      destination-reifier)))))))
+      (let ((result
+	     (cond ((and source-reifier destination-reifier)
+		    (delete-reifier (reified-construct source-reifier
+						       :revision revision)
+				    source-reifier :revision revision)
+		    (delete-reifier (reified-construct destination-reifier
+						       :revision revision)
+				    destination-reifier :revision revision)
+		    (let ((merged-reifier
+			   (merge-constructs source-reifier destination-reifier
+					     :revision revision)))
+		      (add-reifier destination merged-reifier :revision revision)
+		      merged-reifier))
+		   (source-reifier
+		    (delete-reifier (reified-construct source-reifier
+						       :revision revision)
+				    source-reifier :revision revision)
+		    (add-reifier destination source-reifier :revision revision)
+		    source-reifier)
+		   (destination-reifier
+		    (add-reifier destination destination-reifier :revision revision)
+		    nil))))
+	(when result
+	  (list result)))))))
 
 
 (defmethod move-referenced-constructs ((source NameC) (destination NameC)

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  8 11:00:35 2010
@@ -79,7 +79,8 @@
 	   :test-make-AssociationC
 	   :test-make-TopicC
 	   :test-find-oldest-construct
-	   :test-move-referenced-constructs-ReifiableConstructC))
+	   :test-move-referenced-constructs-ReifiableConstructC
+	   :test-move-referenced-constructs-NameC))
 
 
 ;;TODO: test merge-constructs
@@ -2836,6 +2837,86 @@
 	  (is-true (d::marked-as-deleted-p reifier-1)))))))
 
 
+(test test-move-referenced-constructs-NameC ()
+  "Tests the generic move-referenced-constructs corresponding to NameC."
+  (with-fixture with-empty-db (*db-dir*)
+    (let ((rev-1 100)
+	  (rev-2 200))
+      (let ((ii-1 (make-construct 'ItemIdentifierC :uri "ii-1"))
+	    (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2"))
+	    (reifier-1 (make-construct 'TopicC :start-revision rev-1))
+	    (reifier-2 (make-construct 'TopicC :start-revision rev-2))
+	    (type-1 (make-construct 'TopicC :start-revision rev-1))
+	    (theme-1 (make-construct 'TopicC :start-revision rev-1))
+	    (theme-2 (make-construct 'TopicC :start-revision rev-1)))
+	(let ((variant-1 (make-construct 'VariantC
+					 :start-revision rev-1
+					 :themes (list theme-1)
+					 :charvalue "var-1"
+					 :item-identifiers (list ii-1)
+					 :reifier reifier-2))
+	      (variant-2 (make-construct 'VariantC
+					 :start-revision rev-1
+					 :themes (list theme-1)
+					 :charvalue "var-2+4"))
+	      (variant-3 (make-construct 'VariantC
+					 :start-revision rev-1
+					 :themes (list theme-2)
+					 :charvalue "var-3"))
+	      (variant-4 (make-construct 'VariantC
+					 :start-revision rev-1
+					 :themes (list theme-1)
+					 :charvalue "var-2+4")))
+	  (let ((name-1 (make-construct 'NameC
+					:start-revision rev-1
+					:charvalue "name"
+					:variants (list variant-1 variant-2)
+					:instance-of type-1
+					:item-identifiers (list ii-2)))
+		(name-2 (make-construct 'NameC
+					:start-revision rev-1
+					:charvalue "name"
+					:variants (list variant-3 variant-4)
+					:instance-of type-1
+					:reifier reifier-1)))
+	    (setf *TM-REVISION* rev-1)
+	    (is (= (length (union (list variant-1 variant-2)
+				  (variants name-1))) 2))
+	    (is (= (length (union (list variant-3 variant-4)
+				  (variants name-2))) 2))
+	    (is-false (reifier name-1))
+	    (is (eql reifier-1 (reifier name-2)))
+	    (is (= (length
+		    (union (list variant-1 variant-2 ii-2)
+			   (d::move-referenced-constructs name-1 name-2
+							  :revision rev-2)))
+		   3))
+	    (is-false (item-identifiers name-1 :revision rev-2))
+	    (is-false (reifier name-1 :revision rev-2))
+	    (is-false (variants name-1 :revision rev-2))
+	    (is (= (length (item-identifiers name-2 :revision rev-2)) 1))
+	    (is (= (length (union (list ii-2)
+				  (item-identifiers name-2 :revision rev-2)))
+		   1))
+	    (is (eql (reifier name-2 :revision rev-2) reifier-1))
+	    (is (= (length (variants name-2 :revision rev-2)) 3))
+	    (is (= (length (union (list variant-1 variant-3 variant-4)
+				  (variants name-2 :revision rev-2)))
+		   3))
+	    (is-true 
+	     (find-if 
+	      #'(lambda(var)
+		  (and (= (length (item-identifiers var :revision rev-2)) 1)
+		       (string= (uri (first (item-identifiers var
+							      :revision rev-2)))
+				"ii-1")))
+	      (variants name-2 :revision rev-2)))
+	    (is-true 
+	     (find-if #'(lambda(var)
+			  (eql (reifier var :revision rev-2) reifier-2))
+		      (variants name-2 :revision rev-2)))))))))
+
+
 
 
 (defun run-datamodel-tests()
@@ -2895,4 +2976,5 @@
   (it.bese.fiveam:run! 'test-make-TopicC)
   (it.bese.fiveam:run! 'test-find-oldest-construct)
   (it.bese.fiveam:run! 'test-move-referenced-constructs-ReifiableConstructC)
+  (it.bese.fiveam:run! 'test-move-referenced-constructs-NameC)
   )
\ No newline at end of file