Author: lgiessmann Date: Tue Feb 23 14:35:31 2010 New Revision: 202 Log: new-datamode: added some unit-tests for PersistentIdC and SubjectLocatorC; fixed some bugs related to PersistentIdC, SubjectLocatorC and TopicC 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 Feb 23 14:35:31 2010 @@ -87,6 +87,8 @@ (in-package :datamodel) +;;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 ;; after some data-operations are completed (should be passed as body) ;; and a merge should be done @@ -287,7 +289,7 @@ (psis :associate (PersistentIdAssociationC parent-construct) :documentation "Contains all association objects that relate a topic with its actual psis.") - (locators :associate (PersistentIdAssociationC parent-construct) + (locators :associate (SubjectLocatorAssociationC parent-construct) :documentation "Contains all association objects that relate a topic with its actual subject-lcoators.") (names :associate (NameAssociationC parent-construct) @@ -824,24 +826,27 @@ (:method ((construct TopicC) (psi PersistentIdC) &key (revision *TM-REVISION*)) (let ((all-ids - (map 'list #'identifier - (remove-if #'marked-as-deleted-p - (slot-p construct 'psis))))) - (cond ((find psi all-ids) + (map 'list #'identifier (slot-p construct 'psis))) + (construct-to-be-merged + (let ((id-owner (identified-construct psi))) + (when (not (eql id-owner construct)) + id-owner)))) + (cond (construct-to-be-merged + (merge-constructs (identified-construct construct-to-be-merged + :revision revision) + construct)) + ((find psi all-ids) (let ((psi-assoc (loop for psi-assoc in (slot-p construct 'psis) when (eql (identifier psi-assoc) psi) return psi-assoc))) (add-to-version-history psi-assoc :start-revision revision))) - (all-ids - (merge-constructs (identified-construct (first all-ids) - :revision revision) - construct)) (t - (make-instance 'PersistentIdAssociationC - :start-revision revision - :parent-construct construct - :identifier psi) - construct))))) + (let ((assoc + (make-instance 'PersistentIdAssociationC + :parent-construct construct + :identifier psi))) + (add-to-version-history assoc :start-revision revision)))) + construct))) (defgeneric delete-psi (construct psi &key revision) @@ -875,24 +880,27 @@ (:method ((construct TopicC) (locator SubjectLocatorC) &key (revision *TM-REVISION*)) (let ((all-ids - (map 'list #'identifier - (remove-if #'marked-as-deleted-p - (slot-p construct 'locators))))) - (cond ((find locator all-ids) + (map 'list #'identifier (slot-p construct 'locators))) + (construct-to-be-merged + (let ((id-owner (identified-construct locator))) + (when (not (eql id-owner construct)) + id-owner)))) + (cond (construct-to-be-merged + (merge-constructs (identified-construct construct-to-be-merged + :revision revision) + construct)) + ((find locator all-ids) (let ((loc-assoc (loop for loc-assoc in (slot-p construct 'locators) when (eql (identifier loc-assoc) locator) return loc-assoc))) (add-to-version-history loc-assoc :start-revision revision))) - (all-ids - (merge-constructs (identified-construct (first all-ids) - :revision revision) - construct)) (t - (make-instance 'SubjectLocatorAssociationC - :start-revision revision - :parent-construct construct - :identifier locator) - construct))))) + (let ((assoc + (make-instance 'SubjectLocatorAssociationC + :parent-construct construct + :identifier locator))) + (add-to-version-history assoc :start-revision revision)))) + construct))) (defgeneric delete-locator (construct locator &key revision) @@ -1513,16 +1521,16 @@ (let ((id-owner (identified-construct item-identifier))) (when (not (eql id-owner construct)) id-owner)))) - (cond ((find item-identifier all-ids) + (cond (construct-to-be-merged + (merge-constructs (identified-construct construct-to-be-merged + :revision revision) + construct)) + ((find item-identifier all-ids) (let ((ii-assoc (loop for ii-assoc in (slot-p construct 'item-identifiers) when (eql (identifier ii-assoc) item-identifier) return ii-assoc))) (add-to-version-history ii-assoc :start-revision revision))) - (construct-to-be-merged - (merge-constructs (identified-construct construct-to-be-merged - :revision revision) - construct)) (t (let ((assoc (make-instance 'ItemIdAssociationC 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 Feb 23 14:35:31 2010 @@ -17,7 +17,15 @@ (:export :run-datamodel-tests :test-VersionInfoC :test-VersionedConstructC - :test-ItemIdentifierC)) + :test-ItemIdentifierC + :test-PersistentIdC + :test-SubjectLocatorC)) + + +;;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 + (declaim (optimize (debug 3))) @@ -44,9 +52,7 @@ (is (= (d::end-revision vi-1) 300)) (is (= (d::start-revision vi-2) 300)) (is (= (d::end-revision vi-2) 0)) - (is-false (d::versioned-construct-p vi-1)) - (setf (d::versioned-construct vi-1) vc) - (is-true (d::versioned-construct-p vi-1))))) + (setf (d::versioned-construct vi-1) vc)))) (test test-VersionedConstructC () @@ -78,9 +84,6 @@ (= sr-2 100) (= er-2 500))))) (d::add-to-version-history vc :start-revision 600) (is (= (length (d::versions vc)) 3)) - (map 'list #'(lambda(vi) - (is-true (d::versioned-construct-p vi))) - (d::versions vc)) (d::add-to-version-history vc :start-revision 100 :end-revision 500) @@ -95,13 +98,13 @@ (test test-ItemIdentifierC () - "Tests various functions of the VersionedCoinstructC class." + "Tests various functions of the ItemIdentifierC class." (with-fixture with-empty-db (*db-dir*) - (let ((ii-1 (make-instance 'd:ItemIdentifierC + (let ((ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) - (ii-2 (make-instance 'd:ItemIdentifierC + (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2")) - (topic-1 (make-instance 'd:TopicC)) + (topic-1 (make-instance 'TopicC)) (revision-0 0) (revision-1 100) (revision-2 200) @@ -109,14 +112,14 @@ (revision-3-5 350) (revision-4 400)) (setf d:*TM-REVISION* revision-1) - (is-false (d:identified-construct ii-1)) - (signals error (make-instance 'd:ItemIdentifierC)) + (is-false (identified-construct ii-1)) + (signals error (make-instance 'ItemIdentifierC)) (is-false (item-identifiers topic-1)) - (d:add-item-identifier topic-1 ii-1) + (add-item-identifier topic-1 ii-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)) - (d:add-item-identifier topic-1 ii-2 :revision revision-2) + (add-item-identifier topic-1 ii-2 :revision revision-2) (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)) @@ -128,11 +131,11 @@ 2)) (delete-item-identifier topic-1 ii-1 :revision revision-3) (is (= (length (union (list ii-2) - (d:item-identifiers topic-1 + (item-identifiers topic-1 :revision revision-0))) 1)) (is (= (length (union (list ii-1 ii-2) - (d:item-identifiers topic-1 + (item-identifiers topic-1 :revision revision-2))) 2)) (delete-item-identifier topic-1 ii-2 :revision revision-3) @@ -143,10 +146,110 @@ 1)) (is (= (length (d::slot-p topic-1 'd::item-identifiers)) 2)) (is-false (item-identifiers topic-1 :revision revision-3-5))))) - + + +(test test-PersistentIdC () + "Tests various functions of the PersistentIdC class." + (with-fixture with-empty-db (*db-dir*) + (let ((psi-1 (make-instance 'PersistentIdC + :uri "psi-1")) + (psi-2 (make-instance 'PersistentIdC + :uri "psi-2")) + (topic-1 (make-instance 'TopicC)) + (revision-0 0) + (revision-1 100) + (revision-2 200) + (revision-3 300) + (revision-3-5 350) + (revision-4 400)) + (setf d:*TM-REVISION* revision-1) + (is-false (identified-construct psi-1)) + (signals error (make-instance 'PersistentIdC)) + (is-false (psis topic-1)) + (add-psi topic-1 psi-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 (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)) + (is (= (length (union (list psi-1 psi-2) + (psis topic-1 :revision revision-2))) + 2)) + (is (= (length (union (list psi-1 psi-2) + (psis topic-1 :revision revision-0))) + 2)) + (delete-psi topic-1 psi-1 :revision revision-3) + (is (= (length (union (list psi-2) + (psis topic-1 :revision revision-0))) + 1)) + (is (= (length (union (list psi-1 psi-2) + (psis topic-1 :revision revision-2))) + 2)) + (delete-psi topic-1 psi-2 :revision revision-3) + (is-false (psis topic-1 :revision revision-3)) + (add-psi topic-1 psi-1 :revision revision-4) + (is (= (length (union (list psi-1) + (psis topic-1 :revision revision-0))) + 1)) + (is (= (length (d::slot-p topic-1 'd::psis)) 2)) + (is-false (psis topic-1 :revision revision-3-5))))) + + +(test test-SubjectLocatorC () + "Tests various functions of the SubjectLocatorC class." + (with-fixture with-empty-db (*db-dir*) + (let ((sl-1 (make-instance 'SubjectLocatorC + :uri "sl-1")) + (sl-2 (make-instance 'SubjectLocatorC + :uri "sl-2")) + (topic-1 (make-instance 'TopicC)) + (revision-0 0) + (revision-1 100) + (revision-2 200) + (revision-3 300) + (revision-3-5 350) + (revision-4 400)) + (setf d:*TM-REVISION* revision-1) + (is-false (identified-construct sl-1)) + (signals error (make-instance 'SubjectLocatorC)) + (is-false (locators topic-1)) + (add-locator topic-1 sl-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 (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)) + (is (= (length (union (list sl-1 sl-2) + (locators topic-1 :revision revision-2))) + 2)) + (is (= (length (union (list sl-1 sl-2) + (locators topic-1 :revision revision-0))) + 2)) + (delete-locator topic-1 sl-1 :revision revision-3) + (is (= (length (union (list sl-2) + (locators topic-1 :revision revision-0))) + 1)) + (is (= (length (union (list sl-1 sl-2) + (locators topic-1 :revision revision-2))) + 2)) + (delete-locator topic-1 sl-2 :revision revision-3) + (is-false (locators topic-1 :revision revision-3)) + (add-locator topic-1 sl-1 :revision revision-4) + (is (= (length (union (list sl-1) + (locators topic-1 :revision revision-0))) + 1)) + (is (= (length (d::slot-p topic-1 'd::locators)) 2)) + (is-false (locators topic-1 :revision revision-3-5))))) + (defun run-datamodel-tests() (it.bese.fiveam:run! 'test-VersionInfoC) (it.bese.fiveam:run! 'test-VersionedConstructC) (it.bese.fiveam:run! 'test-ItemIdentifierC) + (it.bese.fiveam:run! 'test-PersistentIdC) + (it.bese.fiveam:run! 'test-SubjectLocatorC) ) \ No newline at end of file