[isidorus-cvs] r218 - in branches/new-datamodel/src: model unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Sun Mar 7 20:15:38 UTC 2010
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
More information about the Isidorus-cvs
mailing list