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