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

Lukas Giessmann lgiessmann at common-lisp.net
Tue Apr 27 19:51:48 UTC 2010


Author: lgiessmann
Date: Tue Apr 27 15:51:47 2010
New Revision: 288

Log:
new-datamodel: fixed bugs in the function: "add-item-identifier", "add-variant" and "make-topic"; added new unit-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	Tue Apr 27 15:51:47 2010
@@ -98,7 +98,7 @@
 	   :charvalue
 	   :reified-construct
 	   :mark-as-deleted
-	   :mark-as-deleted-p
+	   :marked-as-deleted-p
 	   :in-topicmaps
 	   :delete-construct
 	   :get-revision
@@ -152,6 +152,7 @@
 	   :get-all-associations
 	   :get-all-tms
 
+
 	   ;;globals
 	   :*TM-REVISION*
 	   :*CURRENT-XTM*))
@@ -159,11 +160,8 @@
 (in-package :datamodel)
 
 
+;;TODO: remove-<xy> --> add to version history???
 ;;TODO: adapt changes-lisp
-;;TODO: check merge-constructs in add-topic-identifier,
-;;      add-item-identifier/add-reifier (can merge the parent constructs
-;;      and the parent's parent construct + the reifier constructs),
-;;      add-psi, add-locator (--> duplicate-identifier-error)
 ;;TODO: implement a macro with-merge-constructs, that merges constructs
 ;;      after all operations in the body were called
 
@@ -2483,6 +2481,9 @@
 			      :characteristic variant
 			      :parent-construct construct
 			      :start-revision revision))
+	  (when (parent construct :revision revision)
+	    (add-name (parent construct :revision revision)  construct
+		      :revision revision))
 	  construct))))
 
 
@@ -3046,8 +3047,16 @@
 			       :parent-construct construct
 			       :identifier item-identifier
 			       :start-revision revision)))
-	(when (typep construct 'VersionedConstructC)
-	  (add-to-version-history merged-construct :start-revision revision))
+	(cond ((typep merged-construct 'VersionedConstructC)
+	       (add-to-version-history merged-construct :start-revision revision))
+	      ((and (typep merged-construct 'CharacteristicC)
+		    (parent merged-construct :revision revision))
+	       (add-characteristic (parent merged-construct :revision revision)
+				   merged-construct :revision revision))
+	      ((and (typep merged-construct 'RoleC)
+		    (parent merged-construct :revision revision))
+	       (add-role (parent merged-construct :revision revision)
+			 merged-construct :revision revision)))
 	merged-construct))))
 
 
@@ -3086,9 +3095,11 @@
 				 (slot-p reifier-topic 'reified-construct))))
 	(let ((merged-construct construct))
 	  (cond ((reified-construct merged-reifier-topic :revision revision)
-		 (merge-constructs
-		  (reified-construct merged-reifier-topic :revision revision)
-		  construct))
+		 (let ((merged-reified
+			(merge-constructs
+			 (reified-construct merged-reifier-topic
+					    :revision revision) construct)))
+		   (setf merged-construct merged-reified)))
 		((find construct all-constructs)
 		 (let ((reifier-assoc
 			(loop for reifier-assoc in
@@ -3578,7 +3589,8 @@
 	(item-identifiers (getf args :item-identifiers))
 	(topic-identifiers (getf args :topic-identifiers))
 	(names (getf args :names))
-	(occurrences (getf args :occurrences)))
+	(occurrences (getf args :occurrences))
+	(reified-construct (getf args :refied-construct)))
     (when (and (or psis locators item-identifiers topic-identifiers
 		   names occurrences)
 	       (not start-revision))
@@ -3620,6 +3632,9 @@
 				       :revision start-revision)))
 	(dolist (occ occurrences)
 	  (add-occurrence merged-topic occ :revision start-revision))
+	(when reified-construct
+	  (add-reified-construct merged-topic reified-construct
+				 :revision start-revision))
 	merged-topic))))
 
 
@@ -3724,26 +3739,6 @@
 	       (add-locator identified-construct identifier
 			    :revision start-revision))))
       identifier)))
-		      
-	   
-		     
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
 
 
 ;;; merge-constructs ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

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	Tue Apr 27 15:51:47 2010
@@ -86,10 +86,13 @@
 	   :test-merge-constructs-TopicC-3
 	   :test-merge-constructs-TopicC-4
 	   :test-merge-constructs-TopicC-5
-	   :test-merge-constructs-TopicC-6))
+	   :test-merge-constructs-TopicC-6
+	   :test-merge-constructs-TopicC-7
+	   :test-merge-constructs-TopicC-8))
 
 
-;;TODO: test merge-constructs
+;;TODO: test merge-constructs --> associations when merge was caused by
+;;      item-identifier of two roles
 ;;TODO: test mark-as-deleted
 
 
@@ -3452,13 +3455,113 @@
 				"ii-1")))))))))
 
 
