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

Lukas Giessmann lgiessmann at common-lisp.net
Mon Mar 22 16:24:54 UTC 2010


Author: lgiessmann
Date: Mon Mar 22 12:24:54 2010
New Revision: 245

Log:
new-datamodel: added "add-to-version-history" to all "add-<item>" and "delete-<item>" that are defined for "VersionedConstructC"

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	Mon Mar 22 12:24:54 2010
@@ -171,8 +171,6 @@
 ;;TODO: implement merge-construct -> ReifiableConstructC -> ...
 ;;      the method should merge two constructs that are inherited from
 ;;      ReifiableConstructC
-;;TODO: implement find-item-by-revision for all classes that don't have their
-;;      one revision-infos --> PointerC, CharacteristicC, RoleC
 
 
 ;;; globals ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -747,6 +745,16 @@
 
 
 ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+(defgeneric delete-parent (construct parent-construct &key revision)
+  (:documentation "Sets the assoication-object between the passed
+                   constructs as marded-as-deleted."))
+
+
+(defgeneric add-parent (construct parent-construct &key revision)
+  (:documentation "Adds the parent-construct (TopicC or NameC) in form of
+                   a corresponding association to the given object."))
+
+
 (defgeneric find-item-by-revision (construct revision
 					     &optional parent-construct)
   (:documentation "Returns the given object if it exists in the passed
@@ -1283,6 +1291,7 @@
 			      return ti-assoc)))
       (when assoc-to-delete
 	(mark-as-deleted assoc-to-delete :revision revision))
+      (add-to-version-history construct :start-revision revision)
       construct)))
 
 
@@ -1338,6 +1347,7 @@
 			      return psi-assoc)))
       (when assoc-to-delete
 	(mark-as-deleted assoc-to-delete :revision revision))
+      (add-to-version-history construct :start-revision revision)
       construct)))
 
 
@@ -1394,6 +1404,7 @@
 			      return loc-assoc)))
       (when assoc-to-delete
 	(mark-as-deleted assoc-to-delete :revision revision))
+      (add-to-version-history construct :start-revision revision)
       construct)))
 
 
@@ -1452,6 +1463,7 @@
 			      return name-assoc)))
       (when assoc-to-delete
 	(mark-as-deleted assoc-to-delete :revision revision))
+      (add-to-version-history construct :start-revision revision)
       construct)))
 
 
@@ -1501,6 +1513,7 @@
 			      return occ-assoc)))
       (when assoc-to-delete
 	(mark-as-deleted assoc-to-delete :revision revision))
+      (add-to-version-history construct :start-revision revision)
       construct)))
 
 
@@ -1773,55 +1786,55 @@
 	(parent-construct (first valid-associations))))))
 
 
