[isidorus-cvs] r244 - in branches/new-datamodel/src: model unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Mon Mar 22 13:04:20 UTC 2010
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
More information about the Isidorus-cvs
mailing list