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