-(defgeneric add-parent (construct parent-construct &key revision)
-  (:documentation "Adds the parent-construct (TopicC or NameC) in form of
-                   a corresponding association to the given object.")
-  (:method ((construct CharacteristicC) (parent-construct ReifiableConstructC)
-	    &key (revision *TM-REVISION*))
-    (let ((already-set-parent (parent construct :revision revision))
-	  (same-parent-assoc ;should contain a object that was marked as deleted
-	   (loop for parent-assoc in (slot-p construct 'parent)
-	      when (eql parent-construct (parent-construct parent-assoc))
-	      return parent-assoc)))
-      (when (and already-set-parent
-		 (not (eql already-set-parent parent-construct)))
-	(error "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a"
-	       construct parent-construct already-set-parent))
-      (cond (already-set-parent
-	     (let ((parent-assoc
-		    (loop for parent-assoc in (slot-p construct 'parent)
-		       when (eql parent-construct
-				 (parent-construct parent-assoc))
-		       return parent-assoc)))
-	       (add-to-version-history parent-assoc :start-revision revision)))
-	    (same-parent-assoc
-	     (add-to-version-history same-parent-assoc :start-revision revision))
-	    (t
-	     (let ((association-type (cond ((typep construct 'OccurrenceC)
-					    'OccurrenceAssociationC)
-					   ((typep construct 'NameC)
-					    'NameAssociationC)
-					   (t
-					    'VariantAssociationC))))
-	       (make-construct association-type
-			       :characteristic construct
-			       :parent-construct parent-construct
-			       :start-revision revision)))))
-    construct))
+(defmethod add-parent ((construct CharacteristicC)
+		       (parent-construct ReifiableConstructC)
+		       &key (revision *TM-REVISION*))
+  (let ((already-set-parent (parent construct :revision revision))
+	(same-parent-assoc ;should contain a object that was marked as deleted
+	 (loop for parent-assoc in (slot-p construct 'parent)
+	    when (eql parent-construct (parent-construct parent-assoc))
+	    return parent-assoc)))
+    (when (and already-set-parent
+	       (not (eql already-set-parent parent-construct)))
+      (error "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a"
+	     construct parent-construct already-set-parent))
+    (cond (already-set-parent
+	   (let ((parent-assoc
+		  (loop for parent-assoc in (slot-p construct 'parent)
+		     when (eql parent-construct
+			       (parent-construct parent-assoc))
+		     return parent-assoc)))
+	     (add-to-version-history parent-assoc :start-revision revision)))
+	  (same-parent-assoc
+	   (add-to-version-history same-parent-assoc :start-revision revision))
+	  (t
+	   (let ((association-type (cond ((typep construct 'OccurrenceC)
+					  'OccurrenceAssociationC)
+					 ((typep construct 'NameC)
+					  'NameAssociationC)
+					 (t
+					  'VariantAssociationC))))
+	     (make-construct association-type
+			     :characteristic construct
+			     :parent-construct parent-construct
+			     :start-revision revision)))))
+  (when (typep parent-construct 'VersionedConstructC)
+    (add-to-version-history parent-construct :start-revision revision))
+  construct)
 
 
-(defgeneric delete-parent (construct parent-construct &key revision)
-  (:documentation "Sets the assoication-object between the passed
-                   constructs as marded-as-deleted.")
-  (:method ((construct CharacteristicC) (parent-construct ReifiableConstructC)
-	    &key (revision (error "From delete-parent(): revision must be set")))
-    (let ((assoc-to-delete
-	   (loop for parent-assoc in (slot-p construct 'parent)
-	      when (eql (parent-construct parent-assoc) parent-construct)
-	      return parent-assoc)))
-      (when assoc-to-delete
-	(mark-as-deleted assoc-to-delete :revision revision))
-      construct)))
+(defmethod delete-parent ((construct CharacteristicC)
+			  (parent-construct ReifiableConstructC)
+			  &key (revision (error "From delete-parent(): revision must be set")))
+  (let ((assoc-to-delete
+	 (loop for parent-assoc in (slot-p construct 'parent)
+	    when (eql (parent-construct parent-assoc) parent-construct)
+	    return parent-assoc)))
+    (when assoc-to-delete
+      (mark-as-deleted assoc-to-delete :revision revision))
+    (when (typep parent-construct 'VersionedConstructC)
+      (add-to-version-history parent-construct :start-revision revision))
+    construct))
 
 
 ;;; OccurrenceC
@@ -2037,6 +2050,7 @@
 			      return role-assoc)))
       (when assoc-to-delete
 	(mark-as-deleted assoc-to-delete :revision revision))
+      (add-to-version-history construct :start-revision revision)
       construct)))
 
 
@@ -2155,6 +2169,7 @@
 	    return parent-assoc)))
     (when assoc-to-delete
       (mark-as-deleted assoc-to-delete :revision revision))
+    (add-to-version-history parent-construct :start-revision revision)
     construct))
 
 
@@ -2337,9 +2352,7 @@
 			       :parent-construct construct
 			       :identifier item-identifier
 			       :start-revision revision)))
-	(when (or (typep merged-construct 'TopicC)
-		  (typep merged-construct 'AssociationC)
-		  (typep merged-construct 'TopicMapC))
+	(when (typep construct 'VersionedConstructC)
 	  (add-to-version-history merged-construct :start-revision revision))
 	merged-construct))))
 
@@ -2354,6 +2367,8 @@
 			      return ii-assoc)))
       (when assoc-to-delete
 	(mark-as-deleted assoc-to-delete :revision revision))
+      (when (typep construct 'VersionedConstructC)
+	(add-to-version-history construct :start-revision revision))
       construct)))
 
 
@@ -2391,9 +2406,7 @@
 				 :reifiable-construct construct
 				 :reifier-topic merged-reifier-topic
 				 :start-revision revision)))
-	  (when (or (typep merged-construct 'TopicC)
-		    (typep merged-construct 'AssociationC)
-		    (typep merged-construct 'TopicMapC))
+	  (when (typep construct 'VersionedConstructC)
 	    (add-to-version-history merged-construct :start-revision revision))
 	  merged-construct)))))
 
@@ -2408,6 +2421,8 @@
 			      return reifier-assoc)))
       (when assoc-to-delete
 	(mark-as-deleted assoc-to-delete :revision revision))
+      (when (typep construct 'VersionedConstructC)
+	(add-to-version-history construct :start-revision revision))
       construct)))
 
 
@@ -2509,7 +2524,7 @@
 			  :theme-topic theme-topic
 			  :scopable-construct construct
 			  :start-revision revision)))
