[isidorus-cvs] r215 - in branches/new-datamodel/src: model unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Sat Feb 27 10:22:24 UTC 2010
Author: lgiessmann
Date: Sat Feb 27 05:22:23 2010
New Revision: 215
Log:
new-datamodel: added some unit-tests for the class RoleC; fixed a bug in add-parent and add-role
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 Sat Feb 27 05:22:23 2010
@@ -94,9 +94,6 @@
(in-package :datamodel)
-;;TODO: add-type/add-parent/add-<x>-identifier handle situation where
-;; new objects hve to be bound in an earlier revision than one
-;; where a object is already bound
;;TODO: finalize add-reifier
;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo
;; initarg in make-construct
@@ -265,7 +262,7 @@
(defpclass AssociationC(ReifiableConstructC ScopableC TypableC
VersionedConstructC)
- ((roles :associate (RoleAssociationC association)
+ ((roles :associate (RoleAssociationC parent-construct)
:documentation "Contains all association-objects of all roles this
association contains.")
(in-topicmaps :associate (TopicMapC associations)
@@ -1424,8 +1421,7 @@
(:method ((construct AssociationC) (role RoleC)
&key (revision *TM-REVISION*))
(let ((all-roles
- (map 'list #'role
- (remove-if #'marked-as-deleted-p (slot-p construct 'roles)))))
+ (map 'list #'role (slot-p construct 'roles))))
(if (find role all-roles)
(let ((role-assoc
(loop for role-assoc in (slot-p construct 'roles)
@@ -1435,7 +1431,7 @@
(let ((assoc
(make-instance 'RoleAssociationC
:role role
- :association construct)))
+ :parent-construct construct)))
(add-to-version-history assoc :start-revision revision))))
construct))
@@ -1477,27 +1473,29 @@
(defmethod add-parent ((construct RoleC) (parent-construct AssociationC)
&key (revision *TM-REVISION*))
- (let ((already-set-parent
- (map 'list #'parent
- (filter-slot-value-by-revision construct 'parent
- :start-revision revision))))
- (cond ((and already-set-parent
- (eql (first already-set-parent) parent-construct))
- (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)))
- ((not already-set-parent)
- (let ((assoc (make-instance 'RoleAssociationC
- :role construct
- :parent-construct parent-construct)))
- (add-to-version-history assoc :start-revision revision)))
- (t
- (error "From add-parent(): ~a can't be a parent of ~a since it is already owned by the association ~a"
- parent-construct construct already-set-parent)))
- construct))
+ (let ((already-set-parent (parent construct :revision revision))
+ (same-parent-assoc (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 ((assoc (make-instance 'RoleAssociationC
+ :role construct
+ :parent-construct parent-construct)))
+ (add-to-version-history assoc :start-revision revision)))))
+ construct)
(defmethod delete-parent ((construct RoleC) (parent-construct AssociationC)
@@ -1526,10 +1524,7 @@
(:documentation "Adds a topic as a player to a role in the given revision.")
(:method ((construct RoleC) (player-topic TopicC)
&key (revision *TM-REVISION*))
- (let ((already-set-player
- (map 'list #'player-topic
- (filter-slot-value-by-revision construct 'player
- :start-revision revision))))
+ (let ((already-set-player (player construct :revision revision)))
;;TODO: search a player-assoc for the passed construct that was set in an older version
(cond ((and already-set-player
(eql (first already-set-player) player-topic))
@@ -1763,10 +1758,7 @@
set at the same revision.")
(:method ((construct TypableC) (type-topic TopicC)
&key (revision *TM-REVISION*))
- (let ((already-set-type
- (map 'list #'type-topic
- (filter-slot-value-by-revision construct 'instance-of
- :start-revision revision)))
+ (let ((already-set-type (instance-of construct :revision revision))
(same-type-assoc
(loop for type-assoc in (slot-p construct 'instance-of)
when (eql (type-topic type-assoc) type-topic)
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 Sat Feb 27 05:22:23 2010
@@ -17,6 +17,7 @@
(:import-from :exceptions
duplicate-identifier-error)
(:export :run-datamodel-tests
+ :datamodel-test
:test-VersionInfoC
:test-VersionedConstructC
:test-ItemIdentifierC
@@ -32,7 +33,8 @@
:test-VariantC
:test-NameC
:test-TypableC
- :test-ScopableC))
+ :test-ScopableC
+ :test-RoleC))
;;TODO: test delete-construct
@@ -776,6 +778,56 @@
(is (= (length (slot-value occ-2 'd::themes)) 1))
(is (= (length (slot-value top-1 'd::used-as-theme)) 1))
(is (= (length (slot-value top-2 'd::used-as-theme)) 2)))))
+
+
+(test test-RoleC ()
+ "Tests various functions of the class RoleC."
+ (with-fixture with-empty-db (*db-dir*)
+ (let ((role-1 (make-instance 'RoleC))
+ (role-2 (make-instance 'RoleC))
+ (assoc-1 (make-instance 'AssociationC))
+ (assoc-2 (make-instance 'AssociationC))
+ (revision-1 100)
+ (revision-2 200)
+ (revision-3 300))
+ (setf *TM-REVISION* revision-1)
+ (is-false (roles assoc-1))
+ (is-false (parent role-1))
+ (add-parent role-1 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 (union (list role-1 role-2)
+ (roles assoc-1))) 2))
+ (is (= (length (union (list role-1)
+ (roles assoc-1 :revision revision-1))) 1))
+ (is (eql (parent role-1) assoc-1))
+ (is (eql (parent role-2 :revision revision-2) assoc-1))
+ (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-false (parent role-1))
+ (is (= (length (union (list role-2)
+ (roles assoc-1))) 1))
+ (delete-parent role-2 assoc-1 :revision revision-3)
+ (is-false (parent role-2))
+ (is (eql assoc-1 (parent role-2 :revision revision-2)))
+ (is-false (roles assoc-1))
+ (add-role assoc-2 role-1 :revision revision-3)
+ (add-parent role-2 assoc-2 :revision revision-3)
+ (is (eql (parent role-2) assoc-2))
+ (is (= (length (union (list role-1 role-2)
+ (roles assoc-2))) 2))
+ (add-role assoc-2 role-1 :revision revision-3)
+ (add-parent role-2 assoc-2 :revision revision-3)
+ (is (eql (parent role-2) assoc-2))
+ (is (= (length (union (list role-1 role-2)
+ (roles assoc-2))) 2))
+ (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)))))
@@ -796,4 +848,5 @@
(it.bese.fiveam:run! 'test-NameC)
(it.bese.fiveam:run! 'test-TypableC)
(it.bese.fiveam:run! 'test-ScopableC)
+ (it.bese.fiveam:run! 'test-RoleC)
)
\ No newline at end of file
More information about the Isidorus-cvs
mailing list