Author: lgiessmann Date: Thu Feb 25 14:20:51 2010 New Revision: 207

Log: new-datamodel: added some unit-tests for add-reifier, reifier and delete-reifier; fixed alos msome problems in these functions; changed some key-parameters --> (reivision 0) was changed to (revision *TM-REVISION*) in all adder-functions, e.g. add-psi

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 Feb 25 14:20:51 2010 @@ -94,6 +94,7 @@ (in-package :datamodel)

+;;TODO: finalize add-reifier ;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo ;; initarg in make-construct ;;TODO: implement a macro "with-merge-construct" that merges constructs @@ -253,7 +254,7 @@ :inherit t :documentation "A relation to all item-identifiers of this construct.") - (reifier :associate (ReifierAssociationC reified-construct) + (reifier :associate (ReifierAssociationC reifiable-construct) :inherit t :documentation "A relation to a reifier-topic.")) (:documentation "Reifiable constructs as per TMDM.")) @@ -316,7 +317,7 @@ :documentation "Contains all association objects that relate a topic that is a theme with its scoppable object.") - (reified-construct :associate (ReifiedAssociationC reifier-topic) + (reified-construct :associate (ReifierAssociationC reifier-topic) :documentation "Contains all association objects that relate a topic that is a reifier with its reified object.") @@ -411,7 +412,7 @@ :initform (error "From ReifierAssociation(): reifiable-construct must be set") :associate ReifiableConstructC :documentation "The actual construct which is reified - by a topic.") + by a topic.") (reifier-topic :initarg :reifier-topic :accessor reifier-topic :initform (error "From ReifierAssociationC(): reifier-topic must be set") @@ -786,7 +787,7 @@ If the passed identifer already identifies another object the identified-constructs are merged.") (:method ((construct TopicC) (topic-identifier TopicIdentificationC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (let ((all-ids (map 'list #'identifier (slot-p construct 'topic-identifiers))) (construct-to-be-merged @@ -840,7 +841,7 @@ If the passed identifer already identifies another object the identified-constructs are merged.") (:method ((construct TopicC) (psi PersistentIdC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (let ((all-ids (map 'list #'identifier (slot-p construct 'psis))) (construct-to-be-merged @@ -893,7 +894,7 @@ If the passed identifer already identifies another object the identified-constructs are merged.") (:method ((construct TopicC) (locator SubjectLocatorC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (let ((all-ids (map 'list #'identifier (slot-p construct 'locators))) (construct-to-be-merged @@ -946,7 +947,7 @@ If the passed name already owns another object an error is thrown.") (:method ((construct TopicC) (name NameC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (when (not (eql (parent name) construct)) (error "From add-name(): ~a can't be owned by ~a since it is already owned by the topic ~a" name construct (parent name))) @@ -959,11 +960,12 @@ when (eql (parent-construct name-assoc) name) return name-assoc))) (add-to-version-history name-assoc :start-revision revision)) - (make-instance 'NameAssociationC - :start-revision revision - :parent-construct construct - :characteristic name)) - construct))) + (let ((assoc + (make-instance 'NameAssociationC + :parent-construct construct + :characteristic name))) + (add-to-version-history assoc :start-revision revision)))) + construct))

(defgeneric delete-name (construct name &key revision) @@ -995,7 +997,7 @@ If the passed occurrence already owns another object an error is thrown.") (:method ((construct TopicC) (occurrence OccurrenceC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (when (not (eql (parent occurrence) construct)) (error "From add-occurrence(): ~a can't be owned by ~a since it is already owned by the topic ~a" occurrence construct (parent occurrence))) @@ -1008,11 +1010,12 @@ when (eql (parent-construct occ-assoc) occurrence) return occ-assoc))) (add-to-version-history occ-assoc :start-revision revision)) - (make-instance 'OccurrenceAssociationC - :start-revision revision - :parent-construct construct - :characteristic occurrence)) - construct))) + (let ((assoc + (make-instance 'OccurrenceAssociationC + :parent-construct construct + :characteristic occurrence))) + (add-to-version-history assoc :start-revision revision)))) + construct))

(defgeneric delete-occurrence (construct occurrence &key revision) @@ -1061,7 +1064,8 @@ (:method ((construct TopicC) &key (revision 0)) (let ((assocs (filter-slot-value-by-revision construct 'reified-construct :start-revision revision))) - (map 'list #'reifiable-construct assocs)))) + (when assocs + (reifiable-construct (first assocs))))))

(defgeneric in-topicmaps (construct &key revision) @@ -1184,7 +1188,7 @@ (:documentation "Adds the given theme-topic to the passed scopable-construct.") (:method ((construct NameC) (variant VariantC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (when (not (eql (parent variant) construct)) (error "From add-variant(): ~a can't be owned by ~a since it is already owned by the name ~a" variant construct (parent variant))) @@ -1198,10 +1202,11 @@ when (eql (characteristic variant-assoc) variant) return variant-assoc))) (add-to-version-history variant-assoc :start-revision revision)) - (make-instance 'VariantAssociationC - :start-revision revision - :characteristic variant - :parent-construct construct))) + (let ((assoc + (make-instance 'VariantAssociationC + :characteristic variant + :parent-construct construct))) + (add-to-version-history assoc :start-revision revision)))) construct))

@@ -1250,7 +1255,7 @@

(defmethod add-parent ((construct CharacteristicC) (parent-construct TopicC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (let ((already-set-topic (map 'list #'parent-construct (filter-slot-value-by-revision construct 'parent @@ -1264,12 +1269,13 @@ return parent-assoc))) (add-to-version-history parent-assoc :start-revision revision))) ((not already-set-topic) - (make-instance (if (typep construct 'OccurrenceC) - 'OccurrenceAssociationC - 'NameAssociationC) - :start-revision revision - :parent-construct parent-construct - :characteristic construct)) + (let ((assoc + (make-instance (if (typep construct 'OccurrenceC) + 'OccurrenceAssociationC + 'NameAssociationC) + :parent-construct parent-construct + :characteristic construct))) + (add-to-version-history assoc :start-revision revision))) (t (error "From add-parent(): ~a can't be owned by ~a since it is already owned by the topic ~a" construct parent-construct already-set-topic))) @@ -1277,7 +1283,7 @@

(defmethod add-parent ((construct CharacteristicC) (parent-construct NameC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (let ((already-set-name (map 'list #'characteristic (filter-slot-value-by-revision construct 'parent @@ -1290,10 +1296,11 @@ return parent-assoc))) (add-to-version-history parent-assoc :start-revision revision))) ((not already-set-name) - (make-instance 'VariantAssociationC - :start-revision revision - :parent-construct parent-construct - :characteristic construct)) + (let ((assoc + (make-instance 'VariantAssociationC + :parent-construct parent-construct + :characteristic construct))) + (add-to-version-history assoc :start-revision revision))) (t (error "From add-parent(): ~a can't be owned by ~a since it is already owned by the topic ~a" construct parent-construct already-set-name))) @@ -1448,7 +1455,7 @@ (defgeneric add-role (construct role &key revision) (:documentation "Adds the given role to the passed association-construct.") (:method ((construct AssociationC) (role RoleC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (let ((all-roles (map 'list #'role (remove-if #'marked-as-deleted-p (slot-p construct 'roles))))) @@ -1458,10 +1465,11 @@ when (eql (role role-assoc) role) return role-assoc))) (add-to-version-history role-assoc :start-revision revision)) - (make-instance 'RoleAssociationC - :start-revision revision - :role role - :association construct))) + (let ((assoc + (make-instance 'RoleAssociationC + :role role + :association construct))) + (add-to-version-history assoc :start-revision revision)))) construct))

@@ -1501,7 +1509,7 @@

(defmethod add-parent ((construct RoleC) (parent-construct AssociationC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (let ((already-set-parent (map 'list #'parent (filter-slot-value-by-revision construct 'parent @@ -1515,10 +1523,10 @@ return parent-assoc))) (add-to-version-history parent-assoc :start-revision revision))) ((not already-set-parent) - (make-instance 'RoleAssociationC - :start-revision revision - :role construct - :parent-construct parent-construct)) + (let ((assoc (make-instance 'RoleAssociationC + :role construct + :parent-construct parent-construct))) + (add-to-version-history assoc :start-revision revision))) (t (error "From add-parent(): ~a can't be a parent of ~a since it is already owned by the association ~a" parent-construct construct already-set-parent))) @@ -1550,7 +1558,7 @@ (defgeneric add-player (construct player-topic &key revision) (:documentation "Adds a topic as a player to a role in the given revision.") (:method ((construct RoleC) (player-topic TopicC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (let ((already-set-player (map 'list #'player-topic (filter-slot-value-by-revision construct 'player @@ -1563,10 +1571,10 @@ return player-assoc))) (add-to-version-history player-assoc :start-revision revision))) ((not already-set-player) - (make-instance 'PlayerAssociationC - :start-revision revision - :parent-construct construct - :player-topic player-topic)) + (let ((assoc (make-instance 'PlayerAssociationC + :parent-construct construct + :player-topic player-topic))) + (add-to-version-history assoc :start-revision revision))) (t (error "From add-player(): ~a can't be a player of ~a since it has already the player ~a" player-topic construct already-set-player))) @@ -1602,9 +1610,9 @@ with the passed construct and the passed version.") (:method ((construct ReifiableConstructC) &key (revision 0)) (let ((assocs (filter-slot-value-by-revision - construct 'item-identifiers :start-revision revision))) + construct 'reifier :start-revision revision))) (when assocs ;assocs must be nil or a list with exactly one item - (reifier (first assocs)))))) + (reifier-topic (first assocs))))))

(defmethod delete-construct :before ((construct ReifiableConstructC)) @@ -1624,7 +1632,7 @@ If the passed identifer already identifies another object the identified-constructs are merged.") (:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (let ((all-ids (map 'list #'identifier (slot-p construct 'item-identifiers))) (construct-to-be-merged @@ -1669,13 +1677,16 @@ If the reifier-topic reifies already another construct the reified-constructs are merged.") (:method ((construct ReifiableConstructC) (reifier-topic TopicC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (let ((merged-reifier-topic - (when (reifier construct) - (merge-constructs (reifier construct) reifier-topic)))) + (if (reifier construct) + (merge-constructs (reifier construct) reifier-topic) + reifier-topic))) (let ((all-constructs - (remove-if #'marked-as-deleted-p - (slot-p reifier-topic 'reified-construct)))) + (let ((inner-construct (reified-construct merged-reifier-topic + :revision revision))) + (when inner-construct + (list inner-construct))))) (cond ((find construct all-constructs) (let ((reifier-assoc (loop for reifier-assoc in @@ -1688,11 +1699,12 @@ (all-constructs (merge-constructs (first all-constructs) construct)) (t - (make-instance 'ReifierAssociationC - :start-revision revision - :reifiable-construct construct - :reifier-topic merged-reifier-topic) - construct)))))) + (let ((assoc + (make-instance 'ReifierAssociationC + :reifiable-construct construct + :reifier-topic merged-reifier-topic))) + (add-to-version-history assoc :start-revision revision)))) + construct))))

(defgeneric delete-reifier (construct reifier &key revision) @@ -1729,7 +1741,7 @@ (:documentation "Adds the given theme-topic to the passed scopable-construct.") (:method ((construct ScopableC) (theme-topic TopicC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (let ((all-themes (map 'list #'theme-topic (remove-if #'marked-as-deleted-p (slot-p construct 'themes))))) @@ -1739,10 +1751,11 @@ when (eql (theme-topic theme-assoc) theme-topic) return theme-assoc))) (add-to-version-history theme-assoc :start-revision revision)) - (make-instance 'ScopeAssociationC - :start-revision revision - :theme-topic theme-topic - :scopable-construct construct))) + (let ((assoc + (make-instance 'ScopeAssociationCn + :theme-topic theme-topic + :scopable-construct construct))) + (add-to-version-history assoc :start-revision revision)))) construct))

@@ -1782,7 +1795,7 @@ typed construct if there is no other type-topic set at the same revision.") (:method ((construct TypableC) (type-topic TopicC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (let ((already-set-type (map 'list #'type-topic (filter-slot-value-by-revision construct 'instance-of @@ -1795,10 +1808,11 @@ return type-assoc))) (add-to-version-history type-assoc :start-revision revision))) ((not already-set-type) - (make-instance 'TypeAssociationC - :start-revision revision - :type-topic type-topic - :typable-construct construct)) + (let ((assoc + (make-instance 'TypeAssociationC + :type-topic type-topic + :typable-construct construct))) + (add-to-version-history assoc :start-revision revision))) (t (error "From add-type(): ~a can't be typed by ~a since it is already typed by the topic ~a" construct type-topic already-set-type))) @@ -1831,10 +1845,11 @@

;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defgeneric merge-constructs(construc-1 construct-2 &key revision) +(defgeneric merge-constructs(construct-1 construct-2 &key revision) (:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC) - &key (revision 0)) - (or construct-1 construct-2 revision))) + &key (revision *TM-REVISION*)) + (or revision) + (if construct-1 construct-1 construct-2)))

(defgeneric make-construct (class-symbol &key start-revision &allow-other-keys)

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 Feb 25 14:20:51 2010 @@ -26,13 +26,18 @@ :test-get-item-by-id :test-get-item-by-item-identifier :test-get-item-by-locator - :test-get-item-by-psi)) + :test-get-item-by-psi + :test-ReifiableConstructC))

-;;TODO: test merges-constructs when merging was caused by an item-dentifier -;;TODO: test merges-constructs when merging was caused by an psi -;;TODO: test merges-constructs when merging was caused by an subject-locator -;;TODO: test merges-constructs when merging was caused by a topic-id +;;TODO: test delete-construct +;;TODO: test merge-constructs when merging was caused by an item-dentifier +;;TODO: test merge-constructs when merging was caused by an psi +;;TODO: test merge-constructs when merging was caused by an subject-locator +;;TODO: test merge-constructs when merging was caused by a topic-id +;;TODO: test merge-constructs when merging was caused by reifiers +;; (occurrences, names, variants, associations, roles) +;;TODO: test ReifiableConstructC --> reifier has to be merged

@@ -367,7 +372,7 @@

(test test-get-item-by-item-identifier () - "Tests the function test-get-item-by-id." + "Tests the function test-get-item-by-item-identifier." (with-fixture with-empty-db (*db-dir*) (let ((ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) @@ -409,7 +414,7 @@

(test test-get-item-by-locator () - "Tests the function test-get-item-by-id." + "Tests the function test-get-item-by-locator." (with-fixture with-empty-db (*db-dir*) (let ((sl-1 (make-instance 'SubjectLocatorC :uri "sl-1")) @@ -451,7 +456,7 @@

(test test-get-item-by-psi () - "Tests the function test-get-item-by-id." + "Tests the function test-get-item-by-psi." (with-fixture with-empty-db (*db-dir*) (let ((psi-1 (make-instance 'PersistentIdC :uri "psi-1")) @@ -492,6 +497,22 @@ (is (eql top-3 (get-item-by-locator "psi-1"))))))

+(test test-ReifiableConstructC () + "Tests variuas functions of the ReifialeConstructC." + (with-fixture with-empty-db (*db-dir*) + (let ((reifier-top (make-instance 'TopicC)) + (reified-rc (make-instance 'd::ReifiableConstructC))) + (is-false (reifier reified-rc)) + (is-false (reified-construct reifier-top)) + (add-reifier reified-rc reifier-top :revision 100) + (is (eql reifier-top (reifier reified-rc))) + (is (eql reified-rc (reified-construct reifier-top))) + (is (eql reifier-top (reifier reified-rc :revision 200))) + (is (eql reified-rc (reified-construct reifier-top :revision 200))) + (is-false (reifier reified-rc :revision 50)) + (is-false (reified-construct reifier-top :revision 50))))) + + (defun run-datamodel-tests() (it.bese.fiveam:run! 'test-VersionInfoC) (it.bese.fiveam:run! 'test-VersionedConstructC) @@ -503,4 +524,5 @@ (it.bese.fiveam:run! 'test-get-item-by-item-identifier) (it.bese.fiveam:run! 'test-get-item-by-locator) (it.bese.fiveam:run! 'test-get-item-by-psi) + (it.bese.fiveam:run! 'test-ReifiableConstructC) ) \ No newline at end of file