February 2010 - isidorus-cvs@lists.common-lisp.net

[isidorus-cvs] r217 - in branches/new-datamodel: docs src/model src/unit_tests
by Lukas Giessmann 27 Feb '10

27 Feb '10

Author: lgiessmann Date: Sat Feb 27 06:37:56 2010 New Revision: 217 Log: new-datamodel: added some unit-tests for the class TopicMapC; added the generics add-to-tm and delete-from-tm. Modified: branches/new-datamodel/docs/isidorus_data_model.pdf branches/new-datamodel/docs/isidorus_data_model.vsd branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/unit_tests/datamodel_test.lisp Modified: branches/new-datamodel/docs/isidorus_data_model.pdf ============================================================================== Binary files branches/new-datamodel/docs/isidorus_data_model.pdf (original) and branches/new-datamodel/docs/isidorus_data_model.pdf Sat Feb 27 06:37:56 2010 differ Modified: branches/new-datamodel/docs/isidorus_data_model.vsd ============================================================================== Binary files. No diff available. 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 06:37:56 2010 @@ -25,7 +25,7 @@ :TopicIdentificationC :TopicC - ;;methods and functions + ;;methods, functions and macros :xtm-id :uri :identified-construct @@ -56,6 +56,8 @@ :delete-role :associations :topics + :add-to-tm + :delete-from-tm :psis :add-psi :delete-psi @@ -86,6 +88,7 @@ :get-item-by-item-identifier :get-item-by-locator :string-integer-p + :with-revision ;;globals :*TM-REVISION* @@ -281,11 +284,11 @@ (elephant:defpclass TopicMapC (ReifiableConstructC VersionedConstructC) - ((topics :accessor topics - :associate (TopicC in-topicmaps) + ((topics :associate (TopicC in-topicmaps) + :many-to-many t :documentation "List of topics that explicitly belong to this TM.") - (associations :accessor associations - :associate (AssociationC in-topicmaps) + (associations :associate (AssociationC in-topicmaps) + :many-to-many t :documentation "List of associations that belong to this TM.")) (:documentation "Represnets a topic map.")) @@ -557,6 +560,12 @@ ;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defmacro with-revision (revision &rest body) + `(let + ((*TM-REVISION* ,revision)) + ,@body)) + + (defun slot-p (instance slot-symbol) "Returns t if the slot depending on slot-symbol is bound and not nil." (if (slot-boundp instance slot-symbol) @@ -1803,7 +1812,45 @@ construct))) +;;; TopicMapC +(defgeneric topics (construct &key revision) + (:documentation "Returns all TopicC-objects that are contained in the tm.") + (:method ((construct TopicMapC) &key (revision 0)) + (filter-slot-value-by-revision construct 'topics + :start-revision revision))) + + +(defgeneric associations (construct &key revision) + (:documentation "Returns all AssociationC-objects that are contained in the tm.") + (:method ((construct TopicMapC) &key (revision 0)) + (filter-slot-value-by-revision construct 'associations + :start-revision revision))) + + +(defgeneric add-to-tm (construct construct-to-add) + (:documentation "Adds a TM construct (TopicC or AssociationC) to the TM.")) + + +(defmethod add-to-tm ((construct TopicMapC) (construct-to-add TopicC)) + (add-association construct 'topics construct-to-add)) + + +(defmethod add-to-tm ((construct TopicMapC) (construct-to-add AssociationC)) + (add-association construct 'associations construct-to-add)) + + +(defgeneric delete-from-tm (construct construct-to-delete) + (:documentation "Deletes a TM construct (TopicC or AssociationC) from + the TM.")) + + +(defmethod delete-from-tm ((construct TopicMapC) (construct-to-delete TopicC)) + (remove-association construct 'topics construct-to-delete)) + +(defmethod delete-from-tm ((construct TopicMapC) + (construct-to-delete AssociationC)) + (remove-association construct 'associations construct-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 Sat Feb 27 06:37:56 2010 @@ -35,7 +35,8 @@ :test-TypableC :test-ScopableC :test-RoleC - :test-player)) + :test-player + :test-TopicMapC)) ;;TODO: test delete-construct @@ -868,10 +869,57 @@ (is (= (length (union (list role-1 role-2) (player-in-roles top-1))) 2)) (is (= (length (slot-value top-1 'd::player-in-roles)) 2))))) + + +(test test-TopicMapC () + "Tests various function of the class TopicMapC." + (with-fixture with-empty-db (*db-dir*) + (let ((tm-1 (make-instance 'TopicMapC)) + (tm-2 (make-instance 'TopicMapC)) + (top-1 (make-instance 'TopicC)) + (assoc-1 (make-instance 'AssociationC)) + (revision-0-5 50) + (revision-1 100)) + (setf *TM-REVISION* revision-1) + (is-false (topics tm-1)) + (is-false (in-topicmaps top-1)) + (is-false (in-topicmaps assoc-1)) + (d::add-to-version-history top-1 :start-revision revision-1) + (add-to-tm tm-1 top-1) + (is (= (length (union (list top-1) + (topics tm-1))) 1)) + (is (= (length (union (list tm-1) + (in-topicmaps top-1))) 1)) + (is-false (topics tm-1 :revision revision-0-5)) + (is-false (in-topicmaps top-1 :revision revision-0-5)) + (d::add-to-version-history assoc-1 :start-revision revision-1) + (add-to-tm tm-1 assoc-1) + (is (= (length (union (list assoc-1) + (associations tm-1))) 1)) + (is (= (length (union (list tm-1) + (in-topicmaps assoc-1))) 1)) + (is-false (associations tm-1 :revision revision-0-5)) + (is-false (in-topicmaps assoc-1 :revision revision-0-5)) + (add-to-tm tm-2 top-1) + (is (= (length (union (list top-1) + (topics tm-2))) 1)) + (is (= (length (union (list tm-2 tm-1) + (in-topicmaps top-1))) 2)) + (is-false (topics tm-2 :revision revision-0-5)) + (is-false (in-topicmaps top-1 :revision revision-0-5)) + (d::add-to-version-history assoc-1 :start-revision revision-1) + (add-to-tm tm-2 assoc-1) + (is (= (length (union (list assoc-1) + (associations tm-2))) 1)) + (is (= (length (union (list tm-2 tm-1) + (in-topicmaps assoc-1))) 2)) + (is-false (associations tm-2 :revision revision-0-5)) + (is-false (in-topicmaps assoc-1 :revision revision-0-5))))) (defun run-datamodel-tests() + "Runs all tests of this test-suite." (it.bese.fiveam:run! 'test-VersionInfoC) (it.bese.fiveam:run! 'test-VersionedConstructC) (it.bese.fiveam:run! 'test-ItemIdentifierC) @@ -890,4 +938,4 @@ (it.bese.fiveam:run! 'test-ScopableC) (it.bese.fiveam:run! 'test-RoleC) (it.bese.fiveam:run! 'test-player) -) \ No newline at end of file + (it.bese.fiveam:run! 'test-TopicMapC)) \ No newline at end of file

1 0

[isidorus-cvs] r216 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 27 Feb '10

27 Feb '10

Author: lgiessmann Date: Sat Feb 27 05:43:01 2010 New Revision: 216 Log: new-datamodel: added some unit-tests for the class RoleC --> player handling. 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:43:01 2010 @@ -1524,24 +1524,29 @@ (: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 (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)) + (let ((already-set-player (player construct :revision revision)) + (same-player-assoc + (loop for player-assoc in (slot-p construct 'player) + when (eql (player-topic player-assoc) player-topic) + return player-assoc))) + (when (and already-set-player + (not (eql already-set-player player-topic))) + (error "From add-player(): ~a can't be palyed by ~a since it is played by ~a" + construct player-topic already-set-player)) + (cond (already-set-player (let ((player-assoc (loop for player-assoc in (slot-p construct 'player) when (eql player-topic (player-topic player-assoc)) return player-assoc))) (add-to-version-history player-assoc :start-revision revision))) - ((not already-set-player) + (same-player-assoc + (add-to-version-history same-player-assoc :start-revision revision)) + (t (let ((assoc (make-instance 'PlayerAssociationC :parent-construct construct :player-topic player-topic))) - (add-to-version-history assoc :start-revision revision))) - (t - (error "From add-player(): ~a can't be a player of ~a since it has already the player ~a" - player-topic construct already-set-player))) - construct))) + (add-to-version-history assoc :start-revision revision))))) + construct)) (defgeneric delete-player (construct player-topic &key revision) 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:43:01 2010 @@ -34,7 +34,8 @@ :test-NameC :test-TypableC :test-ScopableC - :test-RoleC)) + :test-RoleC + :test-player)) ;;TODO: test delete-construct @@ -828,6 +829,45 @@ (is (= (length (slot-value assoc-2 'roles)) 2)) (is (= (length (slot-value role-1 'parent)) 2)) (is (= (length (slot-value role-2 'parent)) 2))))) + + +(test test-player () + "Tests various functions of the topics that are used as player in roles." + (with-fixture with-empty-db (*db-dir*) + (let ((role-1 (make-instance 'RoleC)) + (role-2 (make-instance 'RoleC)) + (top-1 (make-instance 'TopicC)) + (top-2 (make-instance 'TopicC)) + (revision-0-5 50) + (revision-1 100) + (revision-2 200) + (revision-3 300)) + (setf *TM-REVISION* revision-1) + (is-false (player role-1)) + (add-player role-1 top-1) + (is (eql top-1 (player role-1))) + (is-false (player role-1 :revision revision-0-5)) + (is (eql top-1 (player role-1 :revision revision-2))) + (add-player role-1 top-1) + (is (eql top-1 (player role-1))) + (is-false (player role-1 :revision revision-0-5)) + (is (eql top-1 (player role-1 :revision revision-2))) + (signals error (add-player role-1 top-2)) + (add-player role-2 top-1 :revision revision-2) + (is (= (length (union (list role-1 role-2) + (player-in-roles top-1))) 2)) + (is (= (length (union (list role-1) + (player-in-roles top-1 + :revision revision-1))) 1)) + (delete-player role-1 top-1 :revision revision-3) + (is-false (player role-1)) + (is (= (length (union (list role-2) + (player-in-roles top-1))) 1)) + (add-player role-1 top-1 :revision revision-3) + (is (eql top-1 (player role-1))) + (is (= (length (union (list role-1 role-2) + (player-in-roles top-1))) 2)) + (is (= (length (slot-value top-1 'd::player-in-roles)) 2))))) @@ -849,4 +889,5 @@ (it.bese.fiveam:run! 'test-TypableC) (it.bese.fiveam:run! 'test-ScopableC) (it.bese.fiveam:run! 'test-RoleC) + (it.bese.fiveam:run! 'test-player) ) \ No newline at end of file

1 0

[isidorus-cvs] r215 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 27 Feb '10

27 Feb '10

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

1 0

[isidorus-cvs] r214 - in branches/new-datamodel: docs src/model src/unit_tests
by Lukas Giessmann 26 Feb '10

26 Feb '10

Author: lgiessmann Date: Fri Feb 26 15:22:11 2010 New Revision: 214 Log: new-datamodel: added some unit-tests for the base class ScopableC. Modified: branches/new-datamodel/docs/isidorus_data_model.pdf branches/new-datamodel/docs/isidorus_data_model.vsd branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/unit_tests/datamodel_test.lisp Modified: branches/new-datamodel/docs/isidorus_data_model.pdf ============================================================================== Binary files branches/new-datamodel/docs/isidorus_data_model.pdf (original) and branches/new-datamodel/docs/isidorus_data_model.pdf Fri Feb 26 15:22:11 2010 differ Modified: branches/new-datamodel/docs/isidorus_data_model.vsd ============================================================================== Binary files. No diff available. Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Fri Feb 26 15:22:11 2010 @@ -1711,8 +1711,7 @@ (:method ((construct ScopableC) (theme-topic TopicC) &key (revision *TM-REVISION*)) (let ((all-themes - (map 'list #'theme-topic - (remove-if #'marked-as-deleted-p (slot-p construct 'themes))))) + (map 'list #'theme-topic (slot-p construct 'themes)))) (if (find theme-topic all-themes) (let ((theme-assoc (loop for theme-assoc in (slot-p construct 'themes) @@ -1720,7 +1719,7 @@ return theme-assoc))) (add-to-version-history theme-assoc :start-revision revision)) (let ((assoc - (make-instance 'ScopeAssociationCn + (make-instance 'ScopeAssociationC :theme-topic theme-topic :scopable-construct construct))) (add-to-version-history assoc :start-revision revision)))) 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 Fri Feb 26 15:22:11 2010 @@ -31,7 +31,8 @@ :test-OccurrenceC :test-VariantC :test-NameC - :test-TypableC)) + :test-TypableC + :test-ScopableC)) ;;TODO: test delete-construct @@ -725,6 +726,56 @@ (is (= (length (union (list name-1 name-2) (used-as-type top-1))) 2)) (is (= (length (slot-value top-1 'd::used-as-type)) 2))))) + + +(test test-ScopableC () + "Tests various functions of the base class ScopableC." + (with-fixture with-empty-db (*db-dir*) + (let ((occ-1 (make-instance 'OccurrenceC)) + (occ-2 (make-instance 'OccurrenceC)) + (top-1 (make-instance 'TopicC)) + (top-2 (make-instance 'TopicC)) + (revision-1 100) + (revision-2 200) + (revision-3 300)) + (setf *TM-REVISION* revision-1) + (is-false (themes occ-1)) + (is-false (used-as-theme top-1)) + (add-theme occ-1 top-1) + (is (= (length (union (list top-1) + (themes occ-1))) 1)) + (is (= (length (union (list occ-1) + (used-as-theme top-1))) 1)) + (delete-theme occ-1 top-1 :revision revision-2) + (is (= (length (union (list top-1) + (themes occ-1 :revision revision-1))) 1)) + (is-false (themes occ-1)) + (is-false (used-as-theme top-1)) + (is-false (themes occ-1 :revision revision-2)) + (add-theme occ-1 top-1 :revision revision-3) + (is (= (length (union (list top-1) + (themes occ-1))) 1)) + (is (= (length (slot-value occ-1 'd::themes)) 1)) + (add-theme occ-1 top-2 :revision revision-2) + (is (= (length (union (list top-1 top-2) + (themes occ-1))) 2)) + (is (= (length (union (list top-2) + (themes occ-1 :revision revision-2))) 1)) + (is (= (length (union (list top-1 top-2) + (themes occ-1))) 2)) + (add-theme occ-2 top-2 :revision revision-3) + (is (= (length (union (list top-1 top-2) + (themes occ-1))) 2)) + (is (= (length (union (list top-2) + (themes occ-2))) 1)) + (is (= (length (union (list occ-1) + (used-as-theme top-1))) 1)) + (is (= (length (union (list occ-1 occ-2) + (used-as-theme top-2))) 2)) + (is (= (length (slot-value occ-1 'd::themes)) 2)) + (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))))) @@ -744,4 +795,5 @@ (it.bese.fiveam:run! 'test-VariantC) (it.bese.fiveam:run! 'test-NameC) (it.bese.fiveam:run! 'test-TypableC) + (it.bese.fiveam:run! 'test-ScopableC) ) \ No newline at end of file

1 0

[isidorus-cvs] r213 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 26 Feb '10

26 Feb '10

Author: lgiessmann Date: Fri Feb 26 10:50:44 2010 New Revision: 213 Log: new-datamodel: added some unit-tests for the base class TypableC; optimized the function add-type. 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 Fri Feb 26 10:50:44 2010 @@ -94,6 +94,9 @@ (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 @@ -170,7 +173,7 @@ (defpclass TypableC() - ((instance-of :associate (TypeAssociationC type-topic) + ((instance-of :associate (TypeAssociationC typable-construct) :inherit t :documentation "Contains all association-objects that contain the actual type-topic.")) @@ -1527,6 +1530,7 @@ (map 'list #'player-topic (filter-slot-value-by-revision construct 'player :start-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)) (let ((player-assoc @@ -1763,24 +1767,30 @@ (let ((already-set-type (map 'list #'type-topic (filter-slot-value-by-revision construct 'instance-of - :start-revision revision)))) - (cond ((and already-set-type - (eql (first already-set-type) type-topic)) + :start-revision revision))) + (same-type-assoc + (loop for type-assoc in (slot-p construct 'instance-of) + when (eql (type-topic type-assoc) type-topic) + return type-assoc))) + (when (and already-set-type + (not (eql type-topic already-set-type))) + (error "From add-type(): ~a can't be typed by ~a since it is typed by ~a" + construct type-topic already-set-type)) + (cond (already-set-type (let ((type-assoc (loop for type-assoc in (slot-p construct 'instance-of) when (eql type-topic (type-topic type-assoc)) return type-assoc))) (add-to-version-history type-assoc :start-revision revision))) - ((not already-set-type) + (same-type-assoc + (add-to-version-history same-type-assoc :start-revision revision)) + (t (let ((assoc (make-instance 'TypeAssociationC :type-topic type-topic :typable-construct construct))) - (add-to-version-history assoc :start-revision revision))) - (t - (error "From add-type(): ~a can't be typed by ~a since it is already typed by the topic ~a" - construct type-topic already-set-type))) - construct))) + (add-to-version-history assoc :start-revision revision))))) + construct)) (defgeneric delete-type (construct type-topic &key revision) 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 Fri Feb 26 10:50:44 2010 @@ -30,7 +30,8 @@ :test-ReifiableConstructC :test-OccurrenceC :test-VariantC - :test-NameC)) + :test-NameC + :test-TypableC)) ;;TODO: test delete-construct @@ -689,6 +690,41 @@ (is-false (parent name-2)) (add-parent name-2 top-1 :revision revision-8) (is (eql top-1 (parent name-2)))))) + + +(test test-TypableC () + "Tests various functions of the base class TypableC." + (with-fixture with-empty-db (*db-dir*) + (let ((name-1 (make-instance 'NameC)) + (name-2 (make-instance 'NameC)) + (top-1 (make-instance 'TopicC)) + (top-2 (make-instance 'TopicC)) + (revision-0-5 50) + (revision-1 100) + (revision-2 200) + (revision-3 300)) + (setf *TM-REVISION* revision-1) + (is-false (instance-of name-1)) + (add-type name-1 top-1) + (is (eql top-1 (instance-of name-1))) + (is-false (instance-of name-1 :revision revision-0-5)) + (is (eql top-1 (instance-of name-1 :revision revision-2))) + (signals error (add-type name-1 top-2)) + (add-type name-2 top-1 :revision revision-2) + (is (= (length (union (list name-1 name-2) + (used-as-type top-1))) 2)) + (is (= (length (union (list name-1) + (used-as-type top-1 + :revision revision-1))) 1)) + (delete-type name-1 top-1 :revision revision-3) + (is-false (instance-of name-1)) + (is (= (length (union (list name-2) + (used-as-type top-1))) 1)) + (add-type name-1 top-1 :revision revision-3) + (is (eql top-1 (instance-of name-1))) + (is (= (length (union (list name-1 name-2) + (used-as-type top-1))) 2)) + (is (= (length (slot-value top-1 'd::used-as-type)) 2))))) @@ -707,4 +743,5 @@ (it.bese.fiveam:run! 'test-OccurrenceC) (it.bese.fiveam:run! 'test-VariantC) (it.bese.fiveam:run! 'test-NameC) + (it.bese.fiveam:run! 'test-TypableC) ) \ No newline at end of file

1 0

[isidorus-cvs] r212 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 26 Feb '10

26 Feb '10

Author: lgiessmann Date: Fri Feb 26 03:07:41 2010 New Revision: 212 Log: new-datamodel: added some unit-test for NameC; fixed a bug in delete-name and add-name 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 Fri Feb 26 03:07:41 2010 @@ -948,15 +948,16 @@ an error is thrown.") (:method ((construct TopicC) (name NameC) &key (revision *TM-REVISION*)) - (when (and (parent name) - (not (eql (parent name) construct))) + (when (and (parent name :revision revision) + (not (eql (parent name :revision revision) construct))) (error "From add-name(): ~a can't be owned by ~a since it is already owned by the topic ~a" - name construct (parent name))) + name construct (parent name :revision revision))) (let ((all-names (map 'list #'characteristic (slot-p construct 'names)))) (if (find name all-names) (let ((name-assoc (loop for name-assoc in (slot-p construct 'names) - when (eql (parent-construct name-assoc) name) + when (eql (parent-construct name-assoc) + construct) return name-assoc))) (add-to-version-history name-assoc :start-revision revision)) (let ((assoc @@ -973,7 +974,7 @@ (:method ((construct TopicC) (name NameC) &key (revision (error "From delete-name(): revision must be set"))) (let ((assoc-to-delete (loop for name-assoc in (slot-p construct 'names) - when (eql (parent-construct name-assoc) name) + when (eql (parent-construct name-assoc) construct) return name-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) 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 Fri Feb 26 03:07:41 2010 @@ -29,7 +29,8 @@ :test-get-item-by-psi :test-ReifiableConstructC :test-OccurrenceC - :test-VariantC)) + :test-VariantC + :test-NameC)) ;;TODO: test delete-construct @@ -573,7 +574,7 @@ (test test-VariantC () -"Tests various functions of VariantC." + "Tests various functions of VariantC." (with-fixture with-empty-db (*db-dir*) (let ((v-1 (make-instance 'VariantC)) (v-2 (make-instance 'VariantC)) @@ -618,7 +619,6 @@ (is (eql (parent v-1) name-2)) (is (eql (parent v-1 :revision revision-2) name-1)) (delete-parent v-2 name-1 :revision revision-4) - (format t "-->") (is-false (parent v-2 :revision revision-4)) (is (eql name-1 (parent v-2 :revision revision-3))) (add-parent v-2 name-1 :revision revision-5) @@ -630,6 +630,65 @@ (is-false (parent v-2)) (add-parent v-2 name-1 :revision revision-8) (is (eql name-1 (parent v-2)))))) + + +(test test-NameC () + "Tests various functions of NameC." + (with-fixture with-empty-db (*db-dir*) + (let ((name-1 (make-instance 'NameC)) + (name-2 (make-instance 'NameC)) + (top-1 (make-instance 'TopicC)) + (top-2 (make-instance 'TopicC)) + (revision-1 100) + (revision-2 200) + (revision-3 300) + (revision-4 400) + (revision-5 500) + (revision-6 600) + (revision-7 700) + (revision-8 800)) + (setf *TM-REVISION* revision-1) + (is-false (parent name-1)) + (is-false (names top-1)) + (add-name top-1 name-1 :revision revision-1) + (is (= (length (union (list name-1) + (names top-1))) 1)) + (add-name top-1 name-2 :revision revision-2) + (is (= (length (union (list name-1 name-2) + (names top-1))) 2)) + (is (= (length (union (list name-1) + (names top-1 :revision revision-1))) 1)) + (add-name top-1 name-2 :revision revision-3) + (is (= (length (d::slot-p top-1 'd::names)) 2)) + (delete-name top-1 name-1 :revision revision-4) + (is (= (length (union (list name-2) + (names top-1 :revision revision-4))) 1)) + (is (= (length (union (list name-2) + (names top-1))) 1)) + (is (= (length (union (list name-1 name-2) + (names top-1 :revision revision-2))) 2)) + (add-name top-1 name-1 :revision revision-4) + (is (= (length (union (list name-2 name-1) + (names top-1))) 2)) + (signals error (add-name top-2 name-1 :revision revision-4)) + (delete-name top-1 name-1 :revision revision-5) + (is (= (length (union (list name-2) + (names top-1 :revision revision-5))) 1)) + (add-name top-2 name-1 :revision revision-5) + (is (eql (parent name-1) top-2)) + (is (eql (parent name-1 :revision revision-2) top-1)) + (delete-parent name-2 top-1 :revision revision-4) + (is-false (parent name-2 :revision revision-4)) + (is (eql top-1 (parent name-2 :revision revision-3))) + (add-parent name-2 top-1 :revision revision-5) + (is-false (parent name-2 :revision revision-4)) + (is (eql top-1 (parent name-2))) + (delete-parent name-2 top-1 :revision revision-6) + (add-parent name-2 top-2 :revision revision-7) + (delete-parent name-2 top-2 :revision revision-8) + (is-false (parent name-2)) + (add-parent name-2 top-1 :revision revision-8) + (is (eql top-1 (parent name-2)))))) @@ -647,4 +706,5 @@ (it.bese.fiveam:run! 'test-ReifiableConstructC) (it.bese.fiveam:run! 'test-OccurrenceC) (it.bese.fiveam:run! 'test-VariantC) + (it.bese.fiveam:run! 'test-NameC) ) \ No newline at end of file

1 0

[isidorus-cvs] r211 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 26 Feb '10

26 Feb '10

Author: lgiessmann Date: Fri Feb 26 02:58:57 2010 New Revision: 211 Log: new-datamodel: merged the generic functions delete-parent, so there is only one generic function with the signature ((construct CharacteristicC) (parent-construct ReifiableConstructC) &key (revision (error "From delete-parent(): revision must be set"))); added some unit-tests for the class VariantC 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 Fri Feb 26 02:58:57 2010 @@ -493,7 +493,7 @@ associates characteristics with topics.")) -(defpclass VariantAssociationC(CharateristicAssociationC) +(defpclass VariantAssociationC(CharacteristicAssociationC) ((parent-construct :initarg :parent-construct :accessor parent-construct :initform (error "From VariantAssociationC(): parent-construct must be set") @@ -1187,8 +1187,8 @@ scopable-construct.") (:method ((construct NameC) (variant VariantC) &key (revision *TM-REVISION*)) - (when (and (parent variant) - (not (eql (parent variant) construct))) + (when (and (parent variant :revision revision) + (not (eql (parent variant :revision revision) construct))) (error "From add-variant(): ~a can't be owned by ~a since it is already owned by the name ~a" variant construct (parent variant))) (let ((all-variants @@ -1285,29 +1285,16 @@ (defgeneric delete-parent (construct parent-construct &key revision) (:documentation "Sets the assoication-object between the passed - constructs as marded-as-deleted.")) - - -(defmethod delete-parent ((construct CharacteristicC) (parent-construct TopicC) - &key (revision (error "From delete-parent(): revision must be set"))) - (let ((assoc-to-delete - (loop for parent-assoc in (slot-p construct 'parent) - when (eql (parent-construct parent-assoc) parent-construct) - return parent-assoc))) - (when assoc-to-delete - (mark-as-deleted assoc-to-delete :revision revision)) - construct)) - - -(defmethod delete-parent ((construct CharacteristicC) (parent-construct NameC) - &key (revision (error "From delete-parent(): revision must be set"))) - (let ((assoc-to-delete - (loop for parent-assoc in (slot-p construct 'parent) - when (eql (characteristic parent-assoc) parent-construct) - return parent-assoc))) - (when assoc-to-delete - (mark-as-deleted assoc-to-delete :revision revision)) - construct)) + constructs as marded-as-deleted.") + (:method ((construct CharacteristicC) (parent-construct ReifiableConstructC) + &key (revision (error "From delete-parent(): revision must be set"))) + (let ((assoc-to-delete + (loop for parent-assoc in (slot-p construct 'parent) + when (eql (parent-construct parent-assoc) parent-construct) + return parent-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision)) + construct))) ;;; PlayerAssociationC 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 Fri Feb 26 02:58:57 2010 @@ -518,7 +518,7 @@ (with-fixture with-empty-db (*db-dir*) (let ((occ-1 (make-instance 'OccurrenceC)) (occ-2 (make-instance 'OccurrenceC)) - (top (make-instance 'TopicC)) + (top-1 (make-instance 'TopicC)) (top-2 (make-instance 'TopicC)) (revision-1 100) (revision-2 200) @@ -530,46 +530,46 @@ (revision-8 800)) (setf *TM-REVISION* revision-1) (is-false (parent occ-1)) - (is-false (occurrences top)) - (add-occurrence top occ-1 :revision revision-1) + (is-false (occurrences top-1)) + (add-occurrence top-1 occ-1 :revision revision-1) (is (= (length (union (list occ-1) - (occurrences top))) 1)) - (add-occurrence top occ-2 :revision revision-2) + (occurrences top-1))) 1)) + (add-occurrence top-1 occ-2 :revision revision-2) (is (= (length (union (list occ-1 occ-2) - (occurrences top))) 2)) + (occurrences top-1))) 2)) (is (= (length (union (list occ-1) - (occurrences top :revision revision-1))) 1)) - (add-occurrence top occ-2 :revision revision-3) - (is (= (length (d::slot-p top 'd::occurrences)) 2)) - (delete-occurrence top occ-1 :revision revision-4) + (occurrences top-1 :revision revision-1))) 1)) + (add-occurrence top-1 occ-2 :revision revision-3) + (is (= (length (d::slot-p top-1 'd::occurrences)) 2)) + (delete-occurrence top-1 occ-1 :revision revision-4) (is (= (length (union (list occ-2) - (occurrences top :revision revision-4))) 1)) + (occurrences top-1 :revision revision-4))) 1)) (is (= (length (union (list occ-2) - (occurrences top))) 1)) + (occurrences top-1))) 1)) (is (= (length (union (list occ-1 occ-2) - (occurrences top :revision revision-2))) 2)) - (add-occurrence top occ-1 :revision revision-4) + (occurrences top-1 :revision revision-2))) 2)) + (add-occurrence top-1 occ-1 :revision revision-4) (is (= (length (union (list occ-2 occ-1) - (occurrences top))) 2)) + (occurrences top-1))) 2)) (signals error (add-occurrence top-2 occ-1 :revision revision-4)) - (delete-occurrence top occ-1 :revision revision-5) + (delete-occurrence top-1 occ-1 :revision revision-5) (is (= (length (union (list occ-2) - (occurrences top :revision revision-5))) 1)) + (occurrences top-1 :revision revision-5))) 1)) (add-occurrence top-2 occ-1 :revision revision-5) (is (eql (parent occ-1) top-2)) - (is (eql (parent occ-1 :revision revision-2) top)) - (delete-parent occ-2 top :revision revision-4) + (is (eql (parent occ-1 :revision revision-2) top-1)) + (delete-parent occ-2 top-1 :revision revision-4) (is-false (parent occ-2 :revision revision-4)) - (is (eql top (parent occ-2 :revision revision-3))) - (add-parent occ-2 top :revision revision-5) + (is (eql top-1 (parent occ-2 :revision revision-3))) + (add-parent occ-2 top-1 :revision revision-5) (is-false (parent occ-2 :revision revision-4)) - (is (eql top (parent occ-2))) - (delete-parent occ-2 top :revision revision-6) + (is (eql top-1 (parent occ-2))) + (delete-parent occ-2 top-1 :revision revision-6) (add-parent occ-2 top-2 :revision revision-7) (delete-parent occ-2 top-2 :revision revision-8) (is-false (parent occ-2)) - (add-parent occ-2 top :revision revision-8) - (is (eql top (parent occ-2)))))) + (add-parent occ-2 top-1 :revision revision-8) + (is (eql top-1 (parent occ-2)))))) (test test-VariantC () @@ -577,14 +577,59 @@ (with-fixture with-empty-db (*db-dir*) (let ((v-1 (make-instance 'VariantC)) (v-2 (make-instance 'VariantC)) - (name (make-instance 'NameC)) + (name-1 (make-instance 'NameC)) + (name-2 (make-instance 'NameC)) (revision-1 100) (revision-2 200) (revision-3 300) - (revision-4 400)) + (revision-4 400) + (revision-5 500) + (revision-6 600) + (revision-7 700) + (revision-8 800)) (setf *TM-REVISION* revision-1) - - ))) + (is-false (parent v-1)) + (is-false (variants name-1)) + (add-variant name-1 v-1 :revision revision-1) + (is (= (length (union (list v-1) + (variants name-1))) 1)) + (add-variant name-1 v-2 :revision revision-2) + (is (= (length (union (list v-1 v-2) + (variants name-1))) 2)) + (is (= (length (union (list v-1) + (variants name-1 :revision revision-1))) 1)) + (add-variant name-1 v-2 :revision revision-3) + (is (= (length (d::slot-p name-1 'd::variants)) 2)) + (delete-variant name-1 v-1 :revision revision-4) + (is (= (length (union (list v-2) + (variants name-1 :revision revision-4))) 1)) + (is (= (length (union (list v-2) + (variants name-1))) 1)) + (is (= (length (union (list v-1 v-2) + (variants name-1 :revision revision-2))) 2)) + (add-variant name-1 v-1 :revision revision-4) + (is (= (length (union (list v-2 v-1) + (variants name-1))) 2)) + (signals error (add-variant name-2 v-1 :revision revision-4)) + (delete-variant name-1 v-1 :revision revision-5) + (is (= (length (union (list v-2) + (variants name-1 :revision revision-5))) 1)) + (add-variant name-2 v-1 :revision revision-5) + (is (eql (parent v-1) name-2)) + (is (eql (parent v-1 :revision revision-2) name-1)) + (delete-parent v-2 name-1 :revision revision-4) + (format t "-->") + (is-false (parent v-2 :revision revision-4)) + (is (eql name-1 (parent v-2 :revision revision-3))) + (add-parent v-2 name-1 :revision revision-5) + (is-false (parent v-2 :revision revision-4)) + (is (eql name-1 (parent v-2))) + (delete-parent v-2 name-1 :revision revision-6) + (add-parent v-2 name-2 :revision revision-7) + (delete-parent v-2 name-2 :revision revision-8) + (is-false (parent v-2)) + (add-parent v-2 name-1 :revision revision-8) + (is (eql name-1 (parent v-2))))))

1 0

[isidorus-cvs] r210 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 26 Feb '10

26 Feb '10

Author: lgiessmann Date: Fri Feb 26 02:14:11 2010 New Revision: 210 Log: new-datamodel: merged the generic functions add-parent, so there is only one for the parents TopicC and NameC; added some unit-tests for add-parent, delete-parent and parent 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 Fri Feb 26 02:14:11 2010 @@ -331,7 +331,7 @@ ;;; characteristics ... (defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC) - ((parent :associate (CharacteriticAssociationC characteristic) + ((parent :associate (CharacteristicAssociationC characteristic) :inherit t :documentation "Assocates the characterist obejct with the parent-association.") @@ -948,13 +948,12 @@ an error is thrown.") (:method ((construct TopicC) (name NameC) &key (revision *TM-REVISION*)) - (when (not (eql (parent name) construct)) + (when (and (parent name) + (not (eql (parent name) construct))) (error "From add-name(): ~a can't be owned by ~a since it is already owned by the topic ~a" name construct (parent name))) (let ((all-names - (map 'list #'characteristic - (remove-if #'marked-as-deleted-p - (slot-p construct 'names))))) + (map 'list #'characteristic (slot-p construct 'names)))) (if (find name all-names) (let ((name-assoc (loop for name-assoc in (slot-p construct 'names) when (eql (parent-construct name-assoc) name) @@ -998,14 +997,12 @@ an error is thrown.") (:method ((construct TopicC) (occurrence OccurrenceC) &key (revision *TM-REVISION*)) - (when (and (parent occurrence) + (when (and (parent occurrence :revision revision) (not (eql (parent occurrence) construct))) (error "From add-occurrence(): ~a can't be owned by ~a since it is already owned by the topic ~a" occurrence construct (parent occurrence))) (let ((all-occurrences - (map 'list #'characteristic - (remove-if #'marked-as-deleted-p - (slot-p construct 'occurrences))))) + (map 'list #'characteristic (slot-p construct 'occurrences)))) (if (find occurrence all-occurrences) (let ((occ-assoc (loop for occ-assoc in (slot-p construct 'occurrences) when (eql (parent-construct occ-assoc) construct) @@ -1190,13 +1187,12 @@ scopable-construct.") (:method ((construct NameC) (variant VariantC) &key (revision *TM-REVISION*)) - (when (not (eql (parent variant) construct)) + (when (and (parent variant) + (not (eql (parent variant) construct))) (error "From add-variant(): ~a can't be owned by ~a since it is already owned by the name ~a" variant construct (parent variant))) (let ((all-variants - (map 'list #'characteristic - (remove-if #'marked-as-deleted-p - (slot-p construct 'variants))))) + (map 'list #'characteristic (slot-p construct 'variants)))) (if (find variant all-variants) (let ((variant-assoc (loop for variant-assoc in (slot-p construct 'variants) @@ -1252,60 +1248,39 @@ (defgeneric add-parent (construct parent-construct &key revision) (:documentation "Adds the parent-construct (TopicC or NameC) in form of - a corresponding association to the given object.")) - - -(defmethod add-parent ((construct CharacteristicC) (parent-construct TopicC) - &key (revision *TM-REVISION*)) - (let ((already-set-topic - (map 'list #'parent-construct - (filter-slot-value-by-revision construct 'parent - :start-revision revision)))) - (cond ((and already-set-topic - (eql (first already-set-topic) 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-topic) - (let ((assoc - (make-instance (if (typep construct 'OccurrenceC) - 'OccurrenceAssociationC - 'NameAssociationC) - :parent-construct parent-construct - :characteristic construct))) - (add-to-version-history assoc :start-revision revision))) - (t - (error "From add-parent(): ~a can't be owned by ~a since it is already owned by the topic ~a" - construct parent-construct already-set-topic))) - construct)) - - -(defmethod add-parent ((construct CharacteristicC) (parent-construct NameC) - &key (revision *TM-REVISION*)) - (let ((already-set-name - (map 'list #'characteristic - (filter-slot-value-by-revision construct 'parent - :start-revision revision)))) - (cond ((and already-set-name - (eql (first already-set-name) parent-construct)) + a corresponding association to the given object.") + (:method ((construct CharacteristicC) (parent-construct ReifiableConstructC) + &key (revision *TM-REVISION*)) + (let ((already-set-parent (parent construct :revision revision)) + (same-parent-assoc ;should contain a object that was marked as deleted + (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 (characteristic parent-assoc)) + when (eql parent-construct + (parent-construct parent-assoc)) return parent-assoc))) (add-to-version-history parent-assoc :start-revision revision))) - ((not already-set-name) - (let ((assoc - (make-instance 'VariantAssociationC - :parent-construct parent-construct - :characteristic construct))) - (add-to-version-history assoc :start-revision revision))) + (same-parent-assoc + (add-to-version-history same-parent-assoc :start-revision revision)) (t - (error "From add-parent(): ~a can't be owned by ~a since it is already owned by the topic ~a" - construct parent-construct already-set-name))) - construct)) + (let ((association-type (cond ((typep construct 'OccurrenceC) + 'OccurrenceAssociationC) + ((typep construct 'NameC) + 'NameAssociationC) + (t + 'VariantAssociationC)))) + (let ((assoc (make-instance association-type + :characteristic construct + :parent-construct parent-construct))) + (add-to-version-history assoc :start-revision revision)))))) + construct)) (defgeneric delete-parent (construct parent-construct &key revision) 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 Fri Feb 26 02:14:11 2010 @@ -28,7 +28,8 @@ :test-get-item-by-locator :test-get-item-by-psi :test-ReifiableConstructC - :test-OccurrenceC)) + :test-OccurrenceC + :test-VariantC)) ;;TODO: test delete-construct @@ -518,10 +519,15 @@ (let ((occ-1 (make-instance 'OccurrenceC)) (occ-2 (make-instance 'OccurrenceC)) (top (make-instance 'TopicC)) + (top-2 (make-instance 'TopicC)) (revision-1 100) (revision-2 200) (revision-3 300) - (revision-4 400)) + (revision-4 400) + (revision-5 500) + (revision-6 600) + (revision-7 700) + (revision-8 800)) (setf *TM-REVISION* revision-1) (is-false (parent occ-1)) (is-false (occurrences top)) @@ -544,7 +550,42 @@ (occurrences top :revision revision-2))) 2)) (add-occurrence top occ-1 :revision revision-4) (is (= (length (union (list occ-2 occ-1) - (occurrences top))) 2))))) + (occurrences top))) 2)) + (signals error (add-occurrence top-2 occ-1 :revision revision-4)) + (delete-occurrence top occ-1 :revision revision-5) + (is (= (length (union (list occ-2) + (occurrences top :revision revision-5))) 1)) + (add-occurrence top-2 occ-1 :revision revision-5) + (is (eql (parent occ-1) top-2)) + (is (eql (parent occ-1 :revision revision-2) top)) + (delete-parent occ-2 top :revision revision-4) + (is-false (parent occ-2 :revision revision-4)) + (is (eql top (parent occ-2 :revision revision-3))) + (add-parent occ-2 top :revision revision-5) + (is-false (parent occ-2 :revision revision-4)) + (is (eql top (parent occ-2))) + (delete-parent occ-2 top :revision revision-6) + (add-parent occ-2 top-2 :revision revision-7) + (delete-parent occ-2 top-2 :revision revision-8) + (is-false (parent occ-2)) + (add-parent occ-2 top :revision revision-8) + (is (eql top (parent occ-2)))))) + + +(test test-VariantC () +"Tests various functions of VariantC." + (with-fixture with-empty-db (*db-dir*) + (let ((v-1 (make-instance 'VariantC)) + (v-2 (make-instance 'VariantC)) + (name (make-instance 'NameC)) + (revision-1 100) + (revision-2 200) + (revision-3 300) + (revision-4 400)) + (setf *TM-REVISION* revision-1) + + ))) + (defun run-datamodel-tests() @@ -560,4 +601,5 @@ (it.bese.fiveam:run! 'test-get-item-by-psi) (it.bese.fiveam:run! 'test-ReifiableConstructC) (it.bese.fiveam:run! 'test-OccurrenceC) + (it.bese.fiveam:run! 'test-VariantC) ) \ No newline at end of file

1 0

[isidorus-cvs] r209 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 25 Feb '10

25 Feb '10

Author: lgiessmann Date: Thu Feb 25 16:36:10 2010 New Revision: 209 Log: new-datamodel: added some unit-tests for add-occurrence, delete-occurrence, occurrences; fixed some bugs in these funtions 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 Thu Feb 25 16:36:10 2010 @@ -486,7 +486,7 @@ :accessor characteristic :inherit t :initform (error "From CharacteristicCAssociation(): characteristic must be set") - :associate CharactersiticC + :associate CharacteristicC :documentation "Associates this object with the actual characteristic object.")) (:documentation "An abstract base class for all association-objects that @@ -986,7 +986,7 @@ with the passed construct and the passed version.") (:method ((construct TopicC) &key (revision 0)) (let ((assocs (filter-slot-value-by-revision - construct 'occurences :start-revision revision))) + construct 'occurrences :start-revision revision))) (map 'list #'characteristic assocs)))) @@ -998,7 +998,8 @@ an error is thrown.") (:method ((construct TopicC) (occurrence OccurrenceC) &key (revision *TM-REVISION*)) - (when (not (eql (parent occurrence) construct)) + (when (and (parent occurrence) + (not (eql (parent occurrence) construct))) (error "From add-occurrence(): ~a can't be owned by ~a since it is already owned by the topic ~a" occurrence construct (parent occurrence))) (let ((all-occurrences @@ -1007,7 +1008,7 @@ (slot-p construct 'occurrences))))) (if (find occurrence all-occurrences) (let ((occ-assoc (loop for occ-assoc in (slot-p construct 'occurrences) - when (eql (parent-construct occ-assoc) occurrence) + when (eql (parent-construct occ-assoc) construct) return occ-assoc))) (add-to-version-history occ-assoc :start-revision revision)) (let ((assoc @@ -1024,7 +1025,7 @@ (:method ((construct TopicC) (occurrence OccurrenceC) &key (revision (error "From delete-occurrence(): revision must be set"))) (let ((assoc-to-delete (loop for occ-assoc in (slot-p construct 'occurrences) - when (eql (parent-construct occ-assoc) occurrence) + when (eql (parent-construct occ-assoc) construct) return occ-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) 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 Thu Feb 25 16:36:10 2010 @@ -27,14 +27,13 @@ :test-get-item-by-item-identifier :test-get-item-by-locator :test-get-item-by-psi - :test-ReifiableConstructC)) + :test-ReifiableConstructC + :test-OccurrenceC)) ;;TODO: test delete-construct -;;TODO: test merge-constructs when merging was caused by an item-dentifier -;;TODO: test merge-constructs when merging was caused by an psi -;;TODO: test merge-constructs when merging was caused by an subject-locator -;;TODO: test merge-constructs when merging was caused by a topic-id +;;TODO: test merge-constructs when merging was caused by an item-dentifier, +;; a psi, a subject-locator, a topic-id ;;TODO: test merge-constructs when merging was caused by reifiers ;; (occurrences, names, variants, associations, roles) ;;TODO: test ReifiableConstructC --> reifier has to be merged @@ -513,6 +512,41 @@ (is-false (reified-construct reifier-top :revision 50))))) +(test test-OccurrenceC () + "Tests various functions of OccurrenceC." + (with-fixture with-empty-db (*db-dir*) + (let ((occ-1 (make-instance 'OccurrenceC)) + (occ-2 (make-instance 'OccurrenceC)) + (top (make-instance 'TopicC)) + (revision-1 100) + (revision-2 200) + (revision-3 300) + (revision-4 400)) + (setf *TM-REVISION* revision-1) + (is-false (parent occ-1)) + (is-false (occurrences top)) + (add-occurrence top occ-1 :revision revision-1) + (is (= (length (union (list occ-1) + (occurrences top))) 1)) + (add-occurrence top occ-2 :revision revision-2) + (is (= (length (union (list occ-1 occ-2) + (occurrences top))) 2)) + (is (= (length (union (list occ-1) + (occurrences top :revision revision-1))) 1)) + (add-occurrence top occ-2 :revision revision-3) + (is (= (length (d::slot-p top 'd::occurrences)) 2)) + (delete-occurrence top occ-1 :revision revision-4) + (is (= (length (union (list occ-2) + (occurrences top :revision revision-4))) 1)) + (is (= (length (union (list occ-2) + (occurrences top))) 1)) + (is (= (length (union (list occ-1 occ-2) + (occurrences top :revision revision-2))) 2)) + (add-occurrence top occ-1 :revision revision-4) + (is (= (length (union (list occ-2 occ-1) + (occurrences top))) 2))))) + + (defun run-datamodel-tests() (it.bese.fiveam:run! 'test-VersionInfoC) (it.bese.fiveam:run! 'test-VersionedConstructC) @@ -525,4 +559,5 @@ (it.bese.fiveam:run! 'test-get-item-by-locator) (it.bese.fiveam:run! 'test-get-item-by-psi) (it.bese.fiveam:run! 'test-ReifiableConstructC) + (it.bese.fiveam:run! 'test-OccurrenceC) ) \ No newline at end of file

1 0

[isidorus-cvs] r208 - branches/new-datamodel/src/rest_interface trunk/src/rest_interface
by Lukas Giessmann 25 Feb '10

25 Feb '10

Author: lgiessmann Date: Thu Feb 25 15:45:39 2010 New Revision: 208 Log: rest-interface: fixed a bug in the restful-handler return-overview that caused a memory-leak Modified: branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp trunk/src/rest_interface/set-up-json-interface.lisp Modified: branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp ============================================================================== --- branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp (original) +++ branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp Thu Feb 25 15:45:39 2010 @@ -331,15 +331,15 @@ (defun return-overview (&optional param) "Returns a json-object representing a topic map overview as a tree(s)" (declare (ignorable param)) - (handler-case (let ((json-string - (with-reader-lock - (json-tmcl::tree-view-to-json-string (json-tmcl::make-tree-view))))) - (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 - json-string) - (Condition (err) (progn - (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) - (setf (hunchentoot:content-type*) "text") - (format nil "Condition: \"~a\"" err))))) + (with-reader-lock + (handler-case (let ((json-string + (json-tmcl::tree-view-to-json-string (json-tmcl::make-tree-view)))) + (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 + json-string) + (Condition (err) (progn + (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) + (setf (hunchentoot:content-type*) "text") + (format nil "Condition: \"~a\"" err)))))) ;; ============================================================================= @@ -385,4 +385,4 @@ (setf ret-str (concatenate 'string ret-str (subseq str idx (1+ idx)))) (incf idx))) (unless (< idx (length str)) - (return ret-str))))))) \ No newline at end of file + (return ret-str))))))) Modified: trunk/src/rest_interface/set-up-json-interface.lisp ============================================================================== --- trunk/src/rest_interface/set-up-json-interface.lisp (original) +++ trunk/src/rest_interface/set-up-json-interface.lisp Thu Feb 25 15:45:39 2010 @@ -331,15 +331,15 @@ (defun return-overview (&optional param) "Returns a json-object representing a topic map overview as a tree(s)" (declare (ignorable param)) - (handler-case (let ((json-string - (with-reader-lock - (json-tmcl::tree-view-to-json-string (json-tmcl::make-tree-view))))) - (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 - json-string) - (Condition (err) (progn - (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) - (setf (hunchentoot:content-type*) "text") - (format nil "Condition: \"~a\"" err))))) + (with-reader-lock + (handler-case (let ((json-string + (json-tmcl::tree-view-to-json-string (json-tmcl::make-tree-view)))) + (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 + json-string) + (Condition (err) (progn + (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) + (setf (hunchentoot:content-type*) "text") + (format nil "Condition: \"~a\"" err)))))) ;; =============================================================================

1 0