-    (when (typep construct 'AssociationC)
+    (when (typep construct 'VersionedConstructC)
       (add-to-version-history construct :start-revision revision))
     construct))
 
@@ -2524,6 +2539,8 @@
 			      return theme-assoc)))
       (when assoc-to-delete
 	(mark-as-deleted assoc-to-delete :revision revision))
+      (when (typep construct 'VersionedConstructC)
+	(add-to-version-history construct :start-revision revision))
       construct)))
 
 
@@ -2580,7 +2597,7 @@
 			     :type-topic type-topic
 			     :typable-construct construct
 			     :start-revision revision))))
-    (when (typep construct 'AssociationC)
+    (when (typep construct 'VersionedConstructC)
       (add-to-version-history construct :start-revision revision))
     construct))
 
@@ -2596,6 +2613,8 @@
 	      return type-assoc)))
       (when assoc-to-delete
 	(mark-as-deleted assoc-to-delete :revision revision))
+      (when (typep construct 'VersionedConstructC)
+	(add-to-version-history construct :start-revision revision))
       construct)))
 
 

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	Mon Mar 22 12:24:54 2010
@@ -62,8 +62,6 @@
 	   :test-find-item-by-revision))
 
 
-;;TODO: complete all test of the form test-add-<whatever>
-;;      --> indirect call of add-to-version-history
 ;;TODO: test make-construct
 ;;TODO: test merge-constructs
 
@@ -157,10 +155,20 @@
 	(signals error (make-instance 'ItemIdentifierC))
 	(is-false (item-identifiers topic-1))
 	(add-item-identifier topic-1 ii-1)
+	(is (= (length (d::versions topic-1)) 1))
+	(is-true (find-if #'(lambda(vi)
+			      (and (= (d::start-revision vi) revision-1)
+				   (= (d::end-revision vi) 0)))
+			  (d::versions topic-1)))
 	(is (= (length (item-identifiers topic-1)) 1))
 	(is (eql (first (item-identifiers topic-1)) ii-1))
 	(is (eql (identified-construct ii-1) topic-1))
 	(add-item-identifier topic-1 ii-2 :revision revision-2)
+	(is (= (length (d::versions topic-1)) 2))
+	(is-true (find-if #'(lambda(vi)
+			      (and (= (d::start-revision vi) revision-2)
+				   (= (d::end-revision vi) 0)))
+			  (d::versions topic-1)))
 	(is (= (length (item-identifiers topic-1 :revision revision-0)) 2))
 	(is (= (length (item-identifiers topic-1 :revision revision-1)) 1))
 	(is (eql (first (item-identifiers topic-1 :revision revision-1)) ii-1))
