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