[isidorus-cvs] r290 - in branches/new-datamodel/src: model unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Thu Apr 29 10:17:21 UTC 2010
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
More information about the Isidorus-cvs
mailing list