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

[Lukas Giessmann]

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