@@ -180,6 +188,11 @@
 						  :revision revision-2)))
 	       2))
 	(delete-item-identifier topic-1 ii-2 :revision revision-3)
+	(is (= (length (d::versions topic-1)) 3))
+	(is-true (find-if #'(lambda(vi)
+			      (and (= (d::start-revision vi) revision-3)
+				   (= (d::end-revision vi) 0)))
+			  (d::versions topic-1)))
 	(is-false (item-identifiers topic-1 :revision revision-3))
 	(add-item-identifier topic-1 ii-1 :revision revision-4)
 	(is (= (length (union (list ii-1)
@@ -208,10 +221,20 @@
 	(signals error (make-instance 'PersistentIdC))
 	(is-false (psis topic-1))
 	(add-psi topic-1 psi-1)
+	(is (= (length (d::versions topic-1)) 1))
+	(is-true (find-if #'(lambda(vi)
+			      (and (= (d::start-revision vi) revision-1)
+				   (= (d::end-revision vi) 0)))
+			  (d::versions topic-1)))
 	(is (= (length (psis topic-1)) 1))
 	(is (eql (first (psis topic-1)) psi-1))
 	(is (eql (identified-construct psi-1) topic-1))
 	(add-psi topic-1 psi-2 :revision revision-2)
+	(is (= (length (d::versions topic-1)) 2))
+	(is-true (find-if #'(lambda(vi)
+			      (and (= (d::start-revision vi) revision-2)
+				   (= (d::end-revision vi) 0)))
+			  (d::versions topic-1)))
 	(is (= (length (psis topic-1 :revision revision-0)) 2))
 	(is (= (length (psis topic-1 :revision revision-1)) 1))
 	(is (eql (first (psis topic-1 :revision revision-1)) psi-1))
@@ -229,6 +252,11 @@
 			      (psis topic-1 :revision revision-2)))
 	       2))
 	(delete-psi topic-1 psi-2 :revision revision-3)
+	(is (= (length (d::versions topic-1)) 3))
+	(is-true (find-if #'(lambda(vi)
+			      (and (= (d::start-revision vi) revision-3)
+				   (= (d::end-revision vi) 0)))
+			  (d::versions topic-1)))
 	(is-false (psis topic-1 :revision revision-3))
 	(add-psi topic-1 psi-1 :revision revision-4)
 	(is (= (length (union (list psi-1)
@@ -257,10 +285,20 @@
 	(signals error (make-instance 'SubjectLocatorC))
 	(is-false (locators topic-1))
 	(add-locator topic-1 sl-1)
+	(is (= (length (d::versions topic-1)) 1))
+	(is-true (find-if #'(lambda(vi)
+			      (and (= (d::start-revision vi) revision-1)
+				   (= (d::end-revision vi) 0)))
+			  (d::versions topic-1)))
 	(is (= (length (locators topic-1)) 1))
 	(is (eql (first (locators topic-1)) sl-1))
 	(is (eql (identified-construct sl-1) topic-1))
 	(add-locator topic-1 sl-2 :revision revision-2)
+	(is (= (length (d::versions topic-1)) 2))
+	(is-true (find-if #'(lambda(vi)
+			      (and (= (d::start-revision vi) revision-2)
+				   (= (d::end-revision vi) 0)))
+			  (d::versions topic-1)))
 	(is (= (length (locators topic-1 :revision revision-0)) 2))
 	(is (= (length (locators topic-1 :revision revision-1)) 1))
 	(is (eql (first (locators topic-1 :revision revision-1)) sl-1))
@@ -271,6 +309,11 @@
 			      (locators topic-1 :revision revision-0)))
 	       2))
 	(delete-locator topic-1 sl-1 :revision revision-3)
