isidorus-cvs

isidorus-cvs@common-lisp.net

1037 discussions

[isidorus-cvs] r224 - branches/new-datamodel/playground
by Lukas Giessmann 13 Mar '10

13 Mar '10

Author: lgiessmann Date: Sat Mar 13 16:09:24 2010 New Revision: 224 Log: new-datamodel: added a new sample file for call-next-mehtod in a multiple-inheritance scenario Added: branches/new-datamodel/playground/call-next-method_multiple-inheritance.lisp Added: branches/new-datamodel/playground/call-next-method_multiple-inheritance.lisp ============================================================================== --- (empty file) +++ branches/new-datamodel/playground/call-next-method_multiple-inheritance.lisp Sat Mar 13 16:09:24 2010 @@ -0,0 +1,31 @@ +(defclass CharacteristicC() + ((value :accessor value + :initarg :value + :type string))) + +(defclass DatatypableC() + ((datatype :accessor datatype + :initarg :datatype + :type string))) + +(defclass OccurrenceC (CharacteristicC DatatypableC) + ()) + +(defgeneric equivalent-construct (construct &rest args)) + +(defmethod equivalent-construct ((construct OccurrenceC) &rest args) + (format t "equivalent-construct --> OccurrenceC: ~a~%" args) + (call-next-method construct args)) + +(defmethod equivalent-construct ((construct CharacteristicC) &rest args) + (format t "equivalent-construct --> CharacteristicC: ~a~%" args) + (call-next-method construct (first args)) + (string= (value construct) (getf (first args) :value))) + +(defmethod equivalent-construct ((construct DatatypableC) &rest args) + (format t "equivalent-construct --> DatatypableC: ~a~%" args) + (string= (datatype construct) (getf (first args) :datatype))) + +(defvar *occ* (make-instance 'Occurrencec :value "value" :datatype "datatype")) + +(equivalent-construct *occ* :value "value" :datatype "datatype")

1 0

[isidorus-cvs] r223 - branches/new-datamodel/playground
by Lukas Giessmann 10 Mar '10

10 Mar '10

Author: lgiessmann Date: Wed Mar 10 11:59:11 2010 New Revision: 223 Log: new-datamodel: added a sample file that handles "call-next-method" and the auxiliary methods (":before", "after" and "around") Added: branches/new-datamodel/playground/call-next-method.lisp Added: branches/new-datamodel/playground/call-next-method.lisp ============================================================================== --- (empty file) +++ branches/new-datamodel/playground/call-next-method.lisp Wed Mar 10 11:59:11 2010 @@ -0,0 +1,44 @@ +(defclass Class-1 () + ((value :initarg :value + :accessor value))) + +(defmethod set-value :before ((inst Class-1) value) + (format t ":before -> value is of type ~a~%" (type-of value))) + +(defmethod set-value ((inst Class-1) value) + (format t ": -> value is being set to ~a~%" value) + (setf (slot-value inst 'value) value)) + +(defmethod set-value :after ((inst Class-1) value) + (format t ":after -> value was set to ~a~%" value)) + +(defmethod set-value :around ((inst Class-1) value) + (format t ":around -> ???~%") + (call-next-method inst "123")) ;calls the :before method with the + ;arguments inst and "123" + ;if no arguments are passed the arguments + ;of the :around method are passed + +(defvar *inst* (make-instance 'Class-1)) +(set-value *inst* "val") +;:around -> ??? +;:before -> value is of type (SIMPLE-ARRAY CHARACTER (3)) +;: -> value is being set to 123 +;:after -> value was set to 123 + + +(defclass Class-2 (Class-1) + ()) + +(defmethod set-value ((inst Class-2) value) + (call-next-method) ;calls set-value of Class-1 + (format t "(Class-2): -> value is being set to ~a~%" value) + (setf (slot-value inst 'value) value)) + +(defvar *inst2* (make-instance 'Class-2)) +(set-value *inst2* "val2") +;:around -> ??? +;:before -> value is of type (SIMPLE-ARRAY CHARACTER (3)) +;: -> value is being set to 123 +;(Class-2): -> value is being set to 123 +;:after -> value was set to 123 \ No newline at end of file

1 0

[isidorus-cvs] r222 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 10 Mar '10

10 Mar '10

Author: lgiessmann Date: Wed Mar 10 08:59:47 2010 New Revision: 222 Log: new-datamodel: fixed a bug in "delete-construct"; finalized the unit-tests for "delete-construct" 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 Wed Mar 10 08:59:47 2010 @@ -597,18 +597,7 @@ (defmethod delete-construct :after ((construct elephant:persistent)) - "Removes the passed object from the data base when it is not - referenced by a parent TM construct. - So pointers, characteristics, topics, roles and associations - can be only dropped when there are not owned by a parent." - (if (or (typep construct 'PointerC) - (typep construct 'CharacteristicC) - (typep construct 'TopicC) - (typep construct 'RoleC) - (typep construct 'AssociationC)) - (unless (owned-p construct) - (drop-instance construct)) - (drop-instance construct))) + (drop-instance construct)) (defun filter-slot-value-by-revision (construct slot-symbol @@ -835,7 +824,7 @@ ;;; CharacteristicAssociationC (defmethod delete-construct :before ((construct CharacteristicAssociationC)) - (delete-1-n-association construct 'charactersitic)) + (delete-1-n-association construct 'characteristic)) ;;; OccurrenceAssociationC @@ -867,30 +856,40 @@ ;;; TopicC (defmethod delete-construct :before ((construct TopicC)) - (let ((psis-to-delete - (map 'list #'identifier (slot-p construct 'psis))) - (sls-to-delete - (map 'list #'identifier (slot-p construct 'locators))) - (names-to-delete - (map 'list #'characteristic (slot-p construct 'names))) - (occurrences-to-delete (slot-p construct 'occurrences)) - (roles-to-delete - (map 'list #'parent-construct (slot-p construct 'player-in-roles))) - (typables-to-delete - (map 'list #'typable-construct (slot-p construct 'used-as-type))) + (let ((psi-assocs-to-delete (slot-p construct 'psis)) + (sl-assocs-to-delete (slot-p construct 'locators)) + (name-assocs-to-delete (slot-p construct 'names)) + (occ-assocs-to-delete (slot-p construct 'occurrences)) + (role-assocs-to-delete (slot-p construct 'player-in-roles)) + (type-assocs-to-delete (slot-p construct 'used-as-type)) + (scope-assocs-to-delete (slot-p construct 'used-as-theme)) (reifier-assocs-to-delete (slot-p construct 'reified-construct))) - (dolist (construct-to-delete (append psis-to-delete - sls-to-delete - names-to-delete - occurrences-to-delete - roles-to-delete - typables-to-delete - reifier-assocs-to-delete)) - (delete-construct construct-to-delete))) - (dolist (scope-assoc-to-delete (slot-p construct 'used-as-theme)) - (delete-construct scope-assoc-to-delete)) - (dolist (tm (slot-p construct 'in-topicmaps)) - (remove-association construct 'in-topicmaps tm))) + (let ((all-psis (map 'list #'identifier psi-assocs-to-delete)) + (all-sls (map 'list #'identifier sl-assocs-to-delete)) + (all-names (map 'list #'characteristic name-assocs-to-delete)) + (all-occs (map 'list #'characteristic occ-assocs-to-delete)) + (all-roles (map 'list #'parent-construct role-assocs-to-delete)) + (all-types (map 'list #'typable-construct type-assocs-to-delete))) + (dolist (construct-to-delete (append psi-assocs-to-delete + sl-assocs-to-delete + name-assocs-to-delete + occ-assocs-to-delete + role-assocs-to-delete + type-assocs-to-delete + scope-assocs-to-delete + reifier-assocs-to-delete)) + (delete-construct construct-to-delete)) + (dolist (candidate-to-delete (append all-psis all-sls all-names all-occs)) + (unless (owned-p candidate-to-delete) + (delete-construct candidate-to-delete))) + (dolist (candidate-to-delete all-roles) + (unless (player-p candidate-to-delete) + (delete-construct candidate-to-delete))) + (dolist (candidate-to-delete all-types) + (unless (instance-of-p candidate-to-delete) + (delete-construct candidate-to-delete))) + (dolist (tm (slot-p construct 'in-topicmaps)) + (remove-association construct 'in-topicmaps tm))))) (defmethod owned-p ((construct TopicC)) @@ -1101,7 +1100,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) construct) + when (eql (characteristic name-assoc) name) return name-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) @@ -1150,7 +1149,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) construct) + when (eql (characteristic occ-assoc) occurrence) return occ-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) @@ -1301,10 +1300,13 @@ ;;; NameC (defmethod delete-construct :before ((construct NameC)) - (dolist (variant-to-delete - (map 'list #'characteristic - (slot-p construct 'variants))) - (delete-construct variant-to-delete))) + (let ((variant-assocs-to-delete (slot-p construct 'variants))) + (let ((all-variants (map 'list #'characteristic variant-assocs-to-delete))) + (dolist (variant-assoc-to-delete variant-assocs-to-delete) + (delete-construct variant-assoc-to-delete)) + (dolist (candidate-to-delete all-variants) + (unless (owned-p candidate-to-delete) + (delete-construct candidate-to-delete)))))) (defgeneric variants (construct &key revision) @@ -1432,11 +1434,15 @@ ;;; AssociationC (defmethod delete-construct :before ((construct AssociationC)) - (dolist (role-to-delete - (map 'list #'role (slot-p construct 'roles))) - (delete-construct role-to-delete)) - (dolist (tm (slot-p construct 'in-topicmaps)) - (remove-association construct 'in-topicmaps tm))) + (let ((roles-assocs-to-delete (slot-p construct 'roles))) + (let ((all-roles (map 'list #'role roles-assocs-to-delete))) + (dolist (role-assoc-to-delete roles-assocs-to-delete) + (delete-construct role-assoc-to-delete)) + (dolist (candidate-to-delete all-roles) + (unless (owned-p candidate-to-delete) + (delete-construct candidate-to-delete))) + (dolist (tm (slot-p construct 'in-topicmaps)) + (remove-association construct 'in-topicmaps tm))))) (defmethod owned-p ((construct AssociationC)) @@ -1499,6 +1505,14 @@ (delete-construct player-assoc-to-delete))) +(defgeneric player-p (construct) + (:documentation "Returns t if a player is set in this role. + t is also returned if the player is markes-as-deleted.") + (:method ((construct RoleC)) + (when (slot-p construct 'player) + t))) + + (defmethod owned-p ((construct RoleC)) (when (slot-p construct 'parent) t)) @@ -1573,7 +1587,7 @@ 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" + (error "From add-player(): ~a can't be played by ~a since it is played by ~a" construct player-topic already-set-player)) (cond (already-set-player (let ((player-assoc @@ -1598,7 +1612,7 @@ &key (revision (error "From delete-parent(): revision must be set"))) (let ((assoc-to-delete (loop for player-assoc in (slot-p construct 'player) - when (eql (player-topic player-assoc) player-topic) + when (eql (parent-construct player-assoc) construct) return player-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) @@ -1607,12 +1621,15 @@ ;;; ReifiableConstructC (defmethod delete-construct :before ((construct ReifiableConstructC)) - (let ((iis-to-delete - (map 'list #'identifier (slot-p construct 'item-identifiers))) - (reifier-tops-to-delete - (map 'list #'reifier-topic (slot-p construct 'reifier)))) - (dolist (construct-to-delete (append iis-to-delete reifier-tops-to-delete)) - (delete-construct construct-to-delete)))) + (let ((ii-assocs-to-delete (slot-p construct 'item-identifiers)) + (reifier-assocs-to-delete (slot-p construct 'reifier))) + (let ((all-iis (map 'list #'identifier ii-assocs-to-delete))) + (dolist (construct-to-delete (append ii-assocs-to-delete + reifier-assocs-to-delete)) + (delete-construct construct-to-delete)) + (dolist (ii all-iis) + (unless (owned-p ii) + (delete-construct ii)))))) (defgeneric item-identifiers (construct &key revision) @@ -1784,6 +1801,15 @@ (dolist (type-assoc-to-delete (slot-p construct 'instance-of)) (delete-construct type-assoc-to-delete))) + +(defgeneric instance-of-p (construct) + (:documentation "Returns t if there is any type set in this object. + t is also returned if the type is marked-as-deleted.") + (:method ((construct TypableC)) + (when (slot-p construct 'instance-of) + t))) + + (defgeneric instance-of (construct &key revision) (:documentation "Returns the type topic that is set on the passed 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 Wed Mar 10 08:59:47 2010 @@ -39,10 +39,17 @@ :test-TopicMapC :test-delete-ItemIdentifierC :test-delete-PersistentIdC - :test-delete-SubjectLocatorC)) + :test-delete-SubjectLocatorC + :test-delete-ReifiableConstructC + :test-delete-VariantC + :test-delete-NameC + :test-delete-OccurrenceC + :test-delete-TypableC + :test-delete-ScopableC + :test-delete-AssociationC + :test-delete-RoleC)) -;;TODO: test delete-construct ;;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 @@ -957,9 +964,15 @@ (add-item-identifier name-2 ii-4 :revision revision-2) (is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC)) 2)) - (delete-construct ii-4) - (is-false (elephant:get-instances-by-class 'ItemIdentifierC)) - (is-false (elephant:get-instances-by-class 'd::ItemIdAssociationC))))) + (delete-construct occ-2) + (is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC)) + 1)) + (is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 1)) + (is (= (length (union (list ii-4) (item-identifiers name-2))) 1)) + (delete-construct name-2) + (is-false (elephant:get-instances-by-class 'd::ItemIdAssociationC)) + (is-false (elephant:get-instances-by-class 'ItemIdentifierC))))) + (test test-delete-PersistentIdC () @@ -999,9 +1012,12 @@ (add-psi topic-4 psi-4 :revision revision-2) (is (= (length (elephant:get-instances-by-class 'd::PersistentIdAssociationC)) 2)) - (delete-construct psi-4) - (is-false (elephant:get-instances-by-class 'PersistentIdC)) - (is-false (elephant:get-instances-by-class 'd::PersistentIdAssociationC))))) + (is (= (length (elephant:get-instances-by-class 'PersistentIdC)) 1)) + (delete-construct topic-2) + (is (= (length (elephant:get-instances-by-class 'd::PersistentIdAssociationC)) + 1)) + (is (= (length (elephant:get-instances-by-class 'PersistentIdC)) 1)) + (is (= (length (union (list psi-4) (psis topic-4))) 1))))) (test test-delete-SubjectLocatorC () @@ -1041,10 +1057,284 @@ (add-locator topic-4 sl-4 :revision revision-2) (is (= (length (elephant:get-instances-by-class 'd::SubjectLocatorAssociationC)) 2)) - (delete-construct sl-4) - (is-false (elephant:get-instances-by-class 'SubjectLocatorC)) - (is-false (elephant:get-instances-by-class 'd::SubjectLocatorAssociationC))))) - + (is (= (length (elephant:get-instances-by-class 'SubjectLocatorC)) 1)) + (delete-construct topic-2) + (is (= (length (elephant:get-instances-by-class 'd::SubjectLocatorAssociationC)) + 1)) + (is (= (length (elephant:get-instances-by-class 'SubjectLocatorC)) 1)) + (is (= (length (union (list sl-4) (locators topic-4))) 1))))) + + + +(test test-delete-ReifiableConstructC () + "Tests the function delete-construct of the class ReifiableConstructC" + (with-fixture with-empty-db (*db-dir*) + (let ((rc-1 (make-instance 'd::ReifiableConstructC)) + (rc-2 (make-instance 'd::ReifiableConstructC)) + (reifier-1 (make-instance 'TopicC)) + (reifier-2 (make-instance 'TopicC)) + (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) + (revision-1 100) + (revision-2 200)) + (setf *TM-REVISION* revision-1) + (add-reifier rc-1 reifier-1) + (add-item-identifier rc-1 ii-1) + (is (= (length (elephant:get-instances-by-class 'd::ReifiableConstructC)) + 2)) + (is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC)) + 1)) + (is (= (length (elephant:get-instances-by-class 'd::ReifierAssociationC)) + 1)) + (delete-reifier rc-1 reifier-1 :revision revision-2) + (delete-item-identifier rc-1 ii-1 :revision revision-2) + (add-reifier rc-2 reifier-1 :revision revision-2) + (add-item-identifier rc-2 ii-1 :revision revision-2) + (is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC)) + 2)) + (is (= (length (elephant:get-instances-by-class 'd::ReifierAssociationC)) + 2)) + (delete-construct rc-1) + (is (= (length (elephant:get-instances-by-class 'd::ReifiableConstructC)) + 1)) + (is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC)) + 1)) + (is (= (length (elephant:get-instances-by-class 'd::ReifierAssociationC)) + 1)) + (is (= (length (union (list ii-1) (item-identifiers rc-2))) 1)) + (is (eql reifier-1 (reifier rc-2))) + (delete-construct ii-1) + (delete-construct reifier-1) + (is (= (length (elephant:get-instances-by-class 'd::ReifiableConstructC)) + 1)) + (is-false (elephant:get-instances-by-class 'd::ItemIdAssociationC)) + (is-false (elephant:get-instances-by-class 'd::ReifierAssociationC)) + (delete-construct reifier-2) + (is-false (elephant:get-instances-by-class 'd::ReifierAssociationC))))) + + +(test test-delete-VariantC () + "Tests the function delete-construct of the class VariantC" + (with-fixture with-empty-db (*db-dir*) + (let ((name-1 (make-instance 'NameC)) + (name-2 (make-instance 'NameC)) + (variant-1 (make-instance 'VariantC)) + (variant-2 (make-instance 'VariantC)) + (variant-3 (make-instance 'VariantC)) + (variant-4 (make-instance 'VariantC)) + (revision-1 100) + (revision-2 200)) + (setf *TM-REVISION* revision-1) + (add-variant name-1 variant-1) + (add-variant name-1 variant-2) + (add-variant name-1 variant-3) + (delete-variant name-1 variant-1 :revision revision-2) + (delete-variant name-1 variant-2 :revision revision-2) + (add-variant name-2 variant-1 :revision revision-2) + (add-variant name-2 variant-2 :revision revision-2) + (is (= (length (elephant:get-instances-by-class 'd::VariantAssociationC)) + 5)) + (delete-construct variant-1) + (is (= (length (elephant:get-instances-by-class 'd::VariantAssociationC)) + 3)) + (is (= (length (elephant:get-instances-by-class 'VariantC)) 3)) + (delete-construct name-1) + (is (= (length (elephant:get-instances-by-class 'd::VariantAssociationC)) + 1)) + (is (= (length (elephant:get-instances-by-class 'VariantC)) 2)) + (delete-construct name-2) + (is (= (length (elephant:get-instances-by-class 'VariantC)) 1)) + (is-false (elephant:get-instances-by-class 'd::VariantAssociationC)) + (delete-construct variant-4) + (is-false (elephant:get-instances-by-class 'VariantC))))) + + +(test test-delete-NameC () + "Tests the function delete-construct of the class NameC" + (with-fixture with-empty-db (*db-dir*) + (let ((topic-1 (make-instance 'TopicC)) + (topic-2 (make-instance 'TopicC)) + (name-1 (make-instance 'NameC)) + (name-2 (make-instance 'NameC)) + (name-3 (make-instance 'NameC)) + (name-4 (make-instance 'NameC)) + (revision-1 100) + (revision-2 200)) + (setf *TM-REVISION* revision-1) + (add-name topic-1 name-1) + (add-name topic-1 name-2) + (add-name topic-1 name-3) + (delete-name topic-1 name-1 :revision revision-2) + (delete-name topic-1 name-2 :revision revision-2) + (add-name topic-2 name-1 :revision revision-2) + (add-name topic-2 name-2 :revision revision-2) + (is (= (length (elephant:get-instances-by-class 'd::NameAssociationC)) + 5)) + (delete-construct name-1) + (is (= (length (elephant:get-instances-by-class 'd::NameAssociationC)) + 3)) + (is (= (length (elephant:get-instances-by-class 'NameC)) 3)) + (delete-construct topic-1) + (is (= (length (elephant:get-instances-by-class 'd::NameAssociationC)) + 1)) + (is (= (length (elephant:get-instances-by-class 'NameC)) 2)) + (delete-construct topic-2) + (is (= (length (elephant:get-instances-by-class 'NameC)) 1)) + (is-false (elephant:get-instances-by-class 'd::NameAssociationC)) + (delete-construct name-4) + (is-false (elephant:get-instances-by-class 'NameC))))) + + +(test test-delete-OccurrenceC () + "Tests the function delete-construct of the class OccurrenceC" + (with-fixture with-empty-db (*db-dir*) + (let ((topic-1 (make-instance 'TopicC)) + (topic-2 (make-instance 'TopicC)) + (occurrence-1 (make-instance 'OccurrenceC)) + (occurrence-2 (make-instance 'OccurrenceC)) + (occurrence-3 (make-instance 'OccurrenceC)) + (occurrence-4 (make-instance 'OccurrenceC)) + (revision-1 100) + (revision-2 200)) + (setf *TM-REVISION* revision-1) + (add-occurrence topic-1 occurrence-1) + (add-occurrence topic-1 occurrence-2) + (add-occurrence topic-1 occurrence-3) + (delete-occurrence topic-1 occurrence-1 :revision revision-2) + (delete-occurrence topic-1 occurrence-2 :revision revision-2) + (add-occurrence topic-2 occurrence-1 :revision revision-2) + (add-occurrence topic-2 occurrence-2 :revision revision-2) + (is (= (length (elephant:get-instances-by-class + 'd::OccurrenceAssociationC)) 5)) + (delete-construct occurrence-1) + (is (= (length (elephant:get-instances-by-class + 'd::OccurrenceAssociationC)) 3)) + (is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 3)) + (delete-construct topic-1) + (is (= (length (elephant:get-instances-by-class + 'd::OccurrenceAssociationC)) 1)) + (is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 2)) + (delete-construct topic-2) + (is (= (length (elephant:get-instances-by-class 'OccurrenceC)) 1)) + (is-false (elephant:get-instances-by-class 'd::OccurrenceAssociationC)) + (delete-construct occurrence-4) + (is-false (elephant:get-instances-by-class 'OccurrenceC))))) + + +(test test-delete-TypableC () + "Tests the function delete-construct of the class TypableC" + (with-fixture with-empty-db (*db-dir*) + (let ((name-1 (make-instance 'NameC)) + (name-2 (make-instance 'NameC)) + (type-1 (make-instance 'TopicC)) + (type-2 (make-instance 'TopicC)) + (revision-1 100) + (revision-2 200)) + (setf *TM-REVISION* revision-1) + (add-type name-1 type-1) + (delete-type name-1 type-1 :revision revision-2) + (add-type name-1 type-2 :revision revision-2) + (add-type name-2 type-2) + (is (= (length (elephant:get-instances-by-class 'd::TypeAssociationC)) 3)) + (is (= (length (elephant:get-instances-by-class 'd::NameC)) 2)) + (delete-construct type-2) + (is (= (length (elephant:get-instances-by-class 'd::TypeAssociationC)) 1)) + (is (= (length (elephant:get-instances-by-class 'd::NameC)) 1)) + (delete-construct name-1) + (is-false (elephant:get-instances-by-class 'd::TypeAssociationC)) + (is-false (elephant:get-instances-by-class 'd::NameC))))) + + +(test test-delete-ScopableC () + "Tests the function delete-construct of the class ScopableC" + (with-fixture with-empty-db (*db-dir*) + (let ((assoc-1 (make-instance 'AssociationC)) + (assoc-2 (make-instance 'AssociationC)) + (assoc-3 (make-instance 'AssociationC)) + (scope-1 (make-instance 'TopicC)) + (scope-2 (make-instance 'TopicC)) + (scope-3 (make-instance 'TopicC)) + (revision-1 100)) + (setf *TM-REVISION* revision-1) + (add-theme assoc-1 scope-1) + (add-theme assoc-1 scope-2) + (add-theme assoc-2 scope-1) + (is (= (length (elephant:get-instances-by-class 'd::ScopeAssociationC)) + 3)) + (is (= (length (elephant:get-instances-by-class 'AssociationC)) 3)) + (delete-construct scope-1) + (is (= (length (elephant:get-instances-by-class 'd::ScopeAssociationC)) + 1)) + (is (= (length (elephant:get-instances-by-class 'AssociationC)) 3)) + (delete-construct assoc-1) + (is-false (elephant:get-instances-by-class 'd::ScopeAssociationC)) + (is (= (length (elephant:get-instances-by-class 'AssociationC)) 2)) + (add-theme assoc-2 scope-3) + (add-theme assoc-3 scope-3) + (is (= (length (elephant:get-instances-by-class 'd::ScopeAssociationC)) + 2)) + (is (= (length (elephant:get-instances-by-class 'AssociationC)) 2)) + (delete-construct assoc-2) + (is (= (length (union (list scope-3) (themes assoc-3))) 1))))) + + +(test test-delete-AssociationC () + "Tests the function delete-construct of the class AssociationC" + (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)) + (assoc-3 (make-instance 'AssociationC)) + (revision-1 100) + (revision-2 200)) + (setf *TM-REVISION* revision-1) + (add-role assoc-1 role-1) + (delete-role assoc-1 role-1 :revision revision-2) + (add-role assoc-2 role-1 :revision revision-2) + (add-role assoc-2 role-2) + (is (= (length (elephant:get-instances-by-class 'RoleC)) 2)) + (is (= (length (elephant:get-instances-by-class 'AssociationC)) 3)) + (is (= (length (elephant:get-instances-by-class 'd::RoleAssociationC)) 3)) + (delete-construct role-1) + (is (= (length (elephant:get-instances-by-class 'RoleC)) 1)) + (is (= (length (elephant:get-instances-by-class 'AssociationC)) 3)) + (is (= (length (elephant:get-instances-by-class 'd::RoleAssociationC)) 1)) + (delete-role assoc-2 role-2 :revision revision-2) + (add-role assoc-3 role-2 :revision revision-2) + (is (= (length (elephant:get-instances-by-class 'RoleC)) 1)) + (is (= (length (elephant:get-instances-by-class 'AssociationC)) 3)) + (is (= (length (elephant:get-instances-by-class 'd::RoleAssociationC)) 2)) + (delete-construct assoc-3) + (is (= (length (elephant:get-instances-by-class 'RoleC)) 1)) + (is (= (length (elephant:get-instances-by-class 'AssociationC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd::RoleAssociationC)) + 1))))) + + +(test test-delete-RoleC () + "Tests the function delete-construct of the class RoleC" + (with-fixture with-empty-db (*db-dir*) + (let ((role-1 (make-instance 'RoleC)) + (role-2 (make-instance 'RoleC)) + (player-1 (make-instance 'TopicC)) + (player-2 (make-instance 'TopicC)) + (revision-1 100) + (revision-2 200)) + (setf *TM-REVISION* revision-1) + (add-player role-1 player-1) + (delete-player role-1 player-1 :revision revision-2) + (add-player role-1 player-2 :revision revision-2) + (add-player role-2 player-1) + (is (= (length (elephant:get-instances-by-class 'RoleC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd::PlayerAssociationC)) + 3)) + (delete-construct player-1) + (is (= (length (elephant:get-instances-by-class 'RoleC)) 1)) + (is (= (length (elephant:get-instances-by-class 'd::PlayerAssociationC)) + 1)) + (delete-construct role-1) + (is-false (elephant:get-instances-by-class 'RoleC)) + (is-false (elephant:get-instances-by-class 'd::PlayerAssociationC))))) (defun run-datamodel-tests() @@ -1071,4 +1361,12 @@ (it.bese.fiveam:run! 'test-delete-ItemIdentifierC) (it.bese.fiveam:run! 'test-delete-PersistentIdC) (it.bese.fiveam:run! 'test-delete-SubjectLocatorC) + (it.bese.fiveam:run! 'test-delete-ReifiableConstructC) + (it.bese.fiveam:run! 'test-delete-VariantC) + (it.bese.fiveam:run! 'test-delete-NameC) + (it.bese.fiveam:run! 'test-delete-OccurrenceC) + (it.bese.fiveam:run! 'test-delete-TypableC) + (it.bese.fiveam:run! 'test-delete-ScopableC) + (it.bese.fiveam:run! 'test-delete-AssociationC) + (it.bese.fiveam:run! 'test-delete-RoleC) ) \ No newline at end of file

1 0

[isidorus-cvs] r221 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 09 Mar '10

09 Mar '10

Author: lgiessmann Date: Tue Mar 9 12:52:12 2010 New Revision: 221 Log: new-datamodel: fixed a bug in delete-construct (TopicC) and added some unit-tests for delete-construct (PersistentIdC, SubjectLocatorS, ItemIdentifierC) 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 Mar 9 12:52:12 2010 @@ -870,7 +870,7 @@ (let ((psis-to-delete (map 'list #'identifier (slot-p construct 'psis))) (sls-to-delete - (map 'list #'identifier (slot-p construct 'psis))) + (map 'list #'identifier (slot-p construct 'locators))) (names-to-delete (map 'list #'characteristic (slot-p construct 'names))) (occurrences-to-delete (slot-p construct 'occurrences)) 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 Mar 9 12:52:12 2010 @@ -37,7 +37,9 @@ :test-RoleC :test-player :test-TopicMapC - :test-delete-ItemIdentifierC)) + :test-delete-ItemIdentifierC + :test-delete-PersistentIdC + :test-delete-SubjectLocatorC)) ;;TODO: test delete-construct @@ -924,8 +926,11 @@ (let ((ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2")) (ii-3 (make-instance 'ItemIdentifierC :uri "ii-3")) + (ii-4 (make-instance 'ItemIdentifierC :uri "ii-4")) (occ-1 (make-instance 'OccurrenceC)) + (occ-2 (make-instance 'OccurrenceC)) (name-1 (make-instance 'NameC)) + (name-2 (make-instance 'NameC)) (revision-1 100) (revision-2 200)) (setf *TM-REVISION* 100) @@ -935,16 +940,110 @@ (add-item-identifier name-1 ii-1 :revision revision-2) (is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC)) 3)) - (is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 3)) + (is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 4)) (delete-construct ii-3) - (is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 2)) + (is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 3)) (is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC)) 3)) (delete-construct ii-1) - ;(is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 1)) - ;(is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC)) - ; 2)) - ))) + (is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC)) + 1)) + (delete-construct occ-1) + (is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 1)) + (is-false (elephant:get-instances-by-class 'd::ItemIdAssociationC)) + (add-item-identifier occ-2 ii-4 :revision revision-1) + (delete-item-identifier occ-2 ii-4 :revision revision-2) + (add-item-identifier name-2 ii-4 :revision revision-2) + (is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC)) + 2)) + (delete-construct ii-4) + (is-false (elephant:get-instances-by-class 'ItemIdentifierC)) + (is-false (elephant:get-instances-by-class 'd::ItemIdAssociationC))))) + + +(test test-delete-PersistentIdC () + "Tests the function delete-construct of the class PersistentIdC." + (with-fixture with-empty-db (*db-dir*) + (let ((psi-1 (make-instance 'PersistentIdC :uri "psi-1")) + (psi-2 (make-instance 'PersistentIdC :uri "psi-2")) + (psi-3 (make-instance 'PersistentIdC :uri "psi-3")) + (psi-4 (make-instance 'PersistentIdC :uri "psi-4")) + (topic-1 (make-instance 'TopicC)) + (topic-2 (make-instance 'TopicC)) + (topic-3 (make-instance 'TopicC)) + (topic-4 (make-instance 'TopicC)) + (revision-1 100) + (revision-2 200)) + (setf *TM-REVISION* 100) + (add-psi topic-1 psi-1 :revision revision-1) + (add-psi topic-1 psi-2 :revision revision-2) + (delete-psi topic-1 psi-1 :revision revision-2) + (add-psi topic-3 psi-1 :revision revision-2) + (is (= (length (elephant:get-instances-by-class 'd::PersistentIdAssociationC)) + 3)) + (is (= (length (elephant:get-instances-by-class 'PersistentIdC)) 4)) + (delete-construct psi-3) + (is (= (length (elephant:get-instances-by-class 'PersistentIdC)) 3)) + (is (= (length (elephant:get-instances-by-class 'd::PersistentIdAssociationC)) + 3)) + (delete-construct psi-1) + (is (= (length (elephant:get-instances-by-class 'PersistentIdC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd::PersistentIdAssociationC)) + 1)) + (delete-construct topic-1) + (is (= (length (elephant:get-instances-by-class 'PersistentIdC)) 1)) + (is-false (elephant:get-instances-by-class 'd::PersistentIdAssociationC)) + (add-psi topic-2 psi-4 :revision revision-1) + (delete-psi topic-2 psi-4 :revision revision-2) + (add-psi topic-4 psi-4 :revision revision-2) + (is (= (length (elephant:get-instances-by-class 'd::PersistentIdAssociationC)) + 2)) + (delete-construct psi-4) + (is-false (elephant:get-instances-by-class 'PersistentIdC)) + (is-false (elephant:get-instances-by-class 'd::PersistentIdAssociationC))))) + + +(test test-delete-SubjectLocatorC () + "Tests the function delete-construct of the class SubjectLocatorC." + (with-fixture with-empty-db (*db-dir*) + (let ((sl-1 (make-instance 'SubjectLocatorC :uri "sl-1")) + (sl-2 (make-instance 'SubjectLocatorC :uri "sl-2")) + (sl-3 (make-instance 'SubjectLocatorC :uri "sl-3")) + (sl-4 (make-instance 'SubjectLocatorC :uri "sl-4")) + (topic-1 (make-instance 'TopicC)) + (topic-2 (make-instance 'TopicC)) + (topic-3 (make-instance 'TopicC)) + (topic-4 (make-instance 'TopicC)) + (revision-1 100) + (revision-2 200)) + (setf *TM-REVISION* 100) + (add-locator topic-1 sl-1 :revision revision-1) + (add-locator topic-1 sl-2 :revision revision-2) + (delete-locator topic-1 sl-1 :revision revision-2) + (add-locator topic-3 sl-1 :revision revision-2) + (is (= (length (elephant:get-instances-by-class 'd::SubjectLocatorAssociationC)) + 3)) + (is (= (length (elephant:get-instances-by-class 'SubjectLocatorC)) 4)) + (delete-construct sl-3) + (is (= (length (elephant:get-instances-by-class 'SubjectLocatorC)) 3)) + (is (= (length (elephant:get-instances-by-class 'd::SubjectLocatorAssociationC)) + 3)) + (delete-construct sl-1) + (is (= (length (elephant:get-instances-by-class 'SubjectLocatorC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd::SubjectLocatorAssociationC)) + 1)) + (delete-construct topic-1) + (is (= (length (elephant:get-instances-by-class 'SubjectLocatorC)) 1)) + (is-false (elephant:get-instances-by-class 'd::SubjectLocatorAssociationC)) + (add-locator topic-2 sl-4 :revision revision-1) + (delete-locator topic-2 sl-4 :revision revision-2) + (add-locator topic-4 sl-4 :revision revision-2) + (is (= (length (elephant:get-instances-by-class 'd::SubjectLocatorAssociationC)) + 2)) + (delete-construct sl-4) + (is-false (elephant:get-instances-by-class 'SubjectLocatorC)) + (is-false (elephant:get-instances-by-class 'd::SubjectLocatorAssociationC))))) @@ -970,4 +1069,6 @@ (it.bese.fiveam:run! 'test-player) (it.bese.fiveam:run! 'test-TopicMapC) (it.bese.fiveam:run! 'test-delete-ItemIdentifierC) + (it.bese.fiveam:run! 'test-delete-PersistentIdC) + (it.bese.fiveam:run! 'test-delete-SubjectLocatorC) ) \ No newline at end of file

1 0

[isidorus-cvs] r220 - branches/new-datamodel/src/model
by Lukas Giessmann 09 Mar '10

09 Mar '10

Author: lgiessmann Date: Tue Mar 9 12:24:52 2010 New Revision: 220 Log: new-datamodel: finalized "delete-construct" Modified: branches/new-datamodel/src/model/datamodel.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 Mar 9 12:24:52 2010 @@ -853,6 +853,18 @@ (delete-1-n-association construct 'parent-construct)) +;;; RoleAssociationC +(defmethod delete-construct :before ((construct RoleAssociationC)) + (delete-1-n-association construct 'role) + (delete-1-n-association construct 'parent-construct)) + + +;;; PlayerAssociationC +(defmethod delete-construct :before ((construct PlayerAssociationC)) + (delete-1-n-association construct 'player-topic) + (delete-1-n-association construct 'parent-construct)) + + ;;; TopicC (defmethod delete-construct :before ((construct TopicC)) (let ((psis-to-delete @@ -862,7 +874,8 @@ (names-to-delete (map 'list #'characteristic (slot-p construct 'names))) (occurrences-to-delete (slot-p construct 'occurrences)) - ;TODO: roles -> associations? + (roles-to-delete + (map 'list #'parent-construct (slot-p construct 'player-in-roles))) (typables-to-delete (map 'list #'typable-construct (slot-p construct 'used-as-type))) (reifier-assocs-to-delete (slot-p construct 'reified-construct))) @@ -870,6 +883,7 @@ sls-to-delete names-to-delete occurrences-to-delete + roles-to-delete typables-to-delete reifier-assocs-to-delete)) (delete-construct construct-to-delete))) @@ -1417,6 +1431,14 @@ ;;; AssociationC +(defmethod delete-construct :before ((construct AssociationC)) + (dolist (role-to-delete + (map 'list #'role (slot-p construct 'roles))) + (delete-construct role-to-delete)) + (dolist (tm (slot-p construct 'in-topicmaps)) + (remove-association construct 'in-topicmaps tm))) + + (defmethod owned-p ((construct AssociationC)) (when (slot-p construct 'in-topicmaps) t)) @@ -1470,6 +1492,13 @@ ;;; RoleC +(defmethod delete-construct :before ((construct RoleC)) + (dolist (role-assoc-to-delete (slot-p construct 'parent)) + (delete-construct role-assoc-to-delete)) + (dolist (player-assoc-to-delete (slot-p construct 'player)) + (delete-construct player-assoc-to-delete))) + + (defmethod owned-p ((construct RoleC)) (when (slot-p construct 'parent) t))

1 0

[isidorus-cvs] r219 - branches/new-datamodel/src/model
by Lukas Giessmann 09 Mar '10

09 Mar '10

Author: lgiessmann Date: Tue Mar 9 06:11:24 2010 New Revision: 219 Log: new-datamodel: added delete-construct to TopicC, NameC, OccurrenceC, PersistentIdC, ItemIdentifierC, ReifiableConstructC, SubjectLocatorC, VariantC and all their version-associations Modified: branches/new-datamodel/src/model/datamodel.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 Mar 9 06:11:24 2010 @@ -763,6 +763,11 @@ ;;; PointerC +(defmethod delete-construct :before ((construct PointerC)) + (dolist (p-assoc (slot-p construct 'identified-construct)) + (delete-construct p-assoc))) + + (defgeneric owned-p (construct) (:documentation "Returns t if the passed construct is referenced by a parent TM construct.")) @@ -785,7 +790,95 @@ (first assocs))))) +;;; PointerAssociationC +(defmethod delete-construct :before ((construct PointerAssociationC)) + (delete-1-n-association construct 'identifier)) + + +;;; ItemIdAssociationC +(defmethod delete-construct :before ((construct ItemIdAssociationC)) + (delete-1-n-association construct 'parent-construct)) + + +;;; TopicIdAssociationC +(defmethod delete-construct :before ((construct TopicIdAssociationC)) + (delete-1-n-association construct 'parent-construct)) + + +;;; PersistentIdAssociationC +(defmethod delete-construct :before ((construct PersistentIdAssociationC)) + (delete-1-n-association construct 'parent-construct)) + + +;;; SubjectLocatorAssociationC +(defmethod delete-construct :before ((construct SubjectLocatorAssociationC)) + (delete-1-n-association construct 'parent-construct)) + + +;;; ReifierAssociationC +(defmethod delete-construct :before ((construct ReifierAssociationC)) + (delete-1-n-association construct 'reifiable-construct) + (delete-1-n-association construct 'reifier-topic)) + + +;;; TypeAssociationC +(defmethod delete-construct :before ((construct TypeAssociationC)) + (delete-1-n-association construct 'type-topic) + (delete-1-n-association construct 'typable-construct)) + + +;;; ScopeAssociationC +(defmethod delete-construct :before ((construct ScopeAssociationC)) + (delete-1-n-association construct 'theme-topic) + (delete-1-n-association construct 'scopable-construct)) + + +;;; CharacteristicAssociationC +(defmethod delete-construct :before ((construct CharacteristicAssociationC)) + (delete-1-n-association construct 'charactersitic)) + + +;;; OccurrenceAssociationC +(defmethod delete-construct :before ((construct OccurrenceAssociationC)) + (delete-1-n-association construct 'parent-construct)) + + +;;; NameAssociationC +(defmethod delete-construct :before ((construct NameAssociationC)) + (delete-1-n-association construct 'parent-construct)) + + +;;; VariantAssociationC +(defmethod delete-construct :before ((construct VariantAssociationC)) + (delete-1-n-association construct 'parent-construct)) + + ;;; TopicC +(defmethod delete-construct :before ((construct TopicC)) + (let ((psis-to-delete + (map 'list #'identifier (slot-p construct 'psis))) + (sls-to-delete + (map 'list #'identifier (slot-p construct 'psis))) + (names-to-delete + (map 'list #'characteristic (slot-p construct 'names))) + (occurrences-to-delete (slot-p construct 'occurrences)) + ;TODO: roles -> associations? + (typables-to-delete + (map 'list #'typable-construct (slot-p construct 'used-as-type))) + (reifier-assocs-to-delete (slot-p construct 'reified-construct))) + (dolist (construct-to-delete (append psis-to-delete + sls-to-delete + names-to-delete + occurrences-to-delete + typables-to-delete + reifier-assocs-to-delete)) + (delete-construct construct-to-delete))) + (dolist (scope-assoc-to-delete (slot-p construct 'used-as-theme)) + (delete-construct scope-assoc-to-delete)) + (dolist (tm (slot-p construct 'in-topicmaps)) + (remove-association construct 'in-topicmaps tm))) + + (defmethod owned-p ((construct TopicC)) (when (slot-p construct 'in-topicmaps) t)) @@ -1193,6 +1286,13 @@ ;;; NameC +(defmethod delete-construct :before ((construct NameC)) + (dolist (variant-to-delete + (map 'list #'characteristic + (slot-p construct 'variants))) + (delete-construct variant-to-delete))) + + (defgeneric variants (construct &key revision) (:documentation "Returns all variants that correspond with the given revision and that are associated with the passed construct.") @@ -1243,6 +1343,11 @@ ;;; CharacteristicC +(defmethod delete-construct :before ((construct CharacteristicC)) + (dolist (characteristic-assoc-to-delete (slot-p construct 'parent)) + (delete-construct characteristic-assoc-to-delete))) + + (defmethod owned-p ((construct CharacteristicC)) (when (slot-p construct 'parent) t)) @@ -1472,6 +1577,15 @@ ;;; ReifiableConstructC +(defmethod delete-construct :before ((construct ReifiableConstructC)) + (let ((iis-to-delete + (map 'list #'identifier (slot-p construct 'item-identifiers))) + (reifier-tops-to-delete + (map 'list #'reifier-topic (slot-p construct 'reifier)))) + (dolist (construct-to-delete (append iis-to-delete reifier-tops-to-delete)) + (delete-construct construct-to-delete)))) + + (defgeneric item-identifiers (construct &key revision) (:documentation "Returns the ItemIdentifierC-objects that correspond with the passed construct and the passed version.") @@ -1587,6 +1701,11 @@ ;;; ScopableC +(defmethod delete-construct :before ((construct ScopableC)) + (dolist (scope-assoc-to-delete (slot-p construct 'themes)) + (delete-construct scope-assoc-to-delete))) + + (defgeneric themes (construct &key revision) (:documentation "Returns all topics that correspond with the given revision as a scope for the given topic.") @@ -1632,6 +1751,10 @@ ;;; TypableC +(defmethod delete-construct :before ((construct TypableC)) + (dolist (type-assoc-to-delete (slot-p construct 'instance-of)) + (delete-construct type-assoc-to-delete))) + (defgeneric instance-of (construct &key revision) (:documentation "Returns the type topic that is set on the passed revision.") @@ -1690,6 +1813,13 @@ ;;; TopicMapC +(defmethod delete-construct :before ((construct TopicMapC)) + (dolist (top (slot-p construct 'topics)) + (remove-association construct 'topics top)) + (dolist (assoc (slot-p construct 'associations)) + (remove-association construct 'associations assoc))) + + (defgeneric topics (construct &key revision) (:documentation "Returns all TopicC-objects that are contained in the tm.") (:method ((construct TopicMapC) &key (revision 0))

1 0

[isidorus-cvs] r218 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 07 Mar '10

07 Mar '10

Author: lgiessmann Date: Sun Mar 7 15:15:38 2010 New Revision: 218 Log: new-datamodel: added the generic "owned-p" and started to optimize the "delete-construct" mechanism. 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 Sun Mar 7 15:15:38 2010 @@ -97,6 +97,7 @@ (in-package :datamodel) +;;TODO: implement delete-construct ;;TODO: finalize add-reifier ;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo ;; initarg in make-construct @@ -573,7 +574,7 @@ (when value value)) ;elephant-relations are handled separately, since slot-boundp does not - ;here + ;work here (handler-case (let ((value (slot-value instance slot-symbol))) (when value value)) @@ -596,7 +597,18 @@ (defmethod delete-construct :after ((construct elephant:persistent)) - (drop-instance construct)) + "Removes the passed object from the data base when it is not + referenced by a parent TM construct. + So pointers, characteristics, topics, roles and associations + can be only dropped when there are not owned by a parent." + (if (or (typep construct 'PointerC) + (typep construct 'CharacteristicC) + (typep construct 'TopicC) + (typep construct 'RoleC) + (typep construct 'AssociationC)) + (unless (owned-p construct) + (drop-instance construct)) + (drop-instance construct))) (defun filter-slot-value-by-revision (construct slot-symbol @@ -751,6 +763,16 @@ ;;; PointerC +(defgeneric owned-p (construct) + (:documentation "Returns t if the passed construct is referenced by a parent + TM construct.")) + + +(defmethod owned-p ((construct PointerC)) + (when (slot-p construct 'identified-construct) + t)) + + (defgeneric identified-construct (construct &key revision) (:documentation "Returns the identified-construct -> ReifiableConstructC or TopicC that corresponds with the passed revision.") @@ -764,20 +786,9 @@ ;;; TopicC -(defmethod delete-construct :before ((construct TopicC)) - "Deletes all association objects of the passed construct." - (dolist (assoc (append (slot-p construct 'topic-identifiers) - (slot-p construct 'psis) - (slot-p construct 'locators) - (slot-p construct 'names) - (slot-p construct 'occurrences) - (slot-p construct 'player-in-roles) - (slot-p construct 'used-as-type) - (slot-p construct 'used-as-theme) - (slot-p construct 'reified-construct))) - (delete-construct assoc)) - (dolist (assoc (slot-p construct 'in-topicmaps)) - (remove-association construct 'in-topicmaps assoc))) +(defmethod owned-p ((construct TopicC)) + (when (slot-p construct 'in-topicmaps) + t)) (defgeneric topic-identifiers (construct &key revision) @@ -1232,16 +1243,9 @@ ;;; CharacteristicC -(defmethod delete-construct :before ((construct CharacteristicC)) - "Deletes all association-obejcts." - (dolist (parent-assoc (slot-p construct 'parent)) - (delete-construct parent-assoc))) - - -(defmethod delete-construct :before ((construct NameC)) - "Deletes all association-obejcts." - (dolist (variant-assoc (slot-p construct 'variants)) - (delete-construct variant-assoc))) +(defmethod owned-p ((construct CharacteristicC)) + (when (slot-p construct 'parent) + t)) (defgeneric parent (construct &key revision) @@ -1307,112 +1311,10 @@ construct))) -;;; PlayerAssociationC -(defmethod delete-construct :before ((construct PlayerAssociationC)) - "Deletes all elephant-associations." - (delete-1-n-association construct 'player-topic) - (delete-1-n-association construct 'parent-construct)) - - -;;; RoleAssociationC -(defmethod delete-construct :before ((construct RoleAssociationC)) - "Deletes all elephant-associations and the entire role if it is not - associated with another AssociationC object." - (let ((role (role construct))) - (delete-1-n-association construct 'role) - (when (not (slot-p role 'parent)) - (delete-construct role)) - (delete-1-n-association construct 'parent-construct))) - - -;;; VariantAssociationC -(defmethod delete-construct :before ((construct VariantAssociationC)) - (delete-1-n-association construct 'parent-construct)) - - -;;; NameAssociationC -(defmethod delete-construct :before ((construct NameAssociationC)) - (delete-1-n-association construct 'parent-construct)) - - -;;; OccurrenceAssociationC -(defmethod delete-construct :before ((construct OccurrenceAssociationC)) - (delete-1-n-association construct 'parent-construct)) - - -;;; CharacteristicAssociationC -(defmethod delete-construct :before ((construct CharacteristicAssociationC)) - "Deletes all elephant-associations." - (let ((characteristic (characteristic construct))) - (delete-1-n-association construct 'characteristic) - (when (and characteristic - (not (slot-p characteristic 'parent))) - (delete-construct characteristic)))) - - -;;; TypeAssociationC -(defmethod delete-construct :before ((construct TypeAssociationC)) - "Deletes all elephant-associations of the given construct." - (delete-1-n-association construct 'type-topic) - (delete-1-n-association construct 'typable-construct)) - - -;;; ScopeAssociationC -(defmethod delete-construct :before ((construct ScopeAssociationC)) - "Deletes all elephant-associations of this construct." - (delete-1-n-association construct 'theme-topic) - (delete-1-n-association construct 'scopable-topic)) - - -;;; ReifierAssociationC -(defmethod delete-construct :before ((construct ReifierAssociationC)) - "Deletes the association-construct and the reifier-topic when it - is not used as a reifier of another construct." - (delete-1-n-association construct 'reifiable-construct) - (let ((reifier-top (slot-p construct 'reifier-topic))) - (delete-1-n-association construct 'reifier-topic) - (when (= (length (slot-p reifier-top 'reified-construct)) 0) - (delete-construct reifier-top)))) - - -;;; SubjectLocatorAssociationC -(defmethod delete-construct :before ((construct SubjectLocatorAssociationC)) - (delete-1-n-association construct 'parent-construct)) - - -;;; PersistentIdAssociationC -(defmethod delete-construct :before ((construct PersistentIdAssociationC)) - (delete-1-n-association construct 'parent-construct)) - - -;;; TopicIdAssociationC -(defmethod delete-construct :before ((construct TopicIdAssociationC)) - (delete-1-n-association construct 'parent-construct)) - - -;;; ItemIdAssociationC -(defmethod delete-construct :before ((construct ItemIdAssociationC)) - (delete-1-n-association construct 'parent-construct)) - - -;;; PointerAssociationC -(defmethod delete-construct :before ((construct PointerAssociationC)) - "Deletes the association-construct and the pointer if it is not used - as an idengtiffier of any other object." - (let ((id (slot-p construct 'identifier))) - (delete-1-n-association construct 'identifier) - (when (= (length (slot-p id 'identified-construct)) 0) - (delete-construct id)))) - - ;;; AssociationC -(defmethod delete-construct :before ((construct AssociationC)) - "Removes all elephant-associations and deleted all roles that are not - associated by another associations." - (dolist (assoc (slot-p construct 'roles)) - (delete-construct assoc)) - (dolist (tm (in-topicmaps construct)) - (remove-association construct 'in-topicmaps tm))) +(defmethod owned-p ((construct AssociationC)) + (when (slot-p construct 'in-topicmaps) + t)) (defgeneric roles (construct &key revision) @@ -1463,12 +1365,9 @@ ;;; RoleC -(defmethod delete-construct :before ((construct RoleC)) - "Deletes all association-objects." - (dolist (assoc (slot-p construct 'parent)) - (delete-construct assoc)) - (dolist (assoc (slot-p construct 'player)) - (delete-construct assoc))) +(defmethod owned-p ((construct RoleC)) + (when (slot-p construct 'parent) + t)) (defmethod parent ((construct RoleC) &key (revision 0)) @@ -1592,16 +1491,6 @@ (reifier-topic (first assocs)))))) -(defmethod delete-construct :before ((construct ReifiableConstructC)) - "Deletes the passed construct its item-identifiers and its - reifiers. An item-identifier and a reifeir is only deleted - when these constructs are not referenced by other parent-objects." - (dolist (item-identifier (slot-p construct 'item-identifiers)) - (delete-construct item-identifier)) - (dolist (reifier-top (slot-p construct 'reifier)) - (delete-construct reifier-top))) - - (defgeneric add-item-identifier (construct item-identifier &key revision) (:documentation "Adds the passed item-identifier to the passed construct. If the item-identifier is already related with the passed @@ -1698,12 +1587,6 @@ ;;; ScopableC -(defmethod delete-construct :before ((construct ScopableC)) - "Deletes all ScopeAssociationCs that are associated with the given object." - (dolist (theme (slot-p construct 'themes)) - (delete-construct theme))) - - (defgeneric themes (construct &key revision) (:documentation "Returns all topics that correspond with the given revision as a scope for the given topic.") @@ -1749,12 +1632,6 @@ ;;; TypableC -(defmethod delete-construct :before ((construct TypableC)) - "Deletes all TypeAssociationCs that are associated with this object." - (dolist (type (slot-p construct 'instance-of)) - (delete-construct type))) - - (defgeneric instance-of (construct &key revision) (:documentation "Returns the type topic that is set on the passed 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 Sun Mar 7 15:15:38 2010 @@ -36,7 +36,8 @@ :test-ScopableC :test-RoleC :test-player - :test-TopicMapC)) + :test-TopicMapC + :test-delete-ItemIdentifierC)) ;;TODO: test delete-construct @@ -915,6 +916,35 @@ (in-topicmaps assoc-1))) 2)) (is-false (associations tm-2 :revision revision-0-5)) (is-false (in-topicmaps assoc-1 :revision revision-0-5))))) + + +(test test-delete-ItemIdentifierC () + "Tests the function delete-construct of the class ItemIdentifierC." + (with-fixture with-empty-db (*db-dir*) + (let ((ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2")) + (ii-3 (make-instance 'ItemIdentifierC :uri "ii-3")) + (occ-1 (make-instance 'OccurrenceC)) + (name-1 (make-instance 'NameC)) + (revision-1 100) + (revision-2 200)) + (setf *TM-REVISION* 100) + (add-item-identifier occ-1 ii-1 :revision revision-1) + (add-item-identifier occ-1 ii-2 :revision revision-2) + (delete-item-identifier occ-1 ii-1 :revision revision-2) + (add-item-identifier name-1 ii-1 :revision revision-2) + (is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC)) + 3)) + (is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 3)) + (delete-construct ii-3) + (is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 2)) + (is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC)) + 3)) + (delete-construct ii-1) + ;(is (= (length (elephant:get-instances-by-class 'ItemIdentifierC)) 1)) + ;(is (= (length (elephant:get-instances-by-class 'd::ItemIdAssociationC)) + ; 2)) + ))) @@ -938,4 +968,6 @@ (it.bese.fiveam:run! 'test-ScopableC) (it.bese.fiveam:run! 'test-RoleC) (it.bese.fiveam:run! 'test-player) - (it.bese.fiveam:run! 'test-TopicMapC)) \ No newline at end of file + (it.bese.fiveam:run! 'test-TopicMapC) + (it.bese.fiveam:run! 'test-delete-ItemIdentifierC) + ) \ No newline at end of file

1 0

[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

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

isidorus-cvs