Author: lgiessmann Date: Mon Mar 22 09:04:20 2010 New Revision: 244 Log: new-datamodel: add "find-item-by-revision" to classes that are non-VersionedConstructC classes but that are related with their parent-constructs via VersionedAssociationCs. added alsome some unit-tests for this generic 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 09:04:20 2010 @@ -156,12 +156,13 @@ - +;;TOOD: replace the key argument (revision 0)/(start-revision 0) +;; by (start-revision *TM-REVISION*) (revision *TM-REVISION*) +;; to be compatible to the macro with-revision ;;TODO: check merge-constructs in add-topic-identifier, -;; add-item-identifier/add-reifier (can merge the parent construct -;; and the parent's parent construct), add-psi, add-locator -;; (--> duplicate-identifier-error) -;;TODO: finalize add-reifier +;; 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-construct" that merges constructs ;; after some data-operations are completed (should be passed as body) ;; and a merge should be done @@ -171,7 +172,7 @@ ;; 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 +;; one revision-infos --> PointerC, CharacteristicC, RoleC ;;; globals ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -746,6 +747,16 @@ ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgeneric find-item-by-revision (construct revision + &optional parent-construct) + (:documentation "Returns the given object if it exists in the passed + version otherwise nil. + Constructs that exist to be owned by parent-constructs + must provide their parent-construct to get the corresponding + revision of the relationship between the construct itself and + its parent-construct.")) + + (defgeneric check-for-duplicate-identifiers (construct) (:documentation "Check for possibly duplicate identifiers and signal an duplicate-identifier-error is such duplicates are found")) @@ -817,6 +828,21 @@ (delete-construct version-info))) +(defmethod find-item-by-revision ((construct VersionedConstructC) + (revision integer) &optional parent-construct) + (declare (ignorable parent-construct)) + (cond ((= revision 0) + (find-most-recent-revision construct)) + (t + (when (find-if + #'(lambda(vi) + (and (>= revision (start-revision vi)) + (or (< revision (end-revision vi)) + (= 0 (end-revision vi))))) + (versions construct)) + construct)))) + + (defmethod get-most-recent-version-info ((construct VersionedConstructC)) (let ((result (find 0 (versions construct) :key #'end-revision))) (if result @@ -836,22 +862,6 @@ construct))) -(defgeneric find-item-by-revision (construct revision) - (:documentation "Returns the given object if it exists in the passed - version otherwise nil.") - (:method ((construct VersionedConstructC) (revision integer)) - (cond ((= revision 0) - (find-most-recent-revision construct)) - (t - (when (find-if - #'(lambda(vi) - (and (>= revision (start-revision vi)) - (or (< revision (end-revision vi)) - (= 0 (end-revision vi))))) - (versions construct)) - construct))))) - - (defgeneric add-to-version-history (construct &key start-revision end-revision) (:documentation "Adds version history to a versioned construct") (:method ((construct VersionedConstructC) @@ -951,6 +961,33 @@ (string= (uri construct) uri)) +(defmethod find-item-by-revision ((construct PointerC) + (revision integer) &optional parent-construct) + (if parent-construct + (let ((parent-assoc + (let ((assocs + (remove-if + #'null + (map 'list #'(lambda(assoc) + (when (eql (parent-construct assoc) + parent-construct) + assoc)) + (slot-p construct 'identified-construct))))) + (when assocs + (first assocs))))) + (cond ((= revision 0) + (find-most-recent-revision parent-assoc)) + (t + (when (find-if + #'(lambda(vi) + (and (>= revision (start-revision vi)) + (or (< revision (end-revision vi)) + (= 0 (end-revision vi))))) + (versions parent-assoc)) + construct)))) + nil)) + + (defmethod delete-construct :before ((construct PointerC)) (dolist (p-assoc (slot-p construct 'identified-construct)) (delete-construct p-assoc))) @@ -1685,6 +1722,35 @@ :start-revision start-revision))) +(defmethod find-item-by-revision ((construct CharacteristicC) + (revision integer) &optional parent-construct) + (if parent-construct + (let ((parent-assoc + (let ((assocs + (remove-if + #'null + (map 'list #'(lambda(assoc) + (when (eql (parent-construct assoc) + parent-construct) + assoc)) + (slot-p construct 'parent))))) + (when assocs + (first assocs))))) + (cond ((= revision 0) + (when + (find-most-recent-revision parent-assoc) + construct)) + (t + (when (find-if + #'(lambda(vi) + (and (>= revision (start-revision vi)) + (or (< revision (end-revision vi)) + (= 0 (end-revision vi))))) + (versions parent-assoc)) + construct)))) + nil)) + + (defmethod delete-construct :before ((construct CharacteristicC)) (dolist (characteristic-assoc-to-delete (slot-p construct 'parent)) (delete-construct characteristic-assoc-to-delete))) @@ -1997,6 +2063,33 @@ (eql player (player construct :revision start-revision)))) +(defmethod find-item-by-revision ((construct RoleC) + (revision integer) &optional parent-construct) + (let ((parent-assoc + (let ((assocs + (remove-if + #'null + (map 'list #'(lambda(assoc) + (when (eql (parent-construct assoc) + parent-construct) + assoc)) + (slot-p construct 'parent))))) + (when assocs + (first assocs))))) + (cond ((= revision 0) + (when + (find-most-recent-revision parent-assoc) + construct)) + (t + (when (find-if + #'(lambda(vi) + (and (>= revision (start-revision vi)) + (or (< revision (end-revision vi)) + (= 0 (end-revision vi))))) + (versions parent-assoc)) + construct))))) + + (defmethod delete-construct :before ((construct RoleC)) (dolist (role-assoc-to-delete (slot-p construct 'parent)) (delete-construct role-assoc-to-delete)) 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 09:04:20 2010 @@ -58,9 +58,12 @@ :test-equivalent-AssociationC :test-equivalent-TopicC :test-equivalent-TopicMapC - :test-class-p)) + :test-class-p + :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 @@ -1627,6 +1630,80 @@ (is-false (d:PointerC-p class)))))) +(test test-find-item-by-revision () + "Tests the function find-item-by-revision." + (with-fixture with-empty-db (*db-dir*) + (let ((top-1 (make-instance 'TopicC)) + (top-2 (make-instance 'TopicC)) + (assoc-1 (make-instance 'AssociationC)) + (assoc-2 (make-instance 'AssociationC)) + (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2")) + (psi-1 (make-instance 'PersistentIdC :uri "psi-1")) + (name-1 (make-instance 'NameC)) + (name-2 (make-instance 'NameC)) + (variant-1 (make-instance 'VariantC)) + (role-1 (make-instance 'RoleC)) + (rev-0 0) + (rev-0-5 50) + (rev-1 100) + (rev-2 200) + (rev-3 300) + (rev-4 400) + (rev-5 500)) + (setf *TM-REVISION* rev-1) + (d::add-to-version-history top-1 :start-revision rev-1) + (d::add-to-version-history top-1 :start-revision rev-3) + (is (eql top-1 (find-item-by-revision top-1 rev-1))) + (is (eql top-1 (find-item-by-revision top-1 rev-0))) + (is (eql top-1 (find-item-by-revision top-1 rev-4))) + (is (eql top-1 (find-item-by-revision top-1 rev-2))) + (is-false (find-item-by-revision top-1 rev-0-5)) + (add-item-identifier top-1 ii-1 :revision rev-3) + (add-item-identifier top-1 ii-2 :revision rev-3) + (add-item-identifier top-1 ii-1 :revision rev-4) + (delete-item-identifier top-1 ii-1 :revision rev-5) + (add-item-identifier top-2 ii-1 :revision rev-5) + (add-psi top-2 psi-1 :revision rev-1) + (is (eql ii-1 (find-item-by-revision ii-1 rev-3 top-1))) + (is (eql ii-1 (find-item-by-revision ii-1 rev-4 top-1))) + (is-false (find-item-by-revision ii-1 rev-2 top-1)) + (is-false (find-item-by-revision ii-1 rev-5 top-1)) + (is-false (find-item-by-revision ii-1 rev-3)) + (is-false (find-item-by-revision ii-1 rev-0 top-1)) + (is (eql ii-1 (find-item-by-revision ii-1 rev-5 top-2))) + (add-role assoc-1 role-1 :revision rev-1) + (delete-role assoc-1 role-1 :revision rev-3) + (add-role assoc-2 role-1 :revision rev-5) + (is (eql role-1 (find-item-by-revision role-1 rev-1 assoc-1))) + (is (eql role-1 (find-item-by-revision role-1 rev-2 assoc-1))) + (is (eql role-1 (find-item-by-revision role-1 rev-5 assoc-2))) + (is (eql role-1 (find-item-by-revision role-1 rev-0 assoc-2))) + (is-false (find-item-by-revision role-1 rev-0-5 assoc-1)) + (is-false (find-item-by-revision role-1 rev-0 assoc-1)) + (is-false (find-item-by-revision role-1 rev-3 assoc-1)) + (is-false (find-item-by-revision role-1 rev-3 assoc-2)) + (add-name top-1 name-1 :revision rev-1) + (delete-name top-1 name-1 :revision rev-3) + (add-name top-2 name-1 :revision rev-3) + (is (eql name-1 (find-item-by-revision name-1 rev-1 top-1))) + (is (eql name-1 (find-item-by-revision name-1 rev-2 top-1))) + (is (eql name-1 (find-item-by-revision name-1 rev-5 top-2))) + (is (eql name-1 (find-item-by-revision name-1 rev-0 top-2))) + (is-false (find-item-by-revision name-1 rev-0-5 top-1)) + (is-false (find-item-by-revision name-1 rev-0 top-1)) + (is-false (find-item-by-revision name-1 rev-3 top-1)) + (add-variant name-1 variant-1 :revision rev-1) + (delete-variant name-1 variant-1 :revision rev-3) + (add-variant name-2 variant-1 :revision rev-3) + (is (eql variant-1 (find-item-by-revision variant-1 rev-1 name-1))) + (is (eql variant-1 (find-item-by-revision variant-1 rev-2 name-1))) + (is (eql variant-1 (find-item-by-revision variant-1 rev-5 name-2))) + (is (eql variant-1 (find-item-by-revision variant-1 rev-0 name-2))) + (is-false (find-item-by-revision variant-1 rev-0-5 name-1)) + (is-false (find-item-by-revision variant-1 rev-0 name-1)) + (is-false (find-item-by-revision variant-1 rev-3 name-1))))) + @@ -1672,4 +1749,5 @@ (it.bese.fiveam:run! 'test-equivalent-TopicC) (it.bese.fiveam:run! 'test-equivalent-TopicMapC) (it.bese.fiveam:run! 'test-class-p) + (it.bese.fiveam:run! 'test-find-item-by-revision) ) \ No newline at end of file