+	(is (= (length (d::versions topic-1)) 3))
+	(is-true (find-if #'(lambda(vi)
+			      (and (= (d::start-revision vi) revision-3)
+				   (= (d::end-revision vi) 0)))
+			  (d::versions topic-1)))
 	(is (= (length (union (list sl-2)
 			      (locators topic-1 :revision revision-0)))
 	       1))
@@ -311,10 +354,20 @@
 				      :xtm-id "xtm-id-1"))
 	(is-false (topic-identifiers topic-1))
 	(add-topic-identifier topic-1 ti-1)
+	(is (= (length (d::versions topic-1)) 1))
+	(is-true (find-if #'(lambda(vi)
+			      (and (= (d::start-revision vi) revision-1)
+				   (= (d::end-revision vi) 0)))
+			  (d::versions topic-1)))
 	(is (= (length (topic-identifiers topic-1)) 1))
 	(is (eql (first (topic-identifiers topic-1)) ti-1))
 	(is (eql (identified-construct ti-1) topic-1))
 	(add-topic-identifier topic-1 ti-2 :revision revision-2)
+	(is (= (length (d::versions topic-1)) 2))
+	(is-true (find-if #'(lambda(vi)
+			      (and (= (d::start-revision vi) revision-2)
+				   (= (d::end-revision vi) 0)))
+			  (d::versions topic-1)))
 	(is (= (length (topic-identifiers topic-1 :revision revision-0)) 2))
 	(is (= (length (topic-identifiers topic-1 :revision revision-1)) 1))
 	(is (eql (first (topic-identifiers topic-1 :revision revision-1)) ti-1))
@@ -325,6 +378,11 @@
 			      (topic-identifiers topic-1 :revision revision-0)))
 	       2))
 	(delete-topic-identifier topic-1 ti-1 :revision revision-3)
+	(is (= (length (d::versions topic-1)) 3))
+	(is-true (find-if #'(lambda(vi)
+			      (and (= (d::start-revision vi) revision-3)
+				   (= (d::end-revision vi) 0)))
+			  (d::versions topic-1)))
 	(is (= (length (union (list ti-2)
 			      (topic-identifiers topic-1 :revision revision-0)))
 	       1))
@@ -529,16 +587,31 @@
     "Tests variuas functions of the ReifialeConstructC."
     (with-fixture with-empty-db (*db-dir*)
       (let ((reifier-top (make-instance 'TopicC))
-	    (reified-rc (make-instance 'd::ReifiableConstructC)))
+	    (reified-rc (make-instance 'd::AssociationC))
+	    (version-0-5 50)
+	    (version-1 100)
+	    (version-2 200)
+	    (version-3 300))
 	(is-false (reifier reified-rc))
 	(is-false (reified-construct reifier-top))
-	(add-reifier reified-rc reifier-top :revision 100)
+	(add-reifier reified-rc reifier-top :revision version-1)
+	(is (= (length (d::versions reified-rc)) 1))
+	(is-true (find-if #'(lambda(vi)
+			      (and (= (d::start-revision vi) version-1)
+				   (= (d::end-revision vi) 0)))
+			  (d::versions reified-rc)))
 	(is (eql reifier-top (reifier reified-rc)))
 	(is (eql reified-rc (reified-construct reifier-top)))
-	(is (eql reifier-top (reifier reified-rc :revision 200)))
-	(is (eql reified-rc (reified-construct reifier-top :revision 200)))
-	(is-false (reifier reified-rc :revision 50))
-	(is-false (reified-construct reifier-top :revision 50)))))
+	(is (eql reifier-top (reifier reified-rc :revision version-2)))
+	(is (eql reified-rc (reified-construct reifier-top :revision version-2)))
+	(is-false (reifier reified-rc :revision version-0-5))
+	(is-false (reified-construct reifier-top :revision version-0-5))
+	(delete-reifier reified-rc reifier-top :revision version-3)
+	(is (= (length (d::versions reified-rc)) 2))
+	(is-true (find-if #'(lambda(vi)
+			      (and (= (d::start-revision vi) version-3)
+				   (= (d::end-revision vi) 0)))
+			  (d::versions reified-rc))))))
 
 
 (test test-OccurrenceC ()
@@ -560,9 +633,19 @@
       (is-false (parent occ-1))
       (is-false (occurrences top-1))
       (add-occurrence top-1 occ-1 :revision revision-1)
+      (is (= (length (d::versions top-1)) 1))
+      (is-true (find-if #'(lambda(vi)
+			    (and (= (d::start-revision vi) revision-1)
+				 (= (d::end-revision vi) 0)))
+			(d::versions top-1)))
       (is (= (length (union (list occ-1)
 			    (occurrences top-1))) 1))
       (add-occurrence top-1 occ-2 :revision revision-2)
