[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