+(test test-merge-constructs-TopicC-7 ()
+  "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"))
+	  (sl-1 (make-construct 'SubjectLocatorC :uri "sl-1"))
+	  (tid-1 (make-construct 'TopicIdentificationC
+				 :uri "tid-1" :xtm-id "xtm-1"))
+	  (tid-2 (make-construct 'TopicIdentificationC
+				 :uri "tid-2" :xtm-id "xtm-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")))
+      (let ((type-1 (make-construct 'TopicC :start-revision rev-1))
+	    (scope-1 (make-construct 'TopicC :start-revision rev-1))
+	    (scope-2 (make-construct 'TopicC :start-revision rev-1))
+	    (top-1 (make-construct 'TopicC
+				   :start-revision rev-1
+				   :psis (list psi-1)
+				   :topic-identifiers (list tid-1)))
+	    (top-2 (make-construct 'TopicC
+				   :start-revision rev-2
+				   :locators (list sl-1)
+				   :topic-identifiers (list tid-2))))
+	(let ((occ-1 (make-construct 'OccurrenceC
+				     :start-revision rev-1
+				     :item-identifiers (list ii-1)
+				     :instance-of type-1
+				     :themes (list scope-1 scope-2)
+				     :charvalue "occ"
+				     :parent top-1))
+	      (occ-2 (make-construct 'OccurrenceC
+				     :start-revision rev-2
+				     :item-identifiers (list ii-2)
+				     :instance-of type-1
+				     :themes (list scope-1 scope-2)
+				     :charvalue "occ"
+				     :parent top-2))
+	      (occ-3 (make-construct 'OccurrenceC
+				     :start-revision rev-1
+				     :item-identifiers (list ii-3)
+				     :instance-of type-1
+				     :themes (list scope-1)
+				     :charvalue "occ"
+				     :parent top-1)))
+	  (setf *TM-REVISION* rev-3)
+	  (is (= (length (get-all-topics rev-1)) 4))
+	  (is (= (length (get-all-topics rev-3)) 5))
+	  (is (= (length (d::get-db-instances-by-class
+			  'd::OccurrenceC :revision nil)) 3))
+	  (signals not-mergable-error (add-item-identifier occ-3 ii-1))
+	  (is (eql occ-1 (add-item-identifier occ-1 ii-2)))
+	  (is (= (length (get-all-topics rev-3)) 4))
+	  (is-true (d::marked-as-deleted-p occ-2))
+	  (is-true (d::marked-as-deleted-p top-2))
+	  (is-false (set-exclusive-or (list ii-1 ii-2)
+				      (item-identifiers occ-1)))
+	  (is-false (item-identifiers occ-2))
+	  (is-false (set-exclusive-or (list ii-2)
+				      (item-identifiers occ-2 :revision rev-2)))
+	  (is-false (set-exclusive-or (list psi-1) (psis top-1)))
+	  (is-false (set-exclusive-or (list sl-1) (locators top-1)))
+	  (is-false (set-exclusive-or (list tid-1 tid-2)
+				      (topic-identifiers top-1)))
+	  (is-false (locators top-2)))))))
 
 
+(test test-merge-constructs-TopicC-8 ()
+  "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))
+      (let ((top-1 (make-construct 'TopicC :start-revision rev-1))
+	    (top-2 (make-construct 'TopicC :start-revision rev-2))
+	    (reifier-1 (make-construct 'TopicC :start-revision rev-1))
+	    (type-1 (make-construct 'TopicC :start-revision rev-1))
+	    (type-2 (make-construct 'TopicC :start-revision rev-1)))
+	(let ((occ-1 (make-construct 'OccurrenceC
+				     :start-revision rev-1
+				     :instance-of type-1
+				     :charvalue "occ"
+				     :reifier reifier-1
+				     :parent top-1))
+	      (occ-2 (make-construct 'OccurrenceC
+				     :start-revision rev-2
+				     :instance-of type-1
+				     :charvalue "occ"
+				     :parent top-2))
+	      (occ-3 (make-construct 'OccurrenceC
+				     :start-revision rev-1
+				     :instance-of type-2
+				     :charvalue "occ"
+				     :parent top-1)))
+	  (setf *TM-REVISION* rev-3)
+	  (signals not-mergable-error (add-reifier occ-3 reifier-1))
+	  (is (eql (add-reifier occ-2 reifier-1) occ-1))
+	  (is-true (marked-as-deleted-p top-2))
+	  (is-true (marked-as-deleted-p occ-2)))))))
+
 
+;;TODO: merge topics caused by variant-item-identifiers
+;;TODO: mrege topics caused by reifying the same reified-construct
+;;TODO: merge associations caused by a merge of their characteristics
 
-;;TODO: merge topics/associations caused by a merge of their characteristics
-;;TODO: merge-topic when reifies a construct; merge 2 topics when occs are reified
-;;      by the same reifier
 
 
 
@@ -3526,4 +3629,6 @@
   (it.bese.fiveam:run! 'test-merge-constructs-TopicC-4)
   (it.bese.fiveam:run! 'test-merge-constructs-TopicC-5)
   (it.bese.fiveam:run! 'test-merge-constructs-TopicC-6)
+  (it.bese.fiveam:run! 'test-merge-constructs-TopicC-7)
+  (it.bese.fiveam:run! 'test-merge-constructs-TopicC-8)
   )
\ No newline at end of file




More information about the Isidorus-cvs mailing list