+      (is (= (length (d::versions top-1)) 2))
+      (is-true (find-if #'(lambda(vi)
+			    (and (= (d::start-revision vi) revision-2)
+				 (= (d::end-revision vi) 0)))
+			(d::versions top-1)))
       (is (= (length (union (list occ-1 occ-2)
 			    (occurrences top-1))) 2))
       (is (= (length (union (list occ-1)
@@ -570,6 +653,11 @@
       (add-occurrence top-1 occ-2 :revision revision-3)
       (is (= (length (d::slot-p top-1 'd::occurrences)) 2))
       (delete-occurrence top-1 occ-1 :revision revision-4)
+      (is (= (length (d::versions top-1)) 4))
+      (is-true (find-if #'(lambda(vi)
+			    (and (= (d::start-revision vi) revision-4)
+				 (= (d::end-revision vi) 0)))
+			(d::versions top-1)))
       (is (= (length (union (list occ-2)
 			    (occurrences top-1 :revision revision-4))) 1))
       (is (= (length (union (list occ-2)
@@ -594,7 +682,17 @@
       (is (eql top-1 (parent occ-2)))
       (delete-parent occ-2 top-1 :revision revision-6)
       (add-parent occ-2 top-2 :revision revision-7)
+      (is (= (length (d::versions top-2)) 2))
+      (is-true (find-if #'(lambda(vi)
+			    (and (= (d::start-revision vi) revision-7)
+				 (= (d::end-revision vi) 0)))
+			(d::versions top-2)))
       (delete-parent occ-2 top-2 :revision revision-8)
+      (is (= (length (d::versions top-2)) 3))
+      (is-true (find-if #'(lambda(vi)
+			    (and (= (d::start-revision vi) revision-8)
+				 (= (d::end-revision vi) 0)))
+			(d::versions top-2)))
       (is-false (parent occ-2))
       (add-parent occ-2 top-1 :revision revision-8)
       (is (eql top-1 (parent occ-2))))))
@@ -678,9 +776,19 @@
       (is-false (parent name-1))
       (is-false (names top-1))
       (add-name top-1 name-1 :revision revision-1)
+      (is (= (length (d::versions top-1)) 1))
+      (is-true (find-if #'(lambda(vi)
+			    (and (= (d::start-revision vi) revision-1)
+				 (= (d::end-revision vi) 0)))
+			(d::versions top-1)))
       (is (= (length (union (list name-1)
 			    (names top-1))) 1))
       (add-name top-1 name-2 :revision revision-2)
+      (is (= (length (d::versions top-1)) 2))
+      (is-true (find-if #'(lambda(vi)
+			    (and (= (d::start-revision vi) revision-2)
+				 (= (d::end-revision vi) 0)))
+			(d::versions top-1)))
       (is (= (length (union (list name-1 name-2)
 			    (names top-1))) 2))
       (is (= (length (union (list name-1)
@@ -688,6 +796,11 @@
       (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 (d::versions top-1)) 4))
+      (is-true (find-if #'(lambda(vi)
+			    (and (= (d::start-revision vi) revision-4)
+				 (= (d::end-revision vi) 0)))
+			(d::versions top-1)))
       (is (= (length (union (list name-2)
 			    (names top-1 :revision revision-4))) 1))
       (is (= (length (union (list name-2)
@@ -712,7 +825,17 @@
       (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)
+      (is (= (length (d::versions top-2)) 2))
+      (is-true (find-if #'(lambda(vi)
+			    (and (= (d::start-revision vi) revision-7)
+				 (= (d::end-revision vi) 0)))
+			(d::versions top-2)))
       (delete-parent name-2 top-2 :revision revision-8)
+      (is (= (length (d::versions top-2)) 3))
+      (is-true (find-if #'(lambda(vi)
+			    (and (= (d::start-revision vi) revision-8)
+				 (= (d::end-revision vi) 0)))
+			(d::versions top-2)))
       (is-false (parent name-2))
       (add-parent name-2 top-1 :revision revision-8)
       (is (eql top-1 (parent name-2))))))
@@ -812,15 +935,26 @@
 	  (assoc-2 (make-instance 'AssociationC))
 	  (revision-1 100)
 	  (revision-2 200)
-	  (revision-3 300))
+	  (revision-3 300)
+	  (revision-4 400))
       (setf *TM-REVISION* revision-1)
       (is-false (roles assoc-1))
       (is-false (parent role-1))
       (add-parent role-1 assoc-1)
+      (is (= (length (d::versions assoc-1)) 1))
+      (is-true (find-if #'(lambda(vi)
+			    (and (= (d::start-revision vi) revision-1)
+				 (= (d::end-revision vi) 0)))
+			(d::versions assoc-1)))
       (is (eql (parent role-1 :revision revision-1) assoc-1))
       (is (= (length (union (list role-1)
 			    (roles assoc-1))) 1))
       (add-role assoc-1 role-2 :revision revision-2)
+      (is (= (length (d::versions assoc-1)) 2))
+      (is-true (find-if #'(lambda(vi)
+			    (and (= (d::start-revision vi) revision-2)
+				 (= (d::end-revision vi) 0)))
+			(d::versions assoc-1)))
       (is (= (length (union (list role-1 role-2)
 			    (roles assoc-1))) 2))
       (is (= (length (union (list role-1)
@@ -830,6 +964,11 @@
       (is-false (parent role-2 :revision revision-1))
       (signals error (add-parent role-2 assoc-2 :revision revision-2))
       (delete-role assoc-1 role-1 :revision revision-3)
+      (is (= (length (d::versions assoc-1)) 3))
+      (is-true (find-if #'(lambda(vi)
+			    (and (= (d::start-revision vi) revision-3)
+				 (= (d::end-revision vi) 0)))
+			(d::versions assoc-1)))
       (is-false (parent role-1))
       (is (= (length (union (list role-2)
 			    (roles assoc-1))) 1))
@@ -850,7 +989,13 @@
       (is (= (length (slot-value assoc-1 'roles)) 2))
       (is (= (length (slot-value assoc-2 'roles)) 2))
       (is (= (length (slot-value role-1 'parent)) 2))
-      (is (= (length (slot-value role-2 'parent)) 2)))))
+      (is (= (length (slot-value role-2 'parent)) 2))
+      (delete-parent role-1 assoc-2 :revision revision-4)
+      (is (= (length (d::versions assoc-2)) 2))
+      (is-true (find-if #'(lambda(vi)
+			    (and (= (d::start-revision vi) revision-4)
+				 (= (d::end-revision vi) 0)))
+			(d::versions assoc-2))))))
 
 
 (test test-player ()




More information about the Isidorus-cvs mailing list