[isidorus-cvs] r202 - in branches/new-datamodel/src: model unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Tue Feb 23 19:35:33 UTC 2010
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
More information about the Isidorus-cvs
mailing list