[isidorus-cvs] r207 - in branches/new-datamodel/src: model unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Thu Feb 25 19:20:52 UTC 2010
Author: lgiessmann
Date: Thu Feb 25 14:20:51 2010
New Revision: 207
Log:
new-datamodel: added some unit-tests for add-reifier, reifier and delete-reifier; fixed alos msome problems in these functions; changed some key-parameters --> (reivision 0) was changed to (revision *TM-REVISION*) in all adder-functions, e.g. add-psi
Modified:
branches/new-datamodel/src/model/datamodel.lisp
branches/new-datamodel/src/unit_tests/datamodel_test.lisp
Modified: branches/new-datamodel/src/model/datamodel.lisp
==============================================================================
--- branches/new-datamodel/src/model/datamodel.lisp (original)
+++ branches/new-datamodel/src/model/datamodel.lisp Thu Feb 25 14:20:51 2010
@@ -94,6 +94,7 @@
(in-package :datamodel)
+;;TODO: finalize add-reifier
;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo
;; initarg in make-construct
;;TODO: implement a macro "with-merge-construct" that merges constructs
@@ -253,7 +254,7 @@
:inherit t
:documentation "A relation to all item-identifiers of
this construct.")
- (reifier :associate (ReifierAssociationC reified-construct)
+ (reifier :associate (ReifierAssociationC reifiable-construct)
:inherit t
:documentation "A relation to a reifier-topic."))
(:documentation "Reifiable constructs as per TMDM."))
@@ -316,7 +317,7 @@
:documentation "Contains all association objects that relate a
topic that is a theme with its scoppable
object.")
- (reified-construct :associate (ReifiedAssociationC reifier-topic)
+ (reified-construct :associate (ReifierAssociationC reifier-topic)
:documentation "Contains all association objects that
relate a topic that is a reifier with
its reified object.")
@@ -411,7 +412,7 @@
:initform (error "From ReifierAssociation(): reifiable-construct must be set")
:associate ReifiableConstructC
:documentation "The actual construct which is reified
- by a topic.")
+ by a topic.")
(reifier-topic :initarg :reifier-topic
:accessor reifier-topic
:initform (error "From ReifierAssociationC(): reifier-topic must be set")
@@ -786,7 +787,7 @@
If the passed identifer already identifies another object
the identified-constructs are merged.")
(:method ((construct TopicC) (topic-identifier TopicIdentificationC)
- &key (revision 0))
+ &key (revision *TM-REVISION*))
(let ((all-ids
(map 'list #'identifier (slot-p construct 'topic-identifiers)))
(construct-to-be-merged
@@ -840,7 +841,7 @@
If the passed identifer already identifies another object
the identified-constructs are merged.")
(:method ((construct TopicC) (psi PersistentIdC)
- &key (revision 0))
+ &key (revision *TM-REVISION*))
(let ((all-ids
(map 'list #'identifier (slot-p construct 'psis)))
(construct-to-be-merged
@@ -893,7 +894,7 @@
If the passed identifer already identifies another object
the identified-constructs are merged.")
(:method ((construct TopicC) (locator SubjectLocatorC)
- &key (revision 0))
+ &key (revision *TM-REVISION*))
(let ((all-ids
(map 'list #'identifier (slot-p construct 'locators)))
(construct-to-be-merged
@@ -946,7 +947,7 @@
If the passed name already owns another object
an error is thrown.")
(:method ((construct TopicC) (name NameC)
- &key (revision 0))
+ &key (revision *TM-REVISION*))
(when (not (eql (parent name) construct))
(error "From add-name(): ~a can't be owned by ~a since it is already owned by the topic ~a"
name construct (parent name)))
@@ -959,11 +960,12 @@
when (eql (parent-construct name-assoc) name)
return name-assoc)))
(add-to-version-history name-assoc :start-revision revision))
- (make-instance 'NameAssociationC
- :start-revision revision
- :parent-construct construct
- :characteristic name))
- construct)))
+ (let ((assoc
+ (make-instance 'NameAssociationC
+ :parent-construct construct
+ :characteristic name)))
+ (add-to-version-history assoc :start-revision revision))))
+ construct))
(defgeneric delete-name (construct name &key revision)
@@ -995,7 +997,7 @@
If the passed occurrence already owns another object
an error is thrown.")
(:method ((construct TopicC) (occurrence OccurrenceC)
- &key (revision 0))
+ &key (revision *TM-REVISION*))
(when (not (eql (parent occurrence) construct))
(error "From add-occurrence(): ~a can't be owned by ~a since it is already owned by the topic ~a"
occurrence construct (parent occurrence)))
@@ -1008,11 +1010,12 @@
when (eql (parent-construct occ-assoc) occurrence)
return occ-assoc)))
(add-to-version-history occ-assoc :start-revision revision))
- (make-instance 'OccurrenceAssociationC
- :start-revision revision
- :parent-construct construct
- :characteristic occurrence))
- construct)))
+ (let ((assoc
+ (make-instance 'OccurrenceAssociationC
+ :parent-construct construct
+ :characteristic occurrence)))
+ (add-to-version-history assoc :start-revision revision))))
+ construct))
(defgeneric delete-occurrence (construct occurrence &key revision)
@@ -1061,7 +1064,8 @@
(:method ((construct TopicC) &key (revision 0))
(let ((assocs (filter-slot-value-by-revision
construct 'reified-construct :start-revision revision)))
- (map 'list #'reifiable-construct assocs))))
+ (when assocs
+ (reifiable-construct (first assocs))))))
(defgeneric in-topicmaps (construct &key revision)
@@ -1184,7 +1188,7 @@
(:documentation "Adds the given theme-topic to the passed
scopable-construct.")
(:method ((construct NameC) (variant VariantC)
- &key (revision 0))
+ &key (revision *TM-REVISION*))
(when (not (eql (parent variant) construct))
(error "From add-variant(): ~a can't be owned by ~a since it is already owned by the name ~a"
variant construct (parent variant)))
@@ -1198,10 +1202,11 @@
when (eql (characteristic variant-assoc) variant)
return variant-assoc)))
(add-to-version-history variant-assoc :start-revision revision))
- (make-instance 'VariantAssociationC
- :start-revision revision
- :characteristic variant
- :parent-construct construct)))
+ (let ((assoc
+ (make-instance 'VariantAssociationC
+ :characteristic variant
+ :parent-construct construct)))
+ (add-to-version-history assoc :start-revision revision))))
construct))
@@ -1250,7 +1255,7 @@
(defmethod add-parent ((construct CharacteristicC) (parent-construct TopicC)
- &key (revision 0))
+ &key (revision *TM-REVISION*))
(let ((already-set-topic
(map 'list #'parent-construct
(filter-slot-value-by-revision construct 'parent
@@ -1264,12 +1269,13 @@
return parent-assoc)))
(add-to-version-history parent-assoc :start-revision revision)))
((not already-set-topic)
- (make-instance (if (typep construct 'OccurrenceC)
- 'OccurrenceAssociationC
- 'NameAssociationC)
- :start-revision revision
- :parent-construct parent-construct
- :characteristic construct))
+ (let ((assoc
+ (make-instance (if (typep construct 'OccurrenceC)
+ 'OccurrenceAssociationC
+ 'NameAssociationC)
+ :parent-construct parent-construct
+ :characteristic construct)))
+ (add-to-version-history assoc :start-revision revision)))
(t
(error "From add-parent(): ~a can't be owned by ~a since it is already owned by the topic ~a"
construct parent-construct already-set-topic)))
@@ -1277,7 +1283,7 @@
(defmethod add-parent ((construct CharacteristicC) (parent-construct NameC)
- &key (revision 0))
+ &key (revision *TM-REVISION*))
(let ((already-set-name
(map 'list #'characteristic
(filter-slot-value-by-revision construct 'parent
@@ -1290,10 +1296,11 @@
return parent-assoc)))
(add-to-version-history parent-assoc :start-revision revision)))
((not already-set-name)
- (make-instance 'VariantAssociationC
- :start-revision revision
- :parent-construct parent-construct
- :characteristic construct))
+ (let ((assoc
+ (make-instance 'VariantAssociationC
+ :parent-construct parent-construct
+ :characteristic construct)))
+ (add-to-version-history assoc :start-revision revision)))
(t
(error "From add-parent(): ~a can't be owned by ~a since it is already owned by the topic ~a"
construct parent-construct already-set-name)))
@@ -1448,7 +1455,7 @@
(defgeneric add-role (construct role &key revision)
(:documentation "Adds the given role to the passed association-construct.")
(:method ((construct AssociationC) (role RoleC)
- &key (revision 0))
+ &key (revision *TM-REVISION*))
(let ((all-roles
(map 'list #'role
(remove-if #'marked-as-deleted-p (slot-p construct 'roles)))))
@@ -1458,10 +1465,11 @@
when (eql (role role-assoc) role)
return role-assoc)))
(add-to-version-history role-assoc :start-revision revision))
- (make-instance 'RoleAssociationC
- :start-revision revision
- :role role
- :association construct)))
+ (let ((assoc
+ (make-instance 'RoleAssociationC
+ :role role
+ :association construct)))
+ (add-to-version-history assoc :start-revision revision))))
construct))
@@ -1501,7 +1509,7 @@
(defmethod add-parent ((construct RoleC) (parent-construct AssociationC)
- &key (revision 0))
+ &key (revision *TM-REVISION*))
(let ((already-set-parent
(map 'list #'parent
(filter-slot-value-by-revision construct 'parent
@@ -1515,10 +1523,10 @@
return parent-assoc)))
(add-to-version-history parent-assoc :start-revision revision)))
((not already-set-parent)
- (make-instance 'RoleAssociationC
- :start-revision revision
- :role construct
- :parent-construct parent-construct))
+ (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)))
@@ -1550,7 +1558,7 @@
(defgeneric add-player (construct player-topic &key revision)
(:documentation "Adds a topic as a player to a role in the given revision.")
(:method ((construct RoleC) (player-topic TopicC)
- &key (revision 0))
+ &key (revision *TM-REVISION*))
(let ((already-set-player
(map 'list #'player-topic
(filter-slot-value-by-revision construct 'player
@@ -1563,10 +1571,10 @@
return player-assoc)))
(add-to-version-history player-assoc :start-revision revision)))
((not already-set-player)
- (make-instance 'PlayerAssociationC
- :start-revision revision
- :parent-construct construct
- :player-topic player-topic))
+ (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)))
@@ -1602,9 +1610,9 @@
with the passed construct and the passed version.")
(:method ((construct ReifiableConstructC) &key (revision 0))
(let ((assocs (filter-slot-value-by-revision
- construct 'item-identifiers :start-revision revision)))
+ construct 'reifier :start-revision revision)))
(when assocs ;assocs must be nil or a list with exactly one item
- (reifier (first assocs))))))
+ (reifier-topic (first assocs))))))
(defmethod delete-construct :before ((construct ReifiableConstructC))
@@ -1624,7 +1632,7 @@
If the passed identifer already identifies another object
the identified-constructs are merged.")
(:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC)
- &key (revision 0))
+ &key (revision *TM-REVISION*))
(let ((all-ids
(map 'list #'identifier (slot-p construct 'item-identifiers)))
(construct-to-be-merged
@@ -1669,13 +1677,16 @@
If the reifier-topic reifies already another construct
the reified-constructs are merged.")
(:method ((construct ReifiableConstructC) (reifier-topic TopicC)
- &key (revision 0))
+ &key (revision *TM-REVISION*))
(let ((merged-reifier-topic
- (when (reifier construct)
- (merge-constructs (reifier construct) reifier-topic))))
+ (if (reifier construct)
+ (merge-constructs (reifier construct) reifier-topic)
+ reifier-topic)))
(let ((all-constructs
- (remove-if #'marked-as-deleted-p
- (slot-p reifier-topic 'reified-construct))))
+ (let ((inner-construct (reified-construct merged-reifier-topic
+ :revision revision)))
+ (when inner-construct
+ (list inner-construct)))))
(cond ((find construct all-constructs)
(let ((reifier-assoc
(loop for reifier-assoc in
@@ -1688,11 +1699,12 @@
(all-constructs
(merge-constructs (first all-constructs) construct))
(t
- (make-instance 'ReifierAssociationC
- :start-revision revision
- :reifiable-construct construct
- :reifier-topic merged-reifier-topic)
- construct))))))
+ (let ((assoc
+ (make-instance 'ReifierAssociationC
+ :reifiable-construct construct
+ :reifier-topic merged-reifier-topic)))
+ (add-to-version-history assoc :start-revision revision))))
+ construct))))
(defgeneric delete-reifier (construct reifier &key revision)
@@ -1729,7 +1741,7 @@
(:documentation "Adds the given theme-topic to the passed
scopable-construct.")
(:method ((construct ScopableC) (theme-topic TopicC)
- &key (revision 0))
+ &key (revision *TM-REVISION*))
(let ((all-themes
(map 'list #'theme-topic
(remove-if #'marked-as-deleted-p (slot-p construct 'themes)))))
@@ -1739,10 +1751,11 @@
when (eql (theme-topic theme-assoc) theme-topic)
return theme-assoc)))
(add-to-version-history theme-assoc :start-revision revision))
- (make-instance 'ScopeAssociationC
- :start-revision revision
- :theme-topic theme-topic
- :scopable-construct construct)))
+ (let ((assoc
+ (make-instance 'ScopeAssociationCn
+ :theme-topic theme-topic
+ :scopable-construct construct)))
+ (add-to-version-history assoc :start-revision revision))))
construct))
@@ -1782,7 +1795,7 @@
typed construct if there is no other type-topic
set at the same revision.")
(:method ((construct TypableC) (type-topic TopicC)
- &key (revision 0))
+ &key (revision *TM-REVISION*))
(let ((already-set-type
(map 'list #'type-topic
(filter-slot-value-by-revision construct 'instance-of
@@ -1795,10 +1808,11 @@
return type-assoc)))
(add-to-version-history type-assoc :start-revision revision)))
((not already-set-type)
- (make-instance 'TypeAssociationC
- :start-revision revision
- :type-topic type-topic
- :typable-construct construct))
+ (let ((assoc
+ (make-instance 'TypeAssociationC
+ :type-topic type-topic
+ :typable-construct construct)))
+ (add-to-version-history assoc :start-revision revision)))
(t
(error "From add-type(): ~a can't be typed by ~a since it is already typed by the topic ~a"
construct type-topic already-set-type)))
@@ -1831,10 +1845,11 @@
;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defgeneric merge-constructs(construc-1 construct-2 &key revision)
+(defgeneric merge-constructs(construct-1 construct-2 &key revision)
(:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC)
- &key (revision 0))
- (or construct-1 construct-2 revision)))
+ &key (revision *TM-REVISION*))
+ (or revision)
+ (if construct-1 construct-1 construct-2)))
(defgeneric make-construct (class-symbol &key start-revision &allow-other-keys)
Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp
==============================================================================
--- branches/new-datamodel/src/unit_tests/datamodel_test.lisp (original)
+++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp Thu Feb 25 14:20:51 2010
@@ -26,13 +26,18 @@
:test-get-item-by-id
:test-get-item-by-item-identifier
:test-get-item-by-locator
- :test-get-item-by-psi))
+ :test-get-item-by-psi
+ :test-ReifiableConstructC))
-;;TODO: test merges-constructs when merging was caused by an item-dentifier
-;;TODO: test merges-constructs when merging was caused by an psi
-;;TODO: test merges-constructs when merging was caused by an subject-locator
-;;TODO: test merges-constructs when merging was caused by a topic-id
+;;TODO: test delete-construct
+;;TODO: test merge-constructs when merging was caused by an item-dentifier
+;;TODO: test merge-constructs when merging was caused by an psi
+;;TODO: test merge-constructs when merging was caused by an subject-locator
+;;TODO: test merge-constructs when merging was caused by a topic-id
+;;TODO: test merge-constructs when merging was caused by reifiers
+;; (occurrences, names, variants, associations, roles)
+;;TODO: test ReifiableConstructC --> reifier has to be merged
@@ -367,7 +372,7 @@
(test test-get-item-by-item-identifier ()
- "Tests the function test-get-item-by-id."
+ "Tests the function test-get-item-by-item-identifier."
(with-fixture with-empty-db (*db-dir*)
(let ((ii-1 (make-instance 'ItemIdentifierC
:uri "ii-1"))
@@ -409,7 +414,7 @@
(test test-get-item-by-locator ()
- "Tests the function test-get-item-by-id."
+ "Tests the function test-get-item-by-locator."
(with-fixture with-empty-db (*db-dir*)
(let ((sl-1 (make-instance 'SubjectLocatorC
:uri "sl-1"))
@@ -451,7 +456,7 @@
(test test-get-item-by-psi ()
- "Tests the function test-get-item-by-id."
+ "Tests the function test-get-item-by-psi."
(with-fixture with-empty-db (*db-dir*)
(let ((psi-1 (make-instance 'PersistentIdC
:uri "psi-1"))
@@ -492,6 +497,22 @@
(is (eql top-3 (get-item-by-locator "psi-1"))))))
+(test test-ReifiableConstructC ()
+ "Tests variuas functions of the ReifialeConstructC."
+ (with-fixture with-empty-db (*db-dir*)
+ (let ((reifier-top (make-instance 'TopicC))
+ (reified-rc (make-instance 'd::ReifiableConstructC)))
+ (is-false (reifier reified-rc))
+ (is-false (reified-construct reifier-top))
+ (add-reifier reified-rc reifier-top :revision 100)
+ (is (eql reifier-top (reifier reified-rc)))
+ (is (eql reified-rc (reified-construct reifier-top)))
+ (is (eql reifier-top (reifier reified-rc :revision 200)))
+ (is (eql reified-rc (reified-construct reifier-top :revision 200)))
+ (is-false (reifier reified-rc :revision 50))
+ (is-false (reified-construct reifier-top :revision 50)))))
+
+
(defun run-datamodel-tests()
(it.bese.fiveam:run! 'test-VersionInfoC)
(it.bese.fiveam:run! 'test-VersionedConstructC)
@@ -503,4 +524,5 @@
(it.bese.fiveam:run! 'test-get-item-by-item-identifier)
(it.bese.fiveam:run! 'test-get-item-by-locator)
(it.bese.fiveam:run! 'test-get-item-by-psi)
+ (it.bese.fiveam:run! 'test-ReifiableConstructC)
)
\ No newline at end of file
More information about the Isidorus-cvs
mailing list