Author: lgiessmann Date: Mon Mar 22 12:24:54 2010 New Revision: 245 Log: new-datamodel: added "add-to-version-history" to all "add-<item>" and "delete-<item>" that are defined for "VersionedConstructC" 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 Mon Mar 22 12:24:54 2010 @@ -171,8 +171,6 @@ ;;TODO: implement merge-construct -> ReifiableConstructC -> ... ;; the method should merge two constructs that are inherited from ;; ReifiableConstructC -;;TODO: implement find-item-by-revision for all classes that don't have their -;; one revision-infos --> PointerC, CharacteristicC, RoleC ;;; globals ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -747,6 +745,16 @@ ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgeneric delete-parent (construct parent-construct &key revision) + (:documentation "Sets the assoication-object between the passed + constructs as marded-as-deleted.")) + + +(defgeneric add-parent (construct parent-construct &key revision) + (:documentation "Adds the parent-construct (TopicC or NameC) in form of + a corresponding association to the given object.")) + + (defgeneric find-item-by-revision (construct revision &optional parent-construct) (:documentation "Returns the given object if it exists in the passed @@ -1283,6 +1291,7 @@ return ti-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (add-to-version-history construct :start-revision revision) construct))) @@ -1338,6 +1347,7 @@ return psi-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (add-to-version-history construct :start-revision revision) construct))) @@ -1394,6 +1404,7 @@ return loc-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (add-to-version-history construct :start-revision revision) construct))) @@ -1452,6 +1463,7 @@ return name-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (add-to-version-history construct :start-revision revision) construct))) @@ -1501,6 +1513,7 @@ return occ-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (add-to-version-history construct :start-revision revision) construct))) @@ -1773,55 +1786,55 @@ (parent-construct (first valid-associations)))))) -(defgeneric add-parent (construct parent-construct &key revision) - (:documentation "Adds the parent-construct (TopicC or NameC) in form of - a corresponding association to the given object.") - (:method ((construct CharacteristicC) (parent-construct ReifiableConstructC) - &key (revision *TM-REVISION*)) - (let ((already-set-parent (parent construct :revision revision)) - (same-parent-assoc ;should contain a object that was marked as deleted - (loop for parent-assoc in (slot-p construct 'parent) - when (eql parent-construct (parent-construct parent-assoc)) - return parent-assoc))) - (when (and already-set-parent - (not (eql already-set-parent parent-construct))) - (error "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a" - construct parent-construct already-set-parent)) - (cond (already-set-parent - (let ((parent-assoc - (loop for parent-assoc in (slot-p construct 'parent) - when (eql parent-construct - (parent-construct parent-assoc)) - return parent-assoc))) - (add-to-version-history parent-assoc :start-revision revision))) - (same-parent-assoc - (add-to-version-history same-parent-assoc :start-revision revision)) - (t - (let ((association-type (cond ((typep construct 'OccurrenceC) - 'OccurrenceAssociationC) - ((typep construct 'NameC) - 'NameAssociationC) - (t - 'VariantAssociationC)))) - (make-construct association-type - :characteristic construct - :parent-construct parent-construct - :start-revision revision))))) - construct)) +(defmethod add-parent ((construct CharacteristicC) + (parent-construct ReifiableConstructC) + &key (revision *TM-REVISION*)) + (let ((already-set-parent (parent construct :revision revision)) + (same-parent-assoc ;should contain a object that was marked as deleted + (loop for parent-assoc in (slot-p construct 'parent) + when (eql parent-construct (parent-construct parent-assoc)) + return parent-assoc))) + (when (and already-set-parent + (not (eql already-set-parent parent-construct))) + (error "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a" + construct parent-construct already-set-parent)) + (cond (already-set-parent + (let ((parent-assoc + (loop for parent-assoc in (slot-p construct 'parent) + when (eql parent-construct + (parent-construct parent-assoc)) + return parent-assoc))) + (add-to-version-history parent-assoc :start-revision revision))) + (same-parent-assoc + (add-to-version-history same-parent-assoc :start-revision revision)) + (t + (let ((association-type (cond ((typep construct 'OccurrenceC) + 'OccurrenceAssociationC) + ((typep construct 'NameC) + 'NameAssociationC) + (t + 'VariantAssociationC)))) + (make-construct association-type + :characteristic construct + :parent-construct parent-construct + :start-revision revision))))) + (when (typep parent-construct 'VersionedConstructC) + (add-to-version-history parent-construct :start-revision revision)) + construct) -(defgeneric delete-parent (construct parent-construct &key revision) - (:documentation "Sets the assoication-object between the passed - constructs as marded-as-deleted.") - (:method ((construct CharacteristicC) (parent-construct ReifiableConstructC) - &key (revision (error "From delete-parent(): revision must be set"))) - (let ((assoc-to-delete - (loop for parent-assoc in (slot-p construct 'parent) - when (eql (parent-construct parent-assoc) parent-construct) - return parent-assoc))) - (when assoc-to-delete - (mark-as-deleted assoc-to-delete :revision revision)) - construct))) +(defmethod delete-parent ((construct CharacteristicC) + (parent-construct ReifiableConstructC) + &key (revision (error "From delete-parent(): revision must be set"))) + (let ((assoc-to-delete + (loop for parent-assoc in (slot-p construct 'parent) + when (eql (parent-construct parent-assoc) parent-construct) + return parent-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision)) + (when (typep parent-construct 'VersionedConstructC) + (add-to-version-history parent-construct :start-revision revision)) + construct)) ;;; OccurrenceC @@ -2037,6 +2050,7 @@ return role-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (add-to-version-history construct :start-revision revision) construct))) @@ -2155,6 +2169,7 @@ return parent-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (add-to-version-history parent-construct :start-revision revision) construct)) @@ -2337,9 +2352,7 @@ :parent-construct construct :identifier item-identifier :start-revision revision))) - (when (or (typep merged-construct 'TopicC) - (typep merged-construct 'AssociationC) - (typep merged-construct 'TopicMapC)) + (when (typep construct 'VersionedConstructC) (add-to-version-history merged-construct :start-revision revision)) merged-construct)))) @@ -2354,6 +2367,8 @@ return ii-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (when (typep construct 'VersionedConstructC) + (add-to-version-history construct :start-revision revision)) construct))) @@ -2391,9 +2406,7 @@ :reifiable-construct construct :reifier-topic merged-reifier-topic :start-revision revision))) - (when (or (typep merged-construct 'TopicC) - (typep merged-construct 'AssociationC) - (typep merged-construct 'TopicMapC)) + (when (typep construct 'VersionedConstructC) (add-to-version-history merged-construct :start-revision revision)) merged-construct))))) @@ -2408,6 +2421,8 @@ return reifier-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (when (typep construct 'VersionedConstructC) + (add-to-version-history construct :start-revision revision)) construct))) @@ -2509,7 +2524,7 @@ :theme-topic theme-topic :scopable-construct construct :start-revision revision))) - (when (typep construct 'AssociationC) + (when (typep construct 'VersionedConstructC) (add-to-version-history construct :start-revision revision)) construct)) @@ -2524,6 +2539,8 @@ return theme-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (when (typep construct 'VersionedConstructC) + (add-to-version-history construct :start-revision revision)) construct))) @@ -2580,7 +2597,7 @@ :type-topic type-topic :typable-construct construct :start-revision revision)))) - (when (typep construct 'AssociationC) + (when (typep construct 'VersionedConstructC) (add-to-version-history construct :start-revision revision)) construct)) @@ -2596,6 +2613,8 @@ return type-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (when (typep construct 'VersionedConstructC) + (add-to-version-history construct :start-revision revision)) construct))) 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 Mon Mar 22 12:24:54 2010 @@ -62,8 +62,6 @@ :test-find-item-by-revision)) -;;TODO: complete all test of the form test-add-<whatever> -;; --> indirect call of add-to-version-history ;;TODO: test make-construct ;;TODO: test merge-constructs @@ -157,10 +155,20 @@ (signals error (make-instance 'ItemIdentifierC)) (is-false (item-identifiers topic-1)) (add-item-identifier topic-1 ii-1) + (is (= (length (d::versions topic-1)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-1) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (item-identifiers topic-1)) 1)) (is (eql (first (item-identifiers topic-1)) ii-1)) (is (eql (identified-construct ii-1) topic-1)) (add-item-identifier topic-1 ii-2 :revision revision-2) + (is (= (length (d::versions topic-1)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-2) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (item-identifiers topic-1 :revision revision-0)) 2)) (is (= (length (item-identifiers topic-1 :revision revision-1)) 1)) (is (eql (first (item-identifiers topic-1 :revision revision-1)) ii-1)) @@ -180,6 +188,11 @@ :revision revision-2))) 2)) (delete-item-identifier topic-1 ii-2 :revision revision-3) + (is (= (length (d::versions topic-1)) 3)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-3) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is-false (item-identifiers topic-1 :revision revision-3)) (add-item-identifier topic-1 ii-1 :revision revision-4) (is (= (length (union (list ii-1) @@ -208,10 +221,20 @@ (signals error (make-instance 'PersistentIdC)) (is-false (psis topic-1)) (add-psi topic-1 psi-1) + (is (= (length (d::versions topic-1)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-1) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (psis topic-1)) 1)) (is (eql (first (psis topic-1)) psi-1)) (is (eql (identified-construct psi-1) topic-1)) (add-psi topic-1 psi-2 :revision revision-2) + (is (= (length (d::versions topic-1)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-2) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (psis topic-1 :revision revision-0)) 2)) (is (= (length (psis topic-1 :revision revision-1)) 1)) (is (eql (first (psis topic-1 :revision revision-1)) psi-1)) @@ -229,6 +252,11 @@ (psis topic-1 :revision revision-2))) 2)) (delete-psi topic-1 psi-2 :revision revision-3) + (is (= (length (d::versions topic-1)) 3)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-3) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is-false (psis topic-1 :revision revision-3)) (add-psi topic-1 psi-1 :revision revision-4) (is (= (length (union (list psi-1) @@ -257,10 +285,20 @@ (signals error (make-instance 'SubjectLocatorC)) (is-false (locators topic-1)) (add-locator topic-1 sl-1) + (is (= (length (d::versions topic-1)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-1) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (locators topic-1)) 1)) (is (eql (first (locators topic-1)) sl-1)) (is (eql (identified-construct sl-1) topic-1)) (add-locator topic-1 sl-2 :revision revision-2) + (is (= (length (d::versions topic-1)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-2) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (locators topic-1 :revision revision-0)) 2)) (is (= (length (locators topic-1 :revision revision-1)) 1)) (is (eql (first (locators topic-1 :revision revision-1)) sl-1)) @@ -271,6 +309,11 @@ (locators topic-1 :revision revision-0))) 2)) (delete-locator topic-1 sl-1 :revision revision-3) + (is (= (length (d::versions topic-1)) 3)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-3) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (union (list sl-2) (locators topic-1 :revision revision-0))) 1)) @@ -311,10 +354,20 @@ :xtm-id "xtm-id-1")) (is-false (topic-identifiers topic-1)) (add-topic-identifier topic-1 ti-1) + (is (= (length (d::versions topic-1)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-1) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (topic-identifiers topic-1)) 1)) (is (eql (first (topic-identifiers topic-1)) ti-1)) (is (eql (identified-construct ti-1) topic-1)) (add-topic-identifier topic-1 ti-2 :revision revision-2) + (is (= (length (d::versions topic-1)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-2) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (topic-identifiers topic-1 :revision revision-0)) 2)) (is (= (length (topic-identifiers topic-1 :revision revision-1)) 1)) (is (eql (first (topic-identifiers topic-1 :revision revision-1)) ti-1)) @@ -325,6 +378,11 @@ (topic-identifiers topic-1 :revision revision-0))) 2)) (delete-topic-identifier topic-1 ti-1 :revision revision-3) + (is (= (length (d::versions topic-1)) 3)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-3) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (union (list ti-2) (topic-identifiers topic-1 :revision revision-0))) 1)) @@ -529,16 +587,31 @@ "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))) + (reified-rc (make-instance 'd::AssociationC)) + (version-0-5 50) + (version-1 100) + (version-2 200) + (version-3 300)) (is-false (reifier reified-rc)) (is-false (reified-construct reifier-top)) - (add-reifier reified-rc reifier-top :revision 100) + (add-reifier reified-rc reifier-top :revision version-1) + (is (= (length (d::versions reified-rc)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) version-1) + (= (d::end-revision vi) 0))) + (d::versions reified-rc))) (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))))) + (is (eql reifier-top (reifier reified-rc :revision version-2))) + (is (eql reified-rc (reified-construct reifier-top :revision version-2))) + (is-false (reifier reified-rc :revision version-0-5)) + (is-false (reified-construct reifier-top :revision version-0-5)) + (delete-reifier reified-rc reifier-top :revision version-3) + (is (= (length (d::versions reified-rc)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) version-3) + (= (d::end-revision vi) 0))) + (d::versions reified-rc)))))) (test test-OccurrenceC () @@ -560,9 +633,19 @@ (is-false (parent occ-1)) (is-false (occurrences top-1)) (add-occurrence top-1 occ-1 :revision revision-1) + (is (= (length (d::versions top-1)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-1) + (= (d::end-revision vi) 0))) + (d::versions top-1))) (is (= (length (union (list occ-1) (occurrences top-1))) 1)) (add-occurrence top-1 occ-2 :revision revision-2) + (is (= (length (d::versions top-1)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-2) + (= (d::end-revision vi) 0))) + (d::versions top-1))) (is (= (length (union (list occ-1 occ-2) (occurrences top-1))) 2)) (is (= (length (union (list occ-1) @@ -570,6 +653,11 @@ (add-occurrence top-1 occ-2 :revision revision-3) (is (= (length (d::slot-p top-1 'd::occurrences)) 2)) (delete-occurrence top-1 occ-1 :revision revision-4) + (is (= (length (d::versions top-1)) 4)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-4) + (= (d::end-revision vi) 0))) + (d::versions top-1))) (is (= (length (union (list occ-2) (occurrences top-1 :revision revision-4))) 1)) (is (= (length (union (list occ-2) @@ -594,7 +682,17 @@ (is (eql top-1 (parent occ-2))) (delete-parent occ-2 top-1 :revision revision-6) (add-parent occ-2 top-2 :revision revision-7) + (is (= (length (d::versions top-2)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-7) + (= (d::end-revision vi) 0))) + (d::versions top-2))) (delete-parent occ-2 top-2 :revision revision-8) + (is (= (length (d::versions top-2)) 3)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-8) + (= (d::end-revision vi) 0))) + (d::versions top-2))) (is-false (parent occ-2)) (add-parent occ-2 top-1 :revision revision-8) (is (eql top-1 (parent occ-2)))))) @@ -678,9 +776,19 @@ (is-false (parent name-1)) (is-false (names top-1)) (add-name top-1 name-1 :revision revision-1) + (is (= (length (d::versions top-1)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-1) + (= (d::end-revision vi) 0))) + (d::versions top-1))) (is (= (length (union (list name-1) (names top-1))) 1)) (add-name top-1 name-2 :revision revision-2) + (is (= (length (d::versions top-1)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-2) + (= (d::end-revision vi) 0))) + (d::versions top-1))) (is (= (length (union (list name-1 name-2) (names top-1))) 2)) (is (= (length (union (list name-1) @@ -688,6 +796,11 @@ (add-name top-1 name-2 :revision revision-3) (is (= (length (d::slot-p top-1 'd::names)) 2)) (delete-name top-1 name-1 :revision revision-4) + (is (= (length (d::versions top-1)) 4)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-4) + (= (d::end-revision vi) 0))) + (d::versions top-1))) (is (= (length (union (list name-2) (names top-1 :revision revision-4))) 1)) (is (= (length (union (list name-2) @@ -712,7 +825,17 @@ (is (eql top-1 (parent name-2))) (delete-parent name-2 top-1 :revision revision-6) (add-parent name-2 top-2 :revision revision-7) + (is (= (length (d::versions top-2)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-7) + (= (d::end-revision vi) 0))) + (d::versions top-2))) (delete-parent name-2 top-2 :revision revision-8) + (is (= (length (d::versions top-2)) 3)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-8) + (= (d::end-revision vi) 0))) + (d::versions top-2))) (is-false (parent name-2)) (add-parent name-2 top-1 :revision revision-8) (is (eql top-1 (parent name-2)))))) @@ -812,15 +935,26 @@ (assoc-2 (make-instance 'AssociationC)) (revision-1 100) (revision-2 200) - (revision-3 300)) + (revision-3 300) + (revision-4 400)) (setf *TM-REVISION* revision-1) (is-false (roles assoc-1)) (is-false (parent role-1)) (add-parent role-1 assoc-1) + (is (= (length (d::versions assoc-1)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-1) + (= (d::end-revision vi) 0))) + (d::versions assoc-1))) (is (eql (parent role-1 :revision revision-1) assoc-1)) (is (= (length (union (list role-1) (roles assoc-1))) 1)) (add-role assoc-1 role-2 :revision revision-2) + (is (= (length (d::versions assoc-1)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-2) + (= (d::end-revision vi) 0))) + (d::versions assoc-1))) (is (= (length (union (list role-1 role-2) (roles assoc-1))) 2)) (is (= (length (union (list role-1) @@ -830,6 +964,11 @@ (is-false (parent role-2 :revision revision-1)) (signals error (add-parent role-2 assoc-2 :revision revision-2)) (delete-role assoc-1 role-1 :revision revision-3) + (is (= (length (d::versions assoc-1)) 3)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-3) + (= (d::end-revision vi) 0))) + (d::versions assoc-1))) (is-false (parent role-1)) (is (= (length (union (list role-2) (roles assoc-1))) 1)) @@ -850,7 +989,13 @@ (is (= (length (slot-value assoc-1 'roles)) 2)) (is (= (length (slot-value assoc-2 'roles)) 2)) (is (= (length (slot-value role-1 'parent)) 2)) - (is (= (length (slot-value role-2 'parent)) 2))))) + (is (= (length (slot-value role-2 'parent)) 2)) + (delete-parent role-1 assoc-2 :revision revision-4) + (is (= (length (d::versions assoc-2)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-4) + (= (d::end-revision vi) 0))) + (d::versions assoc-2)))))) (test test-player ()