[isidorus-cvs] r209 - in branches/new-datamodel/src: model unit_tests - isidorus-cvs@common-lisp.net - mailman3.common-lisp.net

25 Feb 2010

Author: lgiessmann
Date: Thu Feb 25 16:36:10 2010
New Revision: 209
Log:
new-datamodel: added some unit-tests for add-occurrence, delete-occurrence, occurrences; fixed some bugs in these funtions
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 Feb 25 16:36:10 2010
@@ -486,7 +486,7 @@
    	   :accessor characteristic
    	   :inherit t
    	   :initform (error "From CharacteristicCAssociation(): characteristic must be set")
-		   :associate CharactersiticC
+		   :associate CharacteristicC
    	   :documentation "Associates this object with the actual
                                    characteristic object."))
   (:documentation "An abstract base class for all association-objects that
@@ -986,7 +986,7 @@
                    with the passed construct and the passed version.")
   (:method ((construct TopicC) &key (revision 0))
     (let ((assocs (filter-slot-value-by-revision
-		   construct 'occurences :start-revision revision)))
+		   construct 'occurrences :start-revision revision)))
       (map 'list #'characteristic assocs))))
@@ -998,7 +998,8 @@
                    an error is thrown.")
   (:method ((construct TopicC) (occurrence OccurrenceC)
        &key (revision *TM-REVISION*))
-    (when (not (eql (parent occurrence) construct))
+    (when (and (parent occurrence)
+	       (not (eql (parent occurrence) construct)))
       (error "From add-occurrence(): ~a can't be owned by ~a since it is already owned by the topic ~a"
         occurrence construct (parent occurrence)))
     (let ((all-occurrences
@@ -1007,7 +1008,7 @@
    		   (slot-p construct 'occurrences)))))
       (if (find occurrence all-occurrences)
      (let ((occ-assoc (loop for occ-assoc in (slot-p construct 'occurrences)
-			      when (eql (parent-construct occ-assoc) occurrence)
+			      when (eql (parent-construct occ-assoc) construct)
    		      return occ-assoc)))
        (add-to-version-history occ-assoc :start-revision revision))
      (let ((assoc
@@ -1024,7 +1025,7 @@
   (:method ((construct TopicC) (occurrence OccurrenceC)
        &key (revision (error "From delete-occurrence(): revision must be set")))
     (let ((assoc-to-delete (loop for occ-assoc in (slot-p construct 'occurrences)
-			      when (eql (parent-construct occ-assoc) occurrence)
+			      when (eql (parent-construct occ-assoc) construct)
    		      return occ-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	Thu Feb 25 16:36:10 2010
@@ -27,14 +27,13 @@
       :test-get-item-by-item-identifier
       :test-get-item-by-locator
       :test-get-item-by-psi
-	   :test-ReifiableConstructC))
+	   :test-ReifiableConstructC
+	   :test-OccurrenceC))
;;TODO: test delete-construct
-;;TODO: test merge-constructs when merging was caused by an item-dentifier
-;;TODO: test merge-constructs when merging was caused by an psi
-;;TODO: test merge-constructs when merging was caused by an subject-locator
-;;TODO: test merge-constructs when merging was caused by a topic-id
+;;TODO: test merge-constructs when merging was caused by an item-dentifier,
+;;      a psi, a subject-locator, a topic-id
 ;;TODO: test merge-constructs when merging was caused by reifiers
 ;;      (occurrences, names, variants, associations, roles)
 ;;TODO: test ReifiableConstructC --> reifier has to be merged
@@ -513,6 +512,41 @@
    (is-false (reified-construct reifier-top :revision 50)))))
+(test test-OccurrenceC ()
+  "Tests various functions of OccurrenceC."
+  (with-fixture with-empty-db (*db-dir*)
+    (let ((occ-1 (make-instance 'OccurrenceC))
+	  (occ-2 (make-instance 'OccurrenceC))
+	  (top (make-instance 'TopicC))
+	  (revision-1 100)
+	  (revision-2 200)
+	  (revision-3 300)
+	  (revision-4 400))
+      (setf *TM-REVISION* revision-1)
+      (is-false (parent occ-1))
+      (is-false (occurrences top))
+      (add-occurrence top occ-1 :revision revision-1)
+      (is (= (length (union (list occ-1)
+			    (occurrences top))) 1))
+      (add-occurrence top occ-2 :revision revision-2)
+      (is (= (length (union (list occ-1 occ-2)
+			    (occurrences top))) 2))
+      (is (= (length (union (list occ-1)
+			    (occurrences top :revision revision-1))) 1))
+      (add-occurrence top occ-2 :revision revision-3)
+      (is (= (length (d::slot-p top 'd::occurrences)) 2))
+      (delete-occurrence top occ-1 :revision revision-4)
+      (is (= (length (union (list occ-2)
+			    (occurrences top :revision revision-4))) 1))
+      (is (= (length (union (list occ-2)
+			    (occurrences top))) 1))
+      (is (= (length (union (list occ-1 occ-2)
+			    (occurrences top :revision revision-2))) 2))
+      (add-occurrence top occ-1 :revision revision-4)
+      (is (= (length (union (list occ-2 occ-1)
+			    (occurrences top))) 2)))))
+
+
 (defun run-datamodel-tests()
   (it.bese.fiveam:run! 'test-VersionInfoC)
   (it.bese.fiveam:run! 'test-VersionedConstructC)
@@ -525,4 +559,5 @@
   (it.bese.fiveam:run! 'test-get-item-by-locator)
   (it.bese.fiveam:run! 'test-get-item-by-psi)
   (it.bese.fiveam:run! 'test-ReifiableConstructC)
+  (it.bese.fiveam:run! 'test-OccurrenceC)
 )
\ No newline at end of file

    