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
