Author: lgiessmann Date: Thu Apr 29 06:17:20 2010 New Revision: 290 Log: new-datamodel: fixed a problem when topic-merging was caused by reifying the same "ReifiableConstructC"; fixed a bug when two topics are merged and every of these topics reifies a construct that can't be merged with the other one. 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 Apr 29 06:17:20 2010 @@ -3086,6 +3086,15 @@ the reified-constructs are merged.") (:method ((construct ReifiableConstructC) (reifier-topic TopicC) &key (revision *TM-REVISION*)) + (when (and (reified-construct reifier-topic :revision revision) + (not (equivalent-constructs construct + (reified-construct + reifier-topic :revision revision)))) + (error (make-condition 'not-mergable-error + :message (format nil "From add-reifier(): ~a and ~a can't be merged since the reified-constructs (~a ~a) are not mergable" + reifier-topic (reifier construct :revision revision) (reified-construct reifier-topic :revision revision) construct) + :construct-1 construct + :construct-2 (reified-construct reifier-topic :revision revision)))) (let ((merged-reifier-topic (if (reifier construct :revision revision) (merge-constructs (reifier construct :revision revision) @@ -3852,7 +3861,9 @@ (let ((source-reified (reified-construct source :revision revision)) (destination-reified (reified-construct destination :revision revision))) - (unless (eql (type-of source-reified) (type-of destination-reified)) + (when (and source-reified destination-reified + (not (eql (type-of source-reified) + (type-of destination-reified)))) (error (make-condition 'not-mergable-error :message (format nil "From move-reified-construct(): ~a and ~a can't be merged since the reified-constructs are not of the same type ~a ~a" source destination source-reified destination-reified) @@ -3868,10 +3879,10 @@ merged-reified)) (source-reified (delete-reifier source source-reified :revision revision) - (add-reifier destination source-reified :revision revision) + (add-reifier source-reified destination :revision revision) source-reified) (destination-reified - (add-reifier destination destination-reified :revision revision) + (add-reifier destination-reified destination :revision revision) destination-reified))))) 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 Apr 29 06:17:20 2010 @@ -88,7 +88,8 @@ :test-merge-constructs-TopicC-5 :test-merge-constructs-TopicC-6 :test-merge-constructs-TopicC-7 - :test-merge-constructs-TopicC-8)) + :test-merge-constructs-TopicC-8 + :test-merge-constructs-TopicC-9)) ;;TODO: test merge-constructs --> associations when merge was caused by @@ -3554,12 +3555,96 @@ (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-false (set-exclusive-or (list occ-1 occ-3) (occurrences top-1))) (is-true (marked-as-deleted-p top-2)) - (is-true (marked-as-deleted-p occ-2))))))) + (is-true (marked-as-deleted-p occ-2)) + (is (= (length (d::versions top-1)) 2)) + (is (= (length (d::versions top-2)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::end-revision vi) rev-3) + (= (d::start-revision vi) rev-1))) + (d::versions top-1))) + (is-true (find-if #'(lambda(vi) + (and (= (d::end-revision vi) 0) + (= (d::start-revision vi) rev-3))) + (d::versions top-1))) + (is-true (find-if #'(lambda(vi) + (and (= (d::end-revision vi) rev-3) + (= (d::start-revision vi) rev-2))) + (d::versions top-2))) + (is (= (length (slot-value occ-2 'd::parent)) 1)) + (is (= (length (slot-value occ-1 'd::parent)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::end-revision vi) rev-3) + (= (d::start-revision vi) rev-2))) + (first (map 'list #'d::versions + (slot-value occ-2 'd::parent))))) + (is-true (find-if #'(lambda(vi) + (and (= (d::end-revision vi) rev-3) + (= (d::start-revision vi) rev-1))) + (first (map 'list #'d::versions + (slot-value occ-1 'd::parent))))) + (is-true (find-if #'(lambda(vi) + (and (= (d::end-revision vi) 0) + (= (d::start-revision vi) rev-3))) + (first (map 'list #'d::versions + (slot-value occ-1 'd::parent)))))))))) + + +(test test-merge-constructs-TopicC-9 () + "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) + (rev-4 400) + (psi-1 (make-construct 'PersistentIdC :uri "psi-1")) + (psi-2 (make-construct 'PersistentIdC :uri "psi-2"))) + (let ((top-1 (make-construct 'TopicC :start-revision rev-2 + :psis (list psi-2))) + (top-2 (make-construct 'TopicC :start-revision rev-2)) + (top-3 (make-construct 'TopicC :start-revision rev-1)) + (reifier-1 (make-construct 'TopicC :start-revision rev-1)) + (reifier-2 (make-construct 'TopicC :start-revision rev-2 + :psis (list psi-1))) + (reifier-3 (make-construct 'TopicC :start-revision rev-1)) + (reifier-4 (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-2 + :instance-of type-1 + :charvalue "occ" + :reifier reifier-1 + :parent top-1)) + (occ-2 (make-construct 'OccurrenceC + :start-revision rev-2 + :instance-of type-2 + :charvalue "occ" + :reifier reifier-3 + :parent top-2)) + (occ-3 (make-construct 'OccurrenceC + :start-revision rev-1 + :instance-of type-1 + :charvalue "occ" + :reifier reifier-4 + :parent top-3))) + (setf *TM-REVISION* rev-3) + (is (eql (reifier occ-2) reifier-3)) + (signals not-mergable-error (add-reifier occ-1 reifier-3)) + (is (eql occ-1 (add-reifier occ-1 reifier-2))) + (is-true (marked-as-deleted-p reifier-2)) + (is-false (set-exclusive-or (list psi-1) (psis reifier-1))) + (setf *TM-REVISION* rev-4) + (is (eql (add-reifier occ-1 reifier-4) occ-3)) + (is-true (marked-as-deleted-p top-1)) + (is-false (marked-as-deleted-p top-3)) + (is-false (set-exclusive-or (list psi-2) (psis top-3))) + (is-false (marked-as-deleted-p top-2)) + (is-false (set-exclusive-or (list occ-2) (occurrences top-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 @@ -3631,4 +3716,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) + (it.bese.fiveam:run! 'test-merge-constructs-TopicC-9) ) \ No newline at end of file