isidorus-cvs February 2010

isidorus-cvs@common-lisp.net

1 participants
42 discussions

[isidorus-cvs] r207 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 25 Feb '10

25 Feb '10

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

1 0

[isidorus-cvs] r206 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 24 Feb '10

24 Feb '10

Author: lgiessmann Date: Wed Feb 24 14:59:58 2010 New Revision: 206 Log: new-datamodel: added unit-tests for: get-item-by-item-identifier, get-item-by-psi and get-item-by-locator; optimized the function get item-by-identifier 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 Feb 24 14:59:58 2010 @@ -83,7 +83,7 @@ :get-revision :get-item-by-id :get-item-by-psi - :get-item-by-item-identnfier + :get-item-by-item-identifier :get-item-by-locator :string-integer-p @@ -94,11 +94,6 @@ (in-package :datamodel) - -;;TODO: implement get-item-by-id(TopicC) + unit-tests -;;TODO: implement get-item-by-psi(TopicC) + unit-tests -;;TODO: implement get-item-by-locator(TopicC) + unit-tests -;;TODO: implement get-item-by-item-identifier(ReifiableConstructC) + unit-tests ;;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 @@ -1135,7 +1130,7 @@ (delete-if-not #'(lambda(id) (string= (uri id) uri)) - (get-instances-by-class identifier-type-symbol)))) + (get-instances-by-value identifier-type-symbol 'uri uri)))) (when (and possible-ids (identified-construct (first possible-ids) :revision revision)) (unless (= (length possible-ids) 1) 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 Feb 24 14:59:58 2010 @@ -23,7 +23,10 @@ :test-PersistentIdC :test-SubjectLocatorC :test-TopicIdentificationC - :test-get-item-by-id)) + :test-get-item-by-id + :test-get-item-by-item-identifier + :test-get-item-by-locator + :test-get-item-by-psi)) ;;TODO: test merges-constructs when merging was caused by an item-dentifier @@ -363,6 +366,132 @@ :revision revision))))) +(test test-get-item-by-item-identifier () + "Tests the function test-get-item-by-id." + (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-1 (make-instance 'ItemIdentifierC + :uri "ii-3")) + (ii-3-2 (make-instance 'ItemIdentifierC + :uri "ii-3")) + (top-1 (make-instance 'TopicC)) + (top-2 (make-instance 'TopicC)) + (top-3 (make-instance 'TopicC)) + (revision 100) + (revision-2 200)) + (setf d:*TM-REVISION* revision) + (is-false (get-item-by-id "any-ii-id")) + (signals error (is-false (get-item-by-item-identifier + "any-ii-id" :error-if-nil t))) + (signals error (is-false (get-item-by-item-identifier + "any-ii-id" :error-if-nil t))) + (is-false (get-item-by-item-identifier "any-ii-id")) + (add-item-identifier top-1 ii-3-1 :revision revision) + (add-item-identifier top-1 ii-3-2 :revision revision) + (signals duplicate-identifier-error + (get-item-by-item-identifier "ii-3" :revision revision)) + (add-item-identifier top-2 ii-1) + (add-item-identifier top-2 ii-2 :revision revision-2) + (is (eql top-2 (get-item-by-item-identifier "ii-1"))) + (is (eql top-2 (get-item-by-item-identifier "ii-2"))) + (is (eql top-2 (get-item-by-item-identifier "ii-1" :revision 500))) + (is-false (get-item-by-item-identifier "ii-2" :revision revision)) + (delete-item-identifier top-2 ii-1 :revision revision-2) + (is-false (get-item-by-item-identifier "ii-1")) + (is (eql top-2 (get-item-by-item-identifier "ii-1" :revision revision))) + (add-item-identifier top-3 ii-1 :revision revision-2) + (is (eql top-2 (get-item-by-item-identifier "ii-1" :revision revision))) + (d::add-to-version-history top-3 :start-revision revision-2) + (is (eql top-3 (get-item-by-item-identifier "ii-1")))))) + + +(test test-get-item-by-locator () + "Tests the function test-get-item-by-id." + (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-1 (make-instance 'SubjectLocatorC + :uri "sl-3")) + (sl-3-2 (make-instance 'SubjectLocatorC + :uri "sl-3")) + (top-1 (make-instance 'TopicC)) + (top-2 (make-instance 'TopicC)) + (top-3 (make-instance 'TopicC)) + (revision 100) + (revision-2 200)) + (setf d:*TM-REVISION* revision) + (is-false (get-item-by-id "any-sl-id")) + (signals error (is-false (get-item-by-locator + "any-sl-id" :error-if-nil t))) + (signals error (is-false (get-item-by-locator + "any-sl-id" :error-if-nil t))) + (is-false (get-item-by-locator "any-sl-id")) + (add-locator top-1 sl-3-1 :revision revision) + (add-locator top-1 sl-3-2 :revision revision) + (signals duplicate-identifier-error + (get-item-by-locator "sl-3" :revision revision)) + (add-locator top-2 sl-1) + (add-locator top-2 sl-2 :revision revision-2) + (is (eql top-2 (get-item-by-locator "sl-1"))) + (is (eql top-2 (get-item-by-locator "sl-2"))) + (is (eql top-2 (get-item-by-locator "sl-1" :revision 500))) + (is-false (get-item-by-locator "sl-2" :revision revision)) + (delete-locator top-2 sl-1 :revision revision-2) + (is-false (get-item-by-locator "sl-1")) + (is (eql top-2 (get-item-by-locator "sl-1" :revision revision))) + (add-locator top-3 sl-1 :revision revision-2) + (is (eql top-2 (get-item-by-locator "sl-1" :revision revision))) + (d::add-to-version-history top-3 :start-revision revision-2) + (is (eql top-3 (get-item-by-locator "sl-1")))))) + + +(test test-get-item-by-psi () + "Tests the function test-get-item-by-id." + (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-1 (make-instance 'PersistentIdC + :uri "psi-3")) + (psi-3-2 (make-instance 'PersistentIdC + :uri "psi-3")) + (top-1 (make-instance 'TopicC)) + (top-2 (make-instance 'TopicC)) + (top-3 (make-instance 'TopicC)) + (revision 100) + (revision-2 200)) + (setf d:*TM-REVISION* revision) + (is-false (get-item-by-id "any-psi-id")) + (signals error (is-false (get-item-by-locator + "any-psi-id" :error-if-nil t))) + (signals error (is-false (get-item-by-locator + "any-psi-id" :error-if-nil t))) + (is-false (get-item-by-locator "any-psi-id")) + (add-psi top-1 psi-3-1 :revision revision) + (add-psi top-1 psi-3-2 :revision revision) + (signals duplicate-identifier-error + (get-item-by-locator "psi-3" :revision revision)) + (add-psi top-2 psi-1) + (add-psi top-2 psi-2 :revision revision-2) + (is (eql top-2 (get-item-by-locator "psi-1"))) + (is (eql top-2 (get-item-by-locator "psi-2"))) + (is (eql top-2 (get-item-by-locator "psi-1" :revision 500))) + (is-false (get-item-by-locator "psi-2" :revision revision)) + (delete-psi top-2 psi-1 :revision revision-2) + (is-false (get-item-by-locator "psi-1")) + (is (eql top-2 (get-item-by-locator "psi-1" :revision revision))) + (add-psi top-3 psi-1 :revision revision-2) + (is (eql top-2 (get-item-by-locator "psi-1" :revision revision))) + (d::add-to-version-history top-3 :start-revision revision-2) + (is (eql top-3 (get-item-by-locator "psi-1")))))) + + (defun run-datamodel-tests() (it.bese.fiveam:run! 'test-VersionInfoC) (it.bese.fiveam:run! 'test-VersionedConstructC) @@ -371,4 +500,7 @@ (it.bese.fiveam:run! 'test-SubjectLocatorC) (it.bese.fiveam:run! 'test-TopicIdentificationC) (it.bese.fiveam:run! 'test-get-item-by-id) + (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) ) \ No newline at end of file

1 0

[isidorus-cvs] r205 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 24 Feb '10

24 Feb '10

Author: lgiessmann Date: Wed Feb 24 14:28:28 2010 New Revision: 205 Log: new-datamodel: fixed some problems with get-item-by-id and added some unit-tests 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 Feb 24 14:28:28 2010 @@ -94,8 +94,7 @@ (in-package :datamodel) -;;TODO: fix this line (make-instance 'TopicC :from-oid (subseq topic-id 1))))) -;; in get-item-by-id + ;;TODO: implement get-item-by-id(TopicC) + unit-tests ;;TODO: implement get-item-by-psi(TopicC) + unit-tests ;;TODO: implement get-item-by-locator(TopicC) + unit-tests @@ -265,7 +264,8 @@ (:documentation "Reifiable constructs as per TMDM.")) -(defpclass AssociationC(ReifiableConstructC ScopableC TypableC) +(defpclass AssociationC(ReifiableConstructC ScopableC TypableC + VersionedConstructC) ((roles :associate (RoleAssociationC association) :documentation "Contains all association-objects of all roles this association contains.") @@ -284,7 +284,7 @@ :documentation "Associates this object with a player-association."))) -(elephant:defpclass TopicMapC (ReifiableConstructC) +(elephant:defpclass TopicMapC (ReifiableConstructC VersionedConstructC) ((topics :accessor topics :associate (TopicC in-topicmaps) :documentation "List of topics that explicitly belong to this TM.") @@ -294,7 +294,7 @@ (:documentation "Represnets a topic map.")) -(defpclass TopicC (ReifiableConstructC) +(defpclass TopicC (ReifiableConstructC VersionedConstructC) ((topic-identifiers :associate (TopicIdAssociationC parent-construct) :documentation "Contains all association objects that relate a topic with its actual @@ -749,7 +749,7 @@ (defgeneric identified-construct (construct &key revision) (:documentation "Returns the identified-construct -> ReifiableConstructC or TopicC that corresponds with the passed revision.") - (:method ((construct PointerC) &key (revision *TM-REVISION*)) + (:method ((construct PointerC) &key (revision 0)) (let ((assocs (map 'list #'parent-construct (filter-slot-value-by-revision construct 'identified-construct @@ -778,7 +778,7 @@ (defgeneric topic-identifiers (construct &key revision) (:documentation "Returns the TopicIdentificationC-objects that correspond with the passed construct and the passed version.") - (:method ((construct TopicC) &key (revision *TM-REVISION*)) + (:method ((construct TopicC) &key (revision 0)) (let ((assocs (filter-slot-value-by-revision construct 'topic-identifiers :start-revision revision))) (map 'list #'identifier assocs)))) @@ -791,7 +791,7 @@ If the passed identifer already identifies another object the identified-constructs are merged.") (:method ((construct TopicC) (topic-identifier TopicIdentificationC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (let ((all-ids (map 'list #'identifier (slot-p construct 'topic-identifiers))) (construct-to-be-merged @@ -799,9 +799,7 @@ (when (not (eql id-owner construct)) id-owner)))) (cond (construct-to-be-merged - (merge-constructs (identified-construct construct-to-be-merged - :revision revision) - construct)) + (merge-constructs construct construct-to-be-merged :revision revision)) ((find topic-identifier all-ids) (let ((ti-assoc (loop for ti-assoc in (slot-p construct 'topic-identifiers) @@ -834,7 +832,7 @@ (defgeneric psis (construct &key revision) (:documentation "Returns the PersistentIdC-objects that correspond with the passed construct and the passed version.") - (:method ((construct TopicC) &key (revision *TM-REVISION*)) + (:method ((construct TopicC) &key (revision 0)) (let ((assocs (filter-slot-value-by-revision construct 'psis :start-revision revision))) (map 'list #'identifier assocs)))) @@ -847,7 +845,7 @@ If the passed identifer already identifies another object the identified-constructs are merged.") (:method ((construct TopicC) (psi PersistentIdC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (let ((all-ids (map 'list #'identifier (slot-p construct 'psis))) (construct-to-be-merged @@ -855,9 +853,8 @@ (when (not (eql id-owner construct)) id-owner)))) (cond (construct-to-be-merged - (merge-constructs (identified-construct construct-to-be-merged - :revision revision) - construct)) + (merge-constructs construct construct-to-be-merged + :revision revision)) ((find psi all-ids) (let ((psi-assoc (loop for psi-assoc in (slot-p construct 'psis) when (eql (identifier psi-assoc) psi) @@ -888,7 +885,7 @@ (defgeneric locators (construct &key revision) (:documentation "Returns the SubjectLocatorC-objects that correspond with the passed construct and the passed version.") - (:method ((construct TopicC) &key (revision *TM-REVISION*)) + (:method ((construct TopicC) &key (revision 0)) (let ((assocs (filter-slot-value-by-revision construct 'locators :start-revision revision))) (map 'list #'identifier assocs)))) @@ -901,7 +898,7 @@ If the passed identifer already identifies another object the identified-constructs are merged.") (:method ((construct TopicC) (locator SubjectLocatorC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (let ((all-ids (map 'list #'identifier (slot-p construct 'locators))) (construct-to-be-merged @@ -909,9 +906,8 @@ (when (not (eql id-owner construct)) id-owner)))) (cond (construct-to-be-merged - (merge-constructs (identified-construct construct-to-be-merged - :revision revision) - construct)) + (merge-constructs construct construct-to-be-merged + :revision revision)) ((find locator all-ids) (let ((loc-assoc (loop for loc-assoc in (slot-p construct 'locators) when (eql (identifier loc-assoc) locator) @@ -942,7 +938,7 @@ (defgeneric names (construct &key revision) (:documentation "Returns the NameC-objects that correspond with the passed construct and the passed version.") - (:method ((construct TopicC) &key (revision *TM-REVISION*)) + (:method ((construct TopicC) &key (revision 0)) (let ((assocs (filter-slot-value-by-revision construct 'names :start-revision revision))) (map 'list #'characteristic assocs)))) @@ -955,7 +951,7 @@ If the passed name already owns another object an error is thrown.") (:method ((construct TopicC) (name NameC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (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))) @@ -991,7 +987,7 @@ (defgeneric occurrences (construct &key revision) (:documentation "Returns the OccurrenceC-objects that correspond with the passed construct and the passed version.") - (:method ((construct TopicC) &key (revision *TM-REVISION*)) + (:method ((construct TopicC) &key (revision 0)) (let ((assocs (filter-slot-value-by-revision construct 'occurences :start-revision revision))) (map 'list #'characteristic assocs)))) @@ -1004,7 +1000,7 @@ If the passed occurrence already owns another object an error is thrown.") (:method ((construct TopicC) (occurrence OccurrenceC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (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))) @@ -1040,7 +1036,7 @@ (defgeneric player-in-roles (construct &key revision) (:documentation "Returns the RoleC-objects that correspond with the passed construct and the passed version.") - (:method ((construct TopicC) &key (revision *TM-REVISION*)) + (:method ((construct TopicC) &key (revision 0)) (let ((assocs (filter-slot-value-by-revision construct 'player-in-roles :start-revision revision))) (map 'list #'parent-construct assocs)))) @@ -1049,7 +1045,7 @@ (defgeneric used-as-type (construct &key revision) (:documentation "Returns the TypableC-objects that correspond with the passed construct and the passed version.") - (:method ((construct TopicC) &key (revision *TM-REVISION*)) + (:method ((construct TopicC) &key (revision 0)) (let ((assocs (filter-slot-value-by-revision construct 'used-as-type :start-revision revision))) (map 'list #'typable-construct assocs)))) @@ -1058,7 +1054,7 @@ (defgeneric used-as-theme (construct &key revision) (:documentation "Returns the ScopableC-objects that correspond with the passed construct and the passed version.") - (:method ((construct TopicC) &key (revision *TM-REVISION*)) + (:method ((construct TopicC) &key (revision 0)) (let ((assocs (filter-slot-value-by-revision construct 'used-as-theme :start-revision revision))) (map 'list #'scopable-construct assocs)))) @@ -1067,7 +1063,7 @@ (defgeneric reified-construct (construct &key revision) (:documentation "Returns the ReifiableConstructC-objects that correspond with the passed construct and the passed version.") - (:method ((construct TopicC) &key (revision *TM-REVISION*)) + (:method ((construct TopicC) &key (revision 0)) (let ((assocs (filter-slot-value-by-revision construct 'reified-construct :start-revision revision))) (map 'list #'reifiable-construct assocs)))) @@ -1077,7 +1073,7 @@ (:documentation "Returns all TopicMapS-obejcts where the constrict is contained in.")) -(defmethod in-topicmaps ((topic TopicC) &key (revision *TM-REVISION*)) +(defmethod in-topicmaps ((topic TopicC) &key (revision 0)) (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision)) @@ -1088,7 +1084,7 @@ if the topic already existed in this revision and returns nil otherwise. If no item meeting the constraints was found, then the return value is either NIL or an error is thrown, depending on error-if-nil." - (declare (string topic-id) (integer revision) (string xtm-id)) + (declare (string topic-id) (integer revision)) (let ((result (if xtm-id (let ((possible-top-ids @@ -1105,19 +1101,25 @@ (when (and possible-top-ids (identified-construct (first possible-top-ids) :revision revision)) (unless (= (length possible-top-ids) 1) - (error (make-condition 'duplicate-identifier-error - :message (format nil "(length possible-items ~a) for id ~a and xtm-id ~a > 1" - possible-top-ids topic-id xtm-id) - :uri topic-id))) + (error + (make-condition 'duplicate-identifier-error + :message (format nil "(length possible-items ~a) for id ~a and xtm-id ~a > 1" + possible-top-ids topic-id xtm-id) + :uri topic-id))) (identified-construct (first possible-top-ids) :revision revision) ;no revision need not to be chaecked, since the revision ;is implicitely checked by the function identified-construct )) (when (and (> (length topic-id) 0) - (eql (elt 0 topic-id) #\t) + (eql (elt topic-id 0) #\t) (string-integer-p (subseq topic-id 1))) - (elephant::controller-recreate-instance elephant::*store-controller* (subseq topic-id 1)))))) + (let ((top-from-oid + (elephant::controller-recreate-instance + elephant::*store-controller* + (parse-integer (subseq topic-id 1))))) + (when (find-item-by-revision top-from-oid revision) + top-from-oid)))))) (if (and error-if-nil (not result)) (error "No such item (id: ~a, tm: ~a, rev: ~a)" topic-id xtm-id revision) result))) @@ -1176,7 +1178,7 @@ (defgeneric variants (construct &key revision) (:documentation "Returns all variants that correspond with the given revision and that are associated with the passed construct.") - (:method ((construct NameC) &key (revision *TM-REVISION*)) + (:method ((construct NameC) &key (revision 0)) (let ((valid-associations (filter-slot-value-by-revision construct 'variants :start-revision revision))) @@ -1187,7 +1189,7 @@ (:documentation "Adds the given theme-topic to the passed scopable-construct.") (:method ((construct NameC) (variant VariantC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (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))) @@ -1239,7 +1241,7 @@ (:documentation "Returns the parent construct of the passed object that corresponds with the given revision. The returned construct can be a TopicC or a NameC.") - (:method ((construct CharacteristicC) &key (revision *TM-REVISION*)) + (:method ((construct CharacteristicC) &key (revision 0)) (let ((valid-associations (filter-slot-value-by-revision construct 'parent :start-revision revision))) @@ -1253,7 +1255,7 @@ (defmethod add-parent ((construct CharacteristicC) (parent-construct TopicC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (let ((already-set-topic (map 'list #'parent-construct (filter-slot-value-by-revision construct 'parent @@ -1280,7 +1282,7 @@ (defmethod add-parent ((construct CharacteristicC) (parent-construct NameC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (let ((already-set-name (map 'list #'characteristic (filter-slot-value-by-revision construct 'parent @@ -1441,7 +1443,7 @@ (defgeneric roles (construct &key revision) (:documentation "Returns all topics that correspond with the given revision as a scope for the given topic.") - (:method ((construct AssociationC) &key (revision *TM-REVISION*)) + (:method ((construct AssociationC) &key (revision 0)) (let ((valid-associations (filter-slot-value-by-revision construct 'roles :start-revision revision))) @@ -1451,7 +1453,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 *TM-REVISION*)) + &key (revision 0)) (let ((all-roles (map 'list #'role (remove-if #'marked-as-deleted-p (slot-p construct 'roles))))) @@ -1481,7 +1483,7 @@ construct))) -(defmethod in-topicmaps ((association AssociationC) &key (revision *TM-REVISION*)) +(defmethod in-topicmaps ((association AssociationC) &key (revision 0)) (filter-slot-value-by-revision association 'in-topicmaps :start-revision revision)) @@ -1494,7 +1496,7 @@ (delete-construct assoc))) -(defmethod parent ((construct RoleC) &key (revision *TM-REVISION*)) +(defmethod parent ((construct RoleC) &key (revision 0)) "Returns the construct's parent corresponding to the given revision." (let ((valid-associations (filter-slot-value-by-revision construct 'parent @@ -1504,7 +1506,7 @@ (defmethod add-parent ((construct RoleC) (parent-construct AssociationC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (let ((already-set-parent (map 'list #'parent (filter-slot-value-by-revision construct 'parent @@ -1542,7 +1544,7 @@ (defgeneric player (construct &key revision) (:documentation "Returns the construct's player corresponding to the given revision.") - (:method ((construct RoleC) &key (revision *TM-REVISION*)) + (:method ((construct RoleC) &key (revision 0)) (let ((valid-associations (filter-slot-value-by-revision construct 'player :start-revision revision))) @@ -1553,7 +1555,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 *TM-REVISION*)) + &key (revision 0)) (let ((already-set-player (map 'list #'player-topic (filter-slot-value-by-revision construct 'player @@ -1594,7 +1596,7 @@ (defgeneric item-identifiers (construct &key revision) (:documentation "Returns the ItemIdentifierC-objects that correspond with the passed construct and the passed version.") - (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*)) + (:method ((construct ReifiableConstructC) &key (revision 0)) (let ((assocs (filter-slot-value-by-revision construct 'item-identifiers :start-revision revision))) (map 'list #'identifier assocs)))) @@ -1603,7 +1605,7 @@ (defgeneric reifier (construct &key revision) (:documentation "Returns the reifier-topic that corresponds with the passed construct and the passed version.") - (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*)) + (:method ((construct ReifiableConstructC) &key (revision 0)) (let ((assocs (filter-slot-value-by-revision construct 'item-identifiers :start-revision revision))) (when assocs ;assocs must be nil or a list with exactly one item @@ -1627,7 +1629,7 @@ If the passed identifer already identifies another object the identified-constructs are merged.") (:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (let ((all-ids (map 'list #'identifier (slot-p construct 'item-identifiers))) (construct-to-be-merged @@ -1635,9 +1637,8 @@ (when (not (eql id-owner construct)) id-owner)))) (cond (construct-to-be-merged - (merge-constructs (identified-construct construct-to-be-merged - :revision revision) - construct)) + (merge-constructs construct construct-to-be-merged + :revision revision)) ((find item-identifier all-ids) (let ((ii-assoc (loop for ii-assoc in (slot-p construct 'item-identifiers) @@ -1673,7 +1674,7 @@ If the reifier-topic reifies already another construct the reified-constructs are merged.") (:method ((construct ReifiableConstructC) (reifier-topic TopicC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (let ((merged-reifier-topic (when (reifier construct) (merge-constructs (reifier construct) reifier-topic)))) @@ -1722,7 +1723,7 @@ (defgeneric themes (construct &key revision) (:documentation "Returns all topics that correspond with the given revision as a scope for the given topic.") - (:method ((construct ScopableC) &key (revision *TM-REVISION*)) + (:method ((construct ScopableC) &key (revision 0)) (let ((valid-associations (filter-slot-value-by-revision construct 'themes :start-revision revision))) @@ -1733,7 +1734,7 @@ (:documentation "Adds the given theme-topic to the passed scopable-construct.") (:method ((construct ScopableC) (theme-topic TopicC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (let ((all-themes (map 'list #'theme-topic (remove-if #'marked-as-deleted-p (slot-p construct 'themes))))) @@ -1773,7 +1774,7 @@ (defgeneric instance-of (construct &key revision) (:documentation "Returns the type topic that is set on the passed revision.") - (:method ((construct TypableC) &key (revision *TM-REVISION*)) + (:method ((construct TypableC) &key (revision 0)) (let ((valid-associations (filter-slot-value-by-revision construct 'instance-of :start-revision revision))) @@ -1786,7 +1787,7 @@ typed construct if there is no other type-topic set at the same revision.") (:method ((construct TypableC) (type-topic TopicC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (let ((already-set-type (map 'list #'type-topic (filter-slot-value-by-revision construct 'instance-of @@ -1837,7 +1838,7 @@ ;;; start hacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defgeneric merge-constructs(construc-1 construct-2 &key revision) (:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapconstructC) - &key (revision *TM-REVISION*)) + &key (revision 0)) (or construct-1 construct-2 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 Feb 24 14:28:28 2010 @@ -14,13 +14,16 @@ :it.bese.FiveAM :fixtures :unittests-constants) + (:import-from :exceptions + duplicate-identifier-error) (:export :run-datamodel-tests :test-VersionInfoC :test-VersionedConstructC :test-ItemIdentifierC :test-PersistentIdC :test-SubjectLocatorC - :test-TopicIdentificationC)) + :test-TopicIdentificationC + :test-get-item-by-id)) ;;TODO: test merges-constructs when merging was caused by an item-dentifier @@ -302,6 +305,64 @@ (is-false (topic-identifiers topic-1 :revision revision-3-5))))) +(test test-get-item-by-id () + "Tests the function test-get-item-by-id." + (with-fixture with-empty-db (*db-dir*) + (let ((top-id-1 (make-instance 'TopicIdentificationC + :uri "topid-1" + :xtm-id "xtm-id-1")) + (top-id-2 (make-instance 'TopicIdentificationC + :uri "topid-2" + :xtm-id "xtm-id-2")) + (top-id-3-1 (make-instance 'TopicIdentificationC + :uri "topid-3" + :xtm-id "xtm-id-3")) + (top-id-3-2 (make-instance 'TopicIdentificationC + :uri "topid-3" + :xtm-id "xtm-id-3")) + (top-1 (make-instance 'TopicC)) + (top-2 (make-instance 'TopicC)) + (top-3 (make-instance 'TopicC)) + (revision 100) + (revision-2 200)) + (setf d:*TM-REVISION* revision) + (is-false (get-item-by-id "any-top-id")) + (signals error (is-false (get-item-by-id + "any-top-id" :xtm-id "any-xtm-id" + :error-if-nil t))) + (signals error (is-false (get-item-by-id "any-top-id" :error-if-nil t))) + (is-false (get-item-by-id "any-top-id" :xtm-id "any-xtm-id")) + (add-topic-identifier top-1 top-id-3-1 :revision revision) + (add-topic-identifier top-1 top-id-3-2 :revision revision) + (signals duplicate-identifier-error + (get-item-by-id "topid-3" :xtm-id "xtm-id-3" :revision revision)) + (add-topic-identifier top-2 top-id-1) + (add-topic-identifier top-2 top-id-2 :revision revision-2) + (is (eql top-2 (get-item-by-id "topid-1" :xtm-id "xtm-id-1"))) + (is (eql top-2 (get-item-by-id "topid-2" :xtm-id "xtm-id-2"))) + (is (eql top-2 (get-item-by-id "topid-1" :xtm-id "xtm-id-1" + :revision 500))) + (is-false (get-item-by-id "topid-2" :xtm-id "xtm-id-2" + :revision revision)) + (delete-topic-identifier top-2 top-id-1 :revision revision-2) + (is-false (get-item-by-id "topid-1" :xtm-id "xtm-id-1")) + (is (eql top-2 (get-item-by-id "topid-1" :xtm-id "xtm-id-1" + :revision revision))) + (add-topic-identifier top-3 top-id-1 :revision revision-2) + (is (eql top-2 (get-item-by-id "topid-1" :xtm-id "xtm-id-1" + :revision revision))) + (d::add-to-version-history top-3 :start-revision revision-2) + (is (eql top-3 (get-item-by-id "topid-1" :xtm-id "xtm-id-1"))) + (is (eql top-3 + (get-item-by-id + (concatenate 'string "t" (write-to-string + (elephant::oid top-3)))))) + (is-false (get-item-by-id + (concatenate 'string "t" (write-to-string + (elephant::oid top-3))) + :revision revision))))) + + (defun run-datamodel-tests() (it.bese.fiveam:run! 'test-VersionInfoC) (it.bese.fiveam:run! 'test-VersionedConstructC) @@ -309,4 +370,5 @@ (it.bese.fiveam:run! 'test-PersistentIdC) (it.bese.fiveam:run! 'test-SubjectLocatorC) (it.bese.fiveam:run! 'test-TopicIdentificationC) + (it.bese.fiveam:run! 'test-get-item-by-id) ) \ No newline at end of file

1 0

[isidorus-cvs] r204 - branches/new-datamodel/src/model trunk/src/model
by Lukas Giessmann 24 Feb '10

24 Feb '10

Author: lgiessmann Date: Wed Feb 24 11:04:46 2010 New Revision: 204 Log: new-datamodel: added the functions get-item-by-item-identifier, get-item-by-psi, get-item-by-locator; fixed a bug in the function get-item-by-id -> ticket #65 Modified: branches/new-datamodel/src/model/datamodel.lisp trunk/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 Wed Feb 24 11:04:46 2010 @@ -10,6 +10,8 @@ (defpackage :datamodel (:use :cl :elephant :constants) (:nicknames :d) + (:import-from :exceptions + duplicate-identifier-error) (:export ;;classes :TopicMapC :AssociationC @@ -79,6 +81,11 @@ :in-topicmaps :delete-construct :get-revision + :get-item-by-id + :get-item-by-psi + :get-item-by-item-identnfier + :get-item-by-locator + :string-integer-p ;;globals :*TM-REVISION* @@ -87,6 +94,12 @@ (in-package :datamodel) +;;TODO: fix this line (make-instance 'TopicC :from-oid (subseq topic-id 1))))) +;; in get-item-by-id +;;TODO: implement get-item-by-id(TopicC) + unit-tests +;;TODO: implement get-item-by-psi(TopicC) + unit-tests +;;TODO: implement get-item-by-locator(TopicC) + unit-tests +;;TODO: implement get-item-by-item-identifier(ReifiableConstructC) + unit-tests ;;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 @@ -609,6 +622,13 @@ (get-universal-time)) +(defun string-integer-p (integer-as-string) + "Returns t if the passed string can be parsed to an integer." + (handler-case (when (parse-integer integer-as-string) + t) + (condition () nil))) + + ;;; generic functions/accessors ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; VersionInfocC (defmethod delete-construct :before ((version-info VersionInfoC)) @@ -1061,6 +1081,96 @@ (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision)) +(defun get-item-by-id (topic-id &key (xtm-id *CURRENT-XTM*) (revision 0) (error-if-nil nil)) + "Gets a topic by its id, assuming an xtm-id. If xtm-id is empty, the current TM + is chosen. If xtm-id is nil, choose the global TM with its internal ID, if + applicable in the correct revision. If revison is provided, then the code checks + if the topic already existed in this revision and returns nil otherwise. + If no item meeting the constraints was found, then the return value is either + NIL or an error is thrown, depending on error-if-nil." + (declare (string topic-id) (integer revision) (string xtm-id)) + (let ((result + (if xtm-id + (let ((possible-top-ids + (delete-if-not + #'(lambda(top-id) + (and (string= (xtm-id top-id) xtm-id) + (string= (uri top-id) topic-id))) + ;fixes a bug in get-instances-by-value that does a + ;case-insensitive comparision + (elephant:get-instances-by-value + 'TopicIdentificationC + 'uri + topic-id)))) + (when (and possible-top-ids + (identified-construct (first possible-top-ids) :revision revision)) + (unless (= (length possible-top-ids) 1) + (error (make-condition 'duplicate-identifier-error + :message (format nil "(length possible-items ~a) for id ~a and xtm-id ~a > 1" + possible-top-ids topic-id xtm-id) + :uri topic-id))) + (identified-construct (first possible-top-ids) + :revision revision) + ;no revision need not to be chaecked, since the revision + ;is implicitely checked by the function identified-construct + )) + (when (and (> (length topic-id) 0) + (eql (elt 0 topic-id) #\t) + (string-integer-p (subseq topic-id 1))) + (elephant::controller-recreate-instance elephant::*store-controller* (subseq topic-id 1)))))) + (if (and error-if-nil (not result)) + (error "No such item (id: ~a, tm: ~a, rev: ~a)" topic-id xtm-id revision) + result))) + + +(defun get-item-by-identifier (uri &key (revision 0) + (identifier-type-symbol 'PersistentIdC) + (error-if-nil nil)) + "Returns the construct that is bound to the given identifier-uri." + (declare (string uri) (integer revision) (symbol identifier-type-symbol)) + (let ((result + (let ((possible-ids + (delete-if-not + #'(lambda(id) + (string= (uri id) uri)) + (get-instances-by-class identifier-type-symbol)))) + (when (and possible-ids + (identified-construct (first possible-ids) :revision revision)) + (unless (= (length possible-ids) 1) + (error (make-condition 'duplicate-identifier-error + :message (format nil "(length possible-items ~a) for id ~a" + possible-ids uri) + :uri uri))) + (identified-construct (first possible-ids) + :revision revision))))) + ;no revision need not to be checked, since the revision + ;is implicitely checked by the function identified-construct + (if result + result + (when error-if-nil + (error "No such item is bound to the given identifier uri."))))) + + +(defun get-item-by-item-identifier (uri &key (revision 0) (error-if-nil nil)) + "Returns a ReifiableConstructC that is bound to the identifier-uri." + (get-item-by-identifier uri :revision revision + :identifier-type-symbol 'ItemIdentifierC + :error-if-nil error-if-nil)) + + +(defun get-item-by-psi (uri &key (revision 0) (error-if-nil nil)) + "Returns a TopicC that is bound to the identifier-uri." + (get-item-by-identifier uri :revision revision + :identifier-type-symbol 'PersistentIdC + :error-if-nil error-if-nil)) + + +(defun get-item-by-locator (uri &key (revision 0) (error-if-nil nil)) + "Returns a TopicC that is bound to the identifier-uri." + (get-item-by-identifier uri :revision revision + :identifier-type-symbol 'SubjectLocatorC + :error-if-nil error-if-nil)) + ;;; NameC (defgeneric variants (construct &key revision) Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Wed Feb 24 11:04:46 2010 @@ -1360,7 +1360,7 @@ (if (= revision 0) found-topic (find-item-by-revision found-topic revision))))) - (make-instance 'TopicC :from-oid (subseq topicid 1))))) + (elephant::controller-recreate-instance elephant:*store-controller* (subseq topicid 1))))) (if (and error-if-nil (not result)) (error (format nil "no such item (id: ~a, tm: ~a, rev: ~a)" topicid xtm-id revision)) result)))

1 0

[isidorus-cvs] r203 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 23 Feb '10

23 Feb '10

Author: lgiessmann Date: Tue Feb 23 14:49:01 2010 New Revision: 203 Log: new-datamode: added some unit-tests for TopicIdentificationC; fixed some bugs related to TopicIdentifiecationC 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 Feb 23 14:49:01 2010 @@ -773,26 +773,29 @@ (:method ((construct TopicC) (topic-identifier TopicIdentificationC) &key (revision *TM-REVISION*)) (let ((all-ids - (map 'list #'identifier - (remove-if #'marked-as-deleted-p - (slot-p construct 'topic-identifiers))))) - (cond ((find topic-identifier all-ids) + (map 'list #'identifier (slot-p construct 'topic-identifiers))) + (construct-to-be-merged + (let ((id-owner (identified-construct topic-identifier))) + (when (not (eql id-owner construct)) + id-owner)))) + (cond (construct-to-be-merged + (merge-constructs (identified-construct construct-to-be-merged + :revision revision) + construct)) + ((find topic-identifier all-ids) (let ((ti-assoc (loop for ti-assoc in (slot-p construct 'topic-identifiers) when (eql (identifier ti-assoc) topic-identifier) return ti-assoc))) (add-to-version-history ti-assoc :start-revision revision))) - (all-ids - (merge-constructs (identified-construct (first all-ids) - :revision revision) - construct)) (t - (make-instance 'TopicIdAssociationC - :start-revision revision - :parent-construct construct - :identifier topic-identifier) - construct))))) + (let ((assoc + (make-instance 'TopicIdAssociationC + :parent-construct construct + :identifier topic-identifier))) + (add-to-version-history assoc :start-revision revision)))) + construct))) (defgeneric delete-topic-identifier (construct topic-identifier &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 Tue Feb 23 14:49:01 2010 @@ -19,12 +19,14 @@ :test-VersionedConstructC :test-ItemIdentifierC :test-PersistentIdC - :test-SubjectLocatorC)) + :test-SubjectLocatorC + :test-TopicIdentificationC)) ;;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 @@ -246,10 +248,65 @@ (is-false (locators topic-1 :revision revision-3-5))))) +(test test-TopicIdentificationC () + "Tests various functions of the TopicIdentificationC class." + (with-fixture with-empty-db (*db-dir*) + (let ((ti-1 (make-instance 'TopicIdentificationC + :uri "ti-1" + :xtm-id "xtm-id-1")) + (ti-2 (make-instance 'TopicIdentificationC + :uri "ti-2" + :xtm-id "xtm-id-2")) + (topic-1 (make-instance 'TopicC)) + (revision-0 0) + (revision-1 100) + (revision-2 200) + (revision-3 300) + (revision-3-5 350) + (revision-4 400)) + (setf d:*TM-REVISION* revision-1) + (is-false (identified-construct ti-1)) + (signals error (make-instance 'TopicIdentificationC + :uri "ti-1")) + (signals error (make-instance 'TopicIdentificationC + :xtm-id "xtm-id-1")) + (is-false (topic-identifiers topic-1)) + (add-topic-identifier topic-1 ti-1) + (is (= (length (topic-identifiers topic-1)) 1)) + (is (eql (first (topic-identifiers topic-1)) ti-1)) + (is (eql (identified-construct ti-1) topic-1)) + (add-topic-identifier topic-1 ti-2 :revision revision-2) + (is (= (length (topic-identifiers topic-1 :revision revision-0)) 2)) + (is (= (length (topic-identifiers topic-1 :revision revision-1)) 1)) + (is (eql (first (topic-identifiers topic-1 :revision revision-1)) ti-1)) + (is (= (length (union (list ti-1 ti-2) + (topic-identifiers topic-1 :revision revision-2))) + 2)) + (is (= (length (union (list ti-1 ti-2) + (topic-identifiers topic-1 :revision revision-0))) + 2)) + (delete-topic-identifier topic-1 ti-1 :revision revision-3) + (is (= (length (union (list ti-2) + (topic-identifiers topic-1 :revision revision-0))) + 1)) + (is (= (length (union (list ti-1 ti-2) + (topic-identifiers topic-1 :revision revision-2))) + 2)) + (delete-topic-identifier topic-1 ti-2 :revision revision-3) + (is-false (topic-identifiers topic-1 :revision revision-3)) + (add-topic-identifier topic-1 ti-1 :revision revision-4) + (is (= (length (union (list ti-1) + (topic-identifiers topic-1 :revision revision-0))) + 1)) + (is (= (length (d::slot-p topic-1 'd::topic-identifiers)) 2)) + (is-false (topic-identifiers topic-1 :revision revision-3-5))))) + + (defun run-datamodel-tests() (it.bese.fiveam:run! 'test-VersionInfoC) (it.bese.fiveam:run! 'test-VersionedConstructC) (it.bese.fiveam:run! 'test-ItemIdentifierC) (it.bese.fiveam:run! 'test-PersistentIdC) (it.bese.fiveam:run! 'test-SubjectLocatorC) + (it.bese.fiveam:run! 'test-TopicIdentificationC) ) \ No newline at end of file

1 0

[isidorus-cvs] r202 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 23 Feb '10

23 Feb '10

Author: lgiessmann Date: Tue Feb 23 14:35:31 2010 New Revision: 202 Log: new-datamode: added some unit-tests for PersistentIdC and SubjectLocatorC; fixed some bugs related to PersistentIdC, SubjectLocatorC and TopicC 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 Feb 23 14:35:31 2010 @@ -87,6 +87,8 @@ (in-package :datamodel) +;;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 ;; after some data-operations are completed (should be passed as body) ;; and a merge should be done @@ -287,7 +289,7 @@ (psis :associate (PersistentIdAssociationC parent-construct) :documentation "Contains all association objects that relate a topic with its actual psis.") - (locators :associate (PersistentIdAssociationC parent-construct) + (locators :associate (SubjectLocatorAssociationC parent-construct) :documentation "Contains all association objects that relate a topic with its actual subject-lcoators.") (names :associate (NameAssociationC parent-construct) @@ -824,24 +826,27 @@ (:method ((construct TopicC) (psi PersistentIdC) &key (revision *TM-REVISION*)) (let ((all-ids - (map 'list #'identifier - (remove-if #'marked-as-deleted-p - (slot-p construct 'psis))))) - (cond ((find psi all-ids) + (map 'list #'identifier (slot-p construct 'psis))) + (construct-to-be-merged + (let ((id-owner (identified-construct psi))) + (when (not (eql id-owner construct)) + id-owner)))) + (cond (construct-to-be-merged + (merge-constructs (identified-construct construct-to-be-merged + :revision revision) + construct)) + ((find psi all-ids) (let ((psi-assoc (loop for psi-assoc in (slot-p construct 'psis) when (eql (identifier psi-assoc) psi) return psi-assoc))) (add-to-version-history psi-assoc :start-revision revision))) - (all-ids - (merge-constructs (identified-construct (first all-ids) - :revision revision) - construct)) (t - (make-instance 'PersistentIdAssociationC - :start-revision revision - :parent-construct construct - :identifier psi) - construct))))) + (let ((assoc + (make-instance 'PersistentIdAssociationC + :parent-construct construct + :identifier psi))) + (add-to-version-history assoc :start-revision revision)))) + construct))) (defgeneric delete-psi (construct psi &key revision) @@ -875,24 +880,27 @@ (:method ((construct TopicC) (locator SubjectLocatorC) &key (revision *TM-REVISION*)) (let ((all-ids - (map 'list #'identifier - (remove-if #'marked-as-deleted-p - (slot-p construct 'locators))))) - (cond ((find locator all-ids) + (map 'list #'identifier (slot-p construct 'locators))) + (construct-to-be-merged + (let ((id-owner (identified-construct locator))) + (when (not (eql id-owner construct)) + id-owner)))) + (cond (construct-to-be-merged + (merge-constructs (identified-construct construct-to-be-merged + :revision revision) + construct)) + ((find locator all-ids) (let ((loc-assoc (loop for loc-assoc in (slot-p construct 'locators) when (eql (identifier loc-assoc) locator) return loc-assoc))) (add-to-version-history loc-assoc :start-revision revision))) - (all-ids - (merge-constructs (identified-construct (first all-ids) - :revision revision) - construct)) (t - (make-instance 'SubjectLocatorAssociationC - :start-revision revision - :parent-construct construct - :identifier locator) - construct))))) + (let ((assoc + (make-instance 'SubjectLocatorAssociationC + :parent-construct construct + :identifier locator))) + (add-to-version-history assoc :start-revision revision)))) + construct))) (defgeneric delete-locator (construct locator &key revision) @@ -1513,16 +1521,16 @@ (let ((id-owner (identified-construct item-identifier))) (when (not (eql id-owner construct)) id-owner)))) - (cond ((find item-identifier all-ids) + (cond (construct-to-be-merged + (merge-constructs (identified-construct construct-to-be-merged + :revision revision) + construct)) + ((find item-identifier all-ids) (let ((ii-assoc (loop for ii-assoc in (slot-p construct 'item-identifiers) when (eql (identifier ii-assoc) item-identifier) return ii-assoc))) (add-to-version-history ii-assoc :start-revision revision))) - (construct-to-be-merged - (merge-constructs (identified-construct construct-to-be-merged - :revision revision) - construct)) (t (let ((assoc (make-instance 'ItemIdAssociationC 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 Feb 23 14:35:31 2010 @@ -17,7 +17,15 @@ (:export :run-datamodel-tests :test-VersionInfoC :test-VersionedConstructC - :test-ItemIdentifierC)) + :test-ItemIdentifierC + :test-PersistentIdC + :test-SubjectLocatorC)) + + +;;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 + (declaim (optimize (debug 3))) @@ -44,9 +52,7 @@ (is (= (d::end-revision vi-1) 300)) (is (= (d::start-revision vi-2) 300)) (is (= (d::end-revision vi-2) 0)) - (is-false (d::versioned-construct-p vi-1)) - (setf (d::versioned-construct vi-1) vc) - (is-true (d::versioned-construct-p vi-1))))) + (setf (d::versioned-construct vi-1) vc)))) (test test-VersionedConstructC () @@ -78,9 +84,6 @@ (= sr-2 100) (= er-2 500))))) (d::add-to-version-history vc :start-revision 600) (is (= (length (d::versions vc)) 3)) - (map 'list #'(lambda(vi) - (is-true (d::versioned-construct-p vi))) - (d::versions vc)) (d::add-to-version-history vc :start-revision 100 :end-revision 500) @@ -95,13 +98,13 @@ (test test-ItemIdentifierC () - "Tests various functions of the VersionedCoinstructC class." + "Tests various functions of the ItemIdentifierC class." (with-fixture with-empty-db (*db-dir*) - (let ((ii-1 (make-instance 'd:ItemIdentifierC + (let ((ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) - (ii-2 (make-instance 'd:ItemIdentifierC + (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2")) - (topic-1 (make-instance 'd:TopicC)) + (topic-1 (make-instance 'TopicC)) (revision-0 0) (revision-1 100) (revision-2 200) @@ -109,14 +112,14 @@ (revision-3-5 350) (revision-4 400)) (setf d:*TM-REVISION* revision-1) - (is-false (d:identified-construct ii-1)) - (signals error (make-instance 'd:ItemIdentifierC)) + (is-false (identified-construct ii-1)) + (signals error (make-instance 'ItemIdentifierC)) (is-false (item-identifiers topic-1)) - (d:add-item-identifier topic-1 ii-1) + (add-item-identifier topic-1 ii-1) (is (= (length (item-identifiers topic-1)) 1)) (is (eql (first (item-identifiers topic-1)) ii-1)) (is (eql (identified-construct ii-1) topic-1)) - (d:add-item-identifier topic-1 ii-2 :revision revision-2) + (add-item-identifier topic-1 ii-2 :revision revision-2) (is (= (length (item-identifiers topic-1 :revision revision-0)) 2)) (is (= (length (item-identifiers topic-1 :revision revision-1)) 1)) (is (eql (first (item-identifiers topic-1 :revision revision-1)) ii-1)) @@ -128,11 +131,11 @@ 2)) (delete-item-identifier topic-1 ii-1 :revision revision-3) (is (= (length (union (list ii-2) - (d:item-identifiers topic-1 + (item-identifiers topic-1 :revision revision-0))) 1)) (is (= (length (union (list ii-1 ii-2) - (d:item-identifiers topic-1 + (item-identifiers topic-1 :revision revision-2))) 2)) (delete-item-identifier topic-1 ii-2 :revision revision-3) @@ -143,10 +146,110 @@ 1)) (is (= (length (d::slot-p topic-1 'd::item-identifiers)) 2)) (is-false (item-identifiers topic-1 :revision revision-3-5))))) - + + +(test test-PersistentIdC () + "Tests various functions of the PersistentIdC class." + (with-fixture with-empty-db (*db-dir*) + (let ((psi-1 (make-instance 'PersistentIdC + :uri "psi-1")) + (psi-2 (make-instance 'PersistentIdC + :uri "psi-2")) + (topic-1 (make-instance 'TopicC)) + (revision-0 0) + (revision-1 100) + (revision-2 200) + (revision-3 300) + (revision-3-5 350) + (revision-4 400)) + (setf d:*TM-REVISION* revision-1) + (is-false (identified-construct psi-1)) + (signals error (make-instance 'PersistentIdC)) + (is-false (psis topic-1)) + (add-psi topic-1 psi-1) + (is (= (length (psis topic-1)) 1)) + (is (eql (first (psis topic-1)) psi-1)) + (is (eql (identified-construct psi-1) topic-1)) + (add-psi topic-1 psi-2 :revision revision-2) + (is (= (length (psis topic-1 :revision revision-0)) 2)) + (is (= (length (psis topic-1 :revision revision-1)) 1)) + (is (eql (first (psis topic-1 :revision revision-1)) psi-1)) + (is (= (length (union (list psi-1 psi-2) + (psis topic-1 :revision revision-2))) + 2)) + (is (= (length (union (list psi-1 psi-2) + (psis topic-1 :revision revision-0))) + 2)) + (delete-psi topic-1 psi-1 :revision revision-3) + (is (= (length (union (list psi-2) + (psis topic-1 :revision revision-0))) + 1)) + (is (= (length (union (list psi-1 psi-2) + (psis topic-1 :revision revision-2))) + 2)) + (delete-psi topic-1 psi-2 :revision revision-3) + (is-false (psis topic-1 :revision revision-3)) + (add-psi topic-1 psi-1 :revision revision-4) + (is (= (length (union (list psi-1) + (psis topic-1 :revision revision-0))) + 1)) + (is (= (length (d::slot-p topic-1 'd::psis)) 2)) + (is-false (psis topic-1 :revision revision-3-5))))) + + +(test test-SubjectLocatorC () + "Tests various functions of the SubjectLocatorC class." + (with-fixture with-empty-db (*db-dir*) + (let ((sl-1 (make-instance 'SubjectLocatorC + :uri "sl-1")) + (sl-2 (make-instance 'SubjectLocatorC + :uri "sl-2")) + (topic-1 (make-instance 'TopicC)) + (revision-0 0) + (revision-1 100) + (revision-2 200) + (revision-3 300) + (revision-3-5 350) + (revision-4 400)) + (setf d:*TM-REVISION* revision-1) + (is-false (identified-construct sl-1)) + (signals error (make-instance 'SubjectLocatorC)) + (is-false (locators topic-1)) + (add-locator topic-1 sl-1) + (is (= (length (locators topic-1)) 1)) + (is (eql (first (locators topic-1)) sl-1)) + (is (eql (identified-construct sl-1) topic-1)) + (add-locator topic-1 sl-2 :revision revision-2) + (is (= (length (locators topic-1 :revision revision-0)) 2)) + (is (= (length (locators topic-1 :revision revision-1)) 1)) + (is (eql (first (locators topic-1 :revision revision-1)) sl-1)) + (is (= (length (union (list sl-1 sl-2) + (locators topic-1 :revision revision-2))) + 2)) + (is (= (length (union (list sl-1 sl-2) + (locators topic-1 :revision revision-0))) + 2)) + (delete-locator topic-1 sl-1 :revision revision-3) + (is (= (length (union (list sl-2) + (locators topic-1 :revision revision-0))) + 1)) + (is (= (length (union (list sl-1 sl-2) + (locators topic-1 :revision revision-2))) + 2)) + (delete-locator topic-1 sl-2 :revision revision-3) + (is-false (locators topic-1 :revision revision-3)) + (add-locator topic-1 sl-1 :revision revision-4) + (is (= (length (union (list sl-1) + (locators topic-1 :revision revision-0))) + 1)) + (is (= (length (d::slot-p topic-1 'd::locators)) 2)) + (is-false (locators topic-1 :revision revision-3-5))))) + (defun run-datamodel-tests() (it.bese.fiveam:run! 'test-VersionInfoC) (it.bese.fiveam:run! 'test-VersionedConstructC) (it.bese.fiveam:run! 'test-ItemIdentifierC) + (it.bese.fiveam:run! 'test-PersistentIdC) + (it.bese.fiveam:run! 'test-SubjectLocatorC) ) \ No newline at end of file

1 0

[isidorus-cvs] r201 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 22 Feb '10

22 Feb '10

Author: lgiessmann Date: Mon Feb 22 14:55:40 2010 New Revision: 201 Log: new-datamodel: fixed some bugs in item-identifiers, add-item-identifier and delete-item-identifier; added a unit-test for item-identifiers 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 Mon Feb 22 14:55:40 2010 @@ -1508,17 +1508,19 @@ (:method ((construct ReifiableConstructC) (item-identifier ItemIdentifierC) &key (revision *TM-REVISION*)) (let ((all-ids - (map 'list #'identifier - (remove-if #'marked-as-deleted-p - (slot-p construct 'item-identifiers))))) + (map 'list #'identifier (slot-p construct 'item-identifiers))) + (construct-to-be-merged + (let ((id-owner (identified-construct item-identifier))) + (when (not (eql id-owner construct)) + id-owner)))) (cond ((find item-identifier all-ids) (let ((ii-assoc (loop for ii-assoc in (slot-p construct 'item-identifiers) when (eql (identifier ii-assoc) item-identifier) return ii-assoc))) (add-to-version-history ii-assoc :start-revision revision))) - (all-ids - (merge-constructs (identified-construct (first all-ids) + (construct-to-be-merged + (merge-constructs (identified-construct construct-to-be-merged :revision revision) construct)) (t 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 Mon Feb 22 14:55:40 2010 @@ -97,19 +97,52 @@ (test test-ItemIdentifierC () "Tests various functions of the VersionedCoinstructC class." (with-fixture with-empty-db (*db-dir*) - (setf d:*TM-REVISION* 100) (let ((ii-1 (make-instance 'd:ItemIdentifierC :uri "ii-1")) (ii-2 (make-instance 'd:ItemIdentifierC :uri "ii-2")) - (topic (make-instance 'd:TopicC))) + (topic-1 (make-instance 'd:TopicC)) + (revision-0 0) + (revision-1 100) + (revision-2 200) + (revision-3 300) + (revision-3-5 350) + (revision-4 400)) + (setf d:*TM-REVISION* revision-1) (is-false (d:identified-construct ii-1)) (signals error (make-instance 'd:ItemIdentifierC)) - (is-false (item-identifiers topic)) - (d:add-item-identifier topic ii-1) - (format t ">>> ~a~%" (d::parent-construct ii-1)) - (is (= (length (d:item-identifiers topic)) 1)) - ))) + (is-false (item-identifiers topic-1)) + (d:add-item-identifier topic-1 ii-1) + (is (= (length (item-identifiers topic-1)) 1)) + (is (eql (first (item-identifiers topic-1)) ii-1)) + (is (eql (identified-construct ii-1) topic-1)) + (d:add-item-identifier topic-1 ii-2 :revision revision-2) + (is (= (length (item-identifiers topic-1 :revision revision-0)) 2)) + (is (= (length (item-identifiers topic-1 :revision revision-1)) 1)) + (is (eql (first (item-identifiers topic-1 :revision revision-1)) ii-1)) + (is (= (length (union (list ii-1 ii-2) + (item-identifiers topic-1 :revision revision-2))) + 2)) + (is (= (length (union (list ii-1 ii-2) + (item-identifiers topic-1 :revision revision-0))) + 2)) + (delete-item-identifier topic-1 ii-1 :revision revision-3) + (is (= (length (union (list ii-2) + (d:item-identifiers topic-1 + :revision revision-0))) + 1)) + (is (= (length (union (list ii-1 ii-2) + (d:item-identifiers topic-1 + :revision revision-2))) + 2)) + (delete-item-identifier topic-1 ii-2 :revision revision-3) + (is-false (item-identifiers topic-1 :revision revision-3)) + (add-item-identifier topic-1 ii-1 :revision revision-4) + (is (= (length (union (list ii-1) + (item-identifiers topic-1 :revision revision-0))) + 1)) + (is (= (length (d::slot-p topic-1 'd::item-identifiers)) 2)) + (is-false (item-identifiers topic-1 :revision revision-3-5))))) (defun run-datamodel-tests()

1 0

[isidorus-cvs] r200 - branches/new-datamodel/src/model
by Lukas Giessmann 22 Feb '10

22 Feb '10

Author: lgiessmann Date: Mon Feb 22 14:05:06 2010 New Revision: 200 Log: new-datamode: fixed a problem with elephant-associaitons in the PointerAssociationC-classes 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 Mon Feb 22 14:05:06 2010 @@ -144,29 +144,56 @@ class."))) -;;; pointers ... -(defpclass SubjectLocatorC(IdentifierC) +;;; base classes ... +(defpclass TopicMapConstructC() () - (:index t) - (:documentation "A subject-locator that contains an uri-value and an - association to SubjectLocatorAssociationC's which are in - turn associated with TopicC's.")) + (:documentation "An abstract base class for all classes that describes + Topic Maps data.")) -(defpclass PersistentIdC(IdentifierC) - () - (:index t) - (:documentation "A subject-identifier that contains an uri-value and an - association to PersistentIdAssociationC's which are in - turn associated with TopicC's.")) +(defpclass ScopableC() + ((themes :associate (ScopeAssociationC scopable-construct) + :inherit t + :documentation "Contains all association-objects that contain the + actual scope-topics.")) + (:documentation "An abstract base class for all constructs that are scoped.")) -(defpclass ItemIdentifierC(IdentifierC) - () +(defpclass TypableC() + ((instance-of :associate (TypeAssociationC type-topic) + :inherit t + :documentation "Contains all association-objects that contain + the actual type-topic.")) + (:documentation "An abstract base class for all typed constructcs.")) + + +(defpclass DatatypableC() + ((datatype :accessor datatype + :initarg :datatype + :initform constants:*xml-string* + :type string + :documentation "The XML Schema datatype of the occurrencevalue + (optional, always IRI for resourceRef).")) (:index t) - (:documentation "An item-identifier that contains an uri-value and an - association to ItemIdAssociationC's which are in turn - associated with RiefiableConstructC's.")) + (:documentation "An abstract base class for characteristics that own + an xml-datatype.")) + + +;;; pointers ... +(defpclass PointerC(TopicMapConstructC) + ((uri :initarg :uri + :accessor uri + :inherit t + :type string + :initform (error "From PointerC(): uri must be set for a pointer") + :index t + :documentation "The actual value of a pointer, i.e. uri or ID.") + (identified-construct :associate (PointerAssociationC identifier) + :inherit t + :documentation "Associates a association-object that + additionally stores some + version-infos.")) + (:documentation "An abstract base class for all pointers.")) (defpclass IdentifierC(PointerC) @@ -187,23 +214,42 @@ representing one of them.")) -(defpclass PointerC(TopicMapConstructC) - ((uri :initarg :uri - :accessor uri - ;:inherit t - :type string - :initform (error "From PointerC(): uri must be set for a pointer") - :index t - :documentation "The actual value of a pointer, i.e. uri or ID.") - (identified-construct :associate (PointerAssociationC identifier) - :inherit t - :documentation "Associates a association-object that - additionally stores some - version-infos.")) - (:documentation "An abstract base class for all pointers.")) +(defpclass SubjectLocatorC(IdentifierC) + () + (:index t) + (:documentation "A subject-locator that contains an uri-value and an + association to SubjectLocatorAssociationC's which are in + turn associated with TopicC's.")) + + +(defpclass PersistentIdC(IdentifierC) + () + (:index t) + (:documentation "A subject-identifier that contains an uri-value and an + association to PersistentIdAssociationC's which are in + turn associated with TopicC's.")) + + +(defpclass ItemIdentifierC(IdentifierC) + () + (:index t) + (:documentation "An item-identifier that contains an uri-value and an + association to ItemIdAssociationC's which are in turn + associated with RiefiableConstructC's.")) ;;; reifiables ... +(defpclass ReifiableConstructC(TopicMapConstructC) + ((item-identifiers :associate (ItemIdAssociationC parent-construct) + :inherit t + :documentation "A relation to all item-identifiers of + this construct.") + (reifier :associate (ReifierAssociationC reified-construct) + :inherit t + :documentation "A relation to a reifier-topic.")) + (:documentation "Reifiable constructs as per TMDM.")) + + (defpclass AssociationC(ReifiableConstructC ScopableC TypableC) ((roles :associate (RoleAssociationC association) :documentation "Contains all association-objects of all roles this @@ -223,17 +269,6 @@ :documentation "Associates this object with a player-association."))) -(defpclass ReifiableConstructC(TopicMapConstructC) - ((item-identifiers :associate (ItemIdAssociationC parent-construct) - :inherit t - :documentation "A relation to all item-identifiers of - this construct.") - (reifier :associate (ReifierAssociationC reified-construct) - :inherit t - :documentation "A relation to a reifier-topic.")) - (:documentation "Reifiable constructs as per TMDM.")) - - (elephant:defpclass TopicMapC (ReifiableConstructC) ((topics :accessor topics :associate (TopicC in-topicmaps) @@ -284,6 +319,22 @@ ;;; characteristics ... +(defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC) + ((parent :associate (CharacteriticAssociationC characteristic) + :inherit t + :documentation "Assocates the characterist obejct with the + parent-association.") + (charvalue :initarg :charvalue + :accessor charvalue + :type string + :inherit t + :initform "" + :index t + :documentation "Contains the actual data of this object.")) + (:documentation "Scoped characteristic of a topic (meant to be used + as an abstract class).")) + + (defpclass OccurrenceC(CharacteristicC DatatypableC) () (:documentation "Represents a TM occurrence.")) @@ -300,23 +351,12 @@ (:documentation "Represents a TM variant.")) -(defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC) - ((parent :associate (CharacteriticAssociationC characteristic) - :inherit t - :documentation "Assocates the characterist obejct with the - parent-association.") - (charvalue :initarg :charvalue - :accessor charvalue - :type string - ;:inherit t - :initform "" - :index t - :documentation "Contains the actual data of this object.")) - (:documentation "Scoped characteristic of a topic (meant to be used - as an abstract class).")) +;;; versioned associations ... +(defpclass VersionedAssociationC(VersionedConstructC) + () + (:documentation "An abstract base class for all versioned associations.")) -;;; versioned associations ... (defpclass TypeAssociationC(VersionedAssociationC) ((type-topic :initarg :type-topic :accessor type-topic @@ -372,13 +412,19 @@ with a topic.")) -(defpclass VersionedAssociationC(VersionedConstructC) - () - (:documentation "An abstract base class for all versioned associations.")) - +;;; pointer associations ... +(defpclass PointerAssociationC (VersionedAssociationC) + ((identifier :initarg :identifier + :accessor identifier + :inherit t + :initform (error "From PointerAssociationC(): identifier must be set") + :associate PointerC + :documentation "The actual data that is associated with + the pointer-association's parent.")) + (:documentation "An abstract base class for all versioned + pointer-associations.")) -;;; pointer associations ... (defpclass SubjectLocatorAssociationC(PointerAssociationC) ((parent-construct :initarg :parent-construct :accessor parent-construct @@ -423,19 +469,19 @@ and reifiable-constructs.")) -(defpclass PointerAssociationC (VersionedAssociationC) - ((identifier :initarg :identifier - :accessor identifier - ;:inherit t - :initform (error "From PointerAssociationC(): identifier must be set") - :associate PointerC - :documentation "The actual data that is associated with - the pointer-association's parent.")) - (:documentation "An abstract base class for all versioned - pointer-associations.")) +;;; characteristic associations ... +(defpclass CharacteristicAssociationC(VersionedAssociationC) + ((characteristic :initarg :characteristic + :accessor characteristic + :inherit t + :initform (error "From CharacteristicCAssociation(): characteristic must be set") + :associate CharactersiticC + :documentation "Associates this object with the actual + characteristic object.")) + (:documentation "An abstract base class for all association-objects that + associates characteristics with topics.")) -;;; characteristic associations ... (defpclass VariantAssociationC(CharateristicAssociationC) ((parent-construct :initarg :parent-construct :accessor parent-construct @@ -466,18 +512,6 @@ Additionally version-infos are stored.")) -(defpclass CharacteristicAssociationC(VersionedAssociationC) - ((characteristic :initarg :characteristic - :accessor characteristic - ;:inherit t - :initform (error "From CharacteristicCAssociation(): characteristic must be set") - :associate CharactersiticC - :documentation "Associates this object with the actual - characteristic object.")) - (:documentation "An abstract base class for all association-objects that - associates characteristics with topics.")) - - ;;; roles/association associations ... (defpclass PlayerAssociationC(VersionedAssociationC) ((player-topic :initarg :player-topic @@ -511,48 +545,19 @@ version-infos between these realtions.")) -;;; base classes ... -(defpclass TopicMapConstructC() - () - (:documentation "An abstract base class for all classes that describes - Topic Maps data.")) - - -(defpclass ScopableC() - ((themes :associate (ScopeAssociationC scopable-construct) - :inherit t - :documentation "Contains all association-objects that contain the - actual scope-topics.")) - (:documentation "An abstract base class for all constructs that are scoped.")) - - -(defpclass TypableC() - ((instance-of :associate (TypeAssociationC type-topic) - :inherit t - :documentation "Contains all association-objects that contain - the actual type-topic.")) - (:documentation "An abstract base class for all typed constructcs.")) - - -(defpclass DatatypableC() - ((datatype :accessor datatype - :initarg :datatype - :initform constants:*xml-string* - :type string - :documentation "The XML Schema datatype of the occurrencevalue - (optional, always IRI for resourceRef).")) - (:index t) - (:documentation "An abstract base class for characteristics that own - an xml-datatype.")) - - ;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun slot-p (instance slot-symbol) "Returns t if the slot depending on slot-symbol is bound and not nil." - (when (slot-boundp instance slot-symbol) - (let ((value (slot-value instance slot-symbol))) - (when value - value)))) + (if (slot-boundp instance slot-symbol) + (let ((value (slot-value instance slot-symbol))) + (when value + value)) + ;elephant-relations are handled separately, since slot-boundp does not + ;here + (handler-case (let ((value (slot-value instance slot-symbol))) + (when value + value)) + (error () nil)))) (defun delete-1-n-association(instance slot-symbol) @@ -1517,10 +1522,11 @@ :revision revision) construct)) (t - (make-instance 'ItemIdAssociationC - :start-revision revision - :parent-construct construct - :identifier item-identifier))) + (let ((assoc + (make-instance 'ItemIdAssociationC + :parent-construct construct + :identifier item-identifier))) + (add-to-version-history assoc :start-revision revision)))) construct)))

1 0

[isidorus-cvs] r199 - in branches/new-datamodel: playground src/model
by Lukas Giessmann 21 Feb '10

21 Feb '10

Author: lgiessmann Date: Sun Feb 21 15:34:01 2010 New Revision: 199 Log: new-datamodel: added some example code files that analyses certain situations and elephant's behviour Added: branches/new-datamodel/playground/ branches/new-datamodel/playground/ii_versioned_association.lisp branches/new-datamodel/playground/system_crash.lisp branches/new-datamodel/playground/versioned-pointer.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp Added: branches/new-datamodel/playground/ii_versioned_association.lisp ============================================================================== --- (empty file) +++ branches/new-datamodel/playground/ii_versioned_association.lisp Sun Feb 21 15:34:01 2010 @@ -0,0 +1,117 @@ +(asdf:operate 'asdf:load-op 'elephant) +(use-package :elephant) + +(defpclass VersionInfoC() + ((start-revision :initarg :start-revision + :accessor start-revision + :type integer + :initform 0) + (end-revision :initarg :end-revision + :accessor end-revision + :type integer + :initform 0) + (versioned-construct :initarg :versioned-construct + :accessor versioned-construct + :associate VersionedConstructC))) + +(defpclass VersionedConstructC() + ((versions :initarg :versions + :accessor versions + :inherit t + :associate (VersionInfoC versioned-construct)))) + + +(defpclass VersionedAssociationC(VersionedConstructC) + ()) + + +(defpclass PointerAssociationC (VersionedAssociationC) + ((identifier :initarg :identifier + :accessor identifier + :inherit t + :initform (error "From PointerAssociationC(): identifier must be set") + :associate PointerC))) + + +(defpclass ItemIdAssociationC(PointerAssociationC) + ((parent-construct :initarg :parent-construct + :accessor parent-construct + :initform (error "From ItemIdAssociationC(): parent-construct must be set") + :associate ReifiableConstructC))) + + +(defpclass TopicMapConstructC() + ()) + + +(defpclass ReifiableConstructC(TopicMapConstructC) + ((item-identifiers :associate (ItemIdAssociationC parent-construct) + :inherit t))) + + +(defpclass PointerC(TopicMapConstructC) + ((uri :initarg :uri + :accessor uri + :inherit t + :type string + :initform (error "From PointerC(): uri must be set for a pointer") + :index t) + (identified-construct :associate (PointerAssociationC identifier) + :inherit t))) + + +(defpclass IdentifierC(PointerC) + ()) + + +(defpclass ItemIdentifierC(IdentifierC) + () + (:index t)) + + +(open-store '(:BDB "data_base")) +(defvar *p* (make-instance 'PointerC + :uri "anyUri")) +(defvar *pa* (make-instance 'PointerAssociationC + :identifier *p*)) + +(defvar *ii* (make-instance 'ItemIdentifierC + :uri "anyUri")) + +(defvar *pa-ii* (make-instance 'PointerAssociationC + :identifier *ii*)) + +(defvar *ii-2* (make-instance 'ItemIdentifierC + :uri "anyUri")) + +(defvar *rc* (make-instance 'ReifiableConstructC)) + + +(defvar *ia* (make-instance 'ItemIdAssociationC + :identifier *ii-2* + :parent-construct *rc*)) + + +(when (not (slot-value *p* 'identified-construct)) + (error ">> 1")) + +(when (not (slot-value *pa* 'identifier)) + (error ">> 2")) + +(when (not (slot-value *ii* 'identified-construct)) + (error ">> 3")) + +(when (not (slot-value *pa-ii* 'identifier)) + (error ">> 4")) + +(when (not (slot-value *ii-2* 'identified-construct)) + (error ">> 5")) + +(when (not (slot-value *rc* 'item-identifiers)) + (error ">> 6")) + +(when (not (slot-value *ia* 'parent-construct)) + (error ">> 7")) + +(when (not (slot-value *ia* 'identifier)) + (error ">> 8")) \ No newline at end of file Added: branches/new-datamodel/playground/system_crash.lisp ============================================================================== --- (empty file) +++ branches/new-datamodel/playground/system_crash.lisp Sun Feb 21 15:34:01 2010 @@ -0,0 +1,3 @@ +(sb-mop:class-slots (find-class 'd:ItemIdentifierC)) +(sb-mop:class-finalized-p (find-class 'd:ItemIdentifierC)) +(sb-mop:finalize-inheritance (find-class 'd:ItemIdentifierC)) Added: branches/new-datamodel/playground/versioned-pointer.lisp ============================================================================== --- (empty file) +++ branches/new-datamodel/playground/versioned-pointer.lisp Sun Feb 21 15:34:01 2010 @@ -0,0 +1,28 @@ +(asdf:operate 'asdf:load-op 'elephant) +(elephant:open-store '(:BDB "data_base")) +(defpclass Relation() + ((to-a :associate NodeA + :accessor to-a + :initarg :to-a) + (to-b :associate NodeB + :accessor to-b + :initarg :to-b) + (version :initarg :version + :accessor version + :type integer + :index t)) + (:index t)) +(defpclass NodeA() + ((relation-to-b :associate (Relation to-a) + :accessor relation-to-b + :initarg :relation-to-b)) + (:index t)) +(defpclass NodeB() + ((relation-to-a :associate (Relation to-b) + :accessor relation-to-a + :initarg :relation-to-a)) + (:index t)) +(defvar *rel* (make-instance 'Relation + :to-a (make-instance 'NodeA) + :to-b (make-instance 'NodeB) + :version 1)) Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Sun Feb 21 15:34:01 2010 @@ -190,7 +190,7 @@ (defpclass PointerC(TopicMapConstructC) ((uri :initarg :uri :accessor uri - :inherit t + ;:inherit t :type string :initform (error "From PointerC(): uri must be set for a pointer") :index t @@ -308,7 +308,7 @@ (charvalue :initarg :charvalue :accessor charvalue :type string - :inherit t + ;:inherit t :initform "" :index t :documentation "Contains the actual data of this object.")) @@ -426,7 +426,7 @@ (defpclass PointerAssociationC (VersionedAssociationC) ((identifier :initarg :identifier :accessor identifier - :inherit t + ;:inherit t :initform (error "From PointerAssociationC(): identifier must be set") :associate PointerC :documentation "The actual data that is associated with @@ -469,7 +469,7 @@ (defpclass CharacteristicAssociationC(VersionedAssociationC) ((characteristic :initarg :characteristic :accessor characteristic - :inherit t + ;:inherit t :initform (error "From CharacteristicCAssociation(): characteristic must be set") :associate CharactersiticC :documentation "Associates this object with the actual

1 0

[isidorus-cvs] r198 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 20 Feb '10

20 Feb '10

Author: lgiessmann Date: Sat Feb 20 09:49:30 2010 New Revision: 198 Log: new-datamodel: fixed some accessor/slot-names; restructured the file datamodel.lisp 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 20 09:49:30 2010 @@ -78,9 +78,11 @@ :mark-as-deleted-p :in-topicmaps :delete-construct + :get-revision ;;globals - :*TM-REVISION*)) + :*TM-REVISION* + :*CURRENT-XTM*)) (in-package :datamodel) @@ -89,7 +91,7 @@ ;; after some data-operations are completed (should be passed as body) ;; and a merge should be done ;;TODO: use some exceptions --> more than one type, -;; identifier, not-mergable merges, ... +;; identifier, not-mergable merges, missing-init-args... ;;TODO: implement make-construct -> symbol ;; replace the latest make-construct-method ;;TODO: implement merge-construct -> ReifiableConstructC -> ... @@ -103,6 +105,447 @@ (defvar *TM-REVISION* 0) +(defparameter *CURRENT-XTM* nil "Represents the currently active TM.") + + +;;; classes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; versioning +(defpclass VersionInfoC() + ((start-revision :initarg :start-revision + :accessor start-revision + :type integer + :initform 0 + :documentation "The start-revision of the version's + interval of a versioned object.") + (end-revision :initarg :end-revision + :accessor end-revision + :type integer + :initform 0 + :documentation "The end-revision of the version's interval + of a versioned object.") + (versioned-construct :initarg :versioned-construct + :accessor versioned-construct + :associate VersionedConstructC + :documentation "The reference of the versioned + object that is described by this + VersionInfoC-object.")) + (:documentation "A VersionInfoC-object describes the revision information + of a versioned object in intervals starting by the value + start-revision and ending by the value end-revision - 1. + end-revision=0 means always the latest version.")) + + +(defpclass VersionedConstructC() + ((versions :initarg :versions + :accessor versions + :inherit t + :associate (VersionInfoC versioned-construct) + :documentation "Version infos for former versions of this base + class."))) + + +;;; pointers ... +(defpclass SubjectLocatorC(IdentifierC) + () + (:index t) + (:documentation "A subject-locator that contains an uri-value and an + association to SubjectLocatorAssociationC's which are in + turn associated with TopicC's.")) + + +(defpclass PersistentIdC(IdentifierC) + () + (:index t) + (:documentation "A subject-identifier that contains an uri-value and an + association to PersistentIdAssociationC's which are in + turn associated with TopicC's.")) + + +(defpclass ItemIdentifierC(IdentifierC) + () + (:index t) + (:documentation "An item-identifier that contains an uri-value and an + association to ItemIdAssociationC's which are in turn + associated with RiefiableConstructC's.")) + + +(defpclass IdentifierC(PointerC) + () + (:documentation "An abstract base class for all TM-Identifiers.")) + + +(defpclass TopicIdentificationC(PointerC) + ((xtm-id :initarg :xtm-id + :accessor xtm-id + :type string + :initform (error "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier") + :index t + :documentation "ID of the TM this identification came from.")) + (:index t) + (:documentation "Identify topic items through generalized topic-ids. + A topic may have many original topicids, the class + representing one of them.")) + + +(defpclass PointerC(TopicMapConstructC) + ((uri :initarg :uri + :accessor uri + :inherit t + :type string + :initform (error "From PointerC(): uri must be set for a pointer") + :index t + :documentation "The actual value of a pointer, i.e. uri or ID.") + (identified-construct :associate (PointerAssociationC identifier) + :inherit t + :documentation "Associates a association-object that + additionally stores some + version-infos.")) + (:documentation "An abstract base class for all pointers.")) + + +;;; reifiables ... +(defpclass AssociationC(ReifiableConstructC ScopableC TypableC) + ((roles :associate (RoleAssociationC association) + :documentation "Contains all association-objects of all roles this + association contains.") + (in-topicmaps :associate (TopicMapC associations) + :many-to-many t + :documentation "List of all topic maps this association is + part of")) + (:index t) + (:documentation "Association in a Topic Map")) + + +(defpclass RoleC(ReifiableConstructC TypableC) + ((parent :associate (RoleAssociationC role) + :documentation "Associates this object with a role-association.") + (player :associate (PlayerAssociationC parent-construct) + :documentation "Associates this object with a player-association."))) + + +(defpclass ReifiableConstructC(TopicMapConstructC) + ((item-identifiers :associate (ItemIdAssociationC parent-construct) + :inherit t + :documentation "A relation to all item-identifiers of + this construct.") + (reifier :associate (ReifierAssociationC reified-construct) + :inherit t + :documentation "A relation to a reifier-topic.")) + (:documentation "Reifiable constructs as per TMDM.")) + + +(elephant:defpclass TopicMapC (ReifiableConstructC) + ((topics :accessor topics + :associate (TopicC in-topicmaps) + :documentation "List of topics that explicitly belong to this TM.") + (associations :accessor associations + :associate (AssociationC in-topicmaps) + :documentation "List of associations that belong to this TM.")) + (:documentation "Represnets a topic map.")) + + +(defpclass TopicC (ReifiableConstructC) + ((topic-identifiers :associate (TopicIdAssociationC parent-construct) + :documentation "Contains all association objects that + relate a topic with its actual + topic-identifiers.") + (psis :associate (PersistentIdAssociationC parent-construct) + :documentation "Contains all association objects that relate a topic + with its actual psis.") + (locators :associate (PersistentIdAssociationC parent-construct) + :documentation "Contains all association objects that relate a + topic with its actual subject-lcoators.") + (names :associate (NameAssociationC parent-construct) + :documentation "Contains all association objects that relate a topic + with its actual names.") + (occurrences :associate (OccurrenceAssociationC parent-construct) + :documentation "Contains all association objects that relate a + topic with its actual occurrences.") + (player-in-roles :associate (PlayerAssociationC player-topic) + :documentation "Contains all association objects that relate + a topic that is a player with its role.") + (used-as-type :associate (TypeAssociationC type-topic) + :documentation "Contains all association objects that relate a + topic that is a type with its typable obejct.") + (used-as-theme :associate (ScopeAssociationC theme-topic) + :documentation "Contains all association objects that relate a + topic that is a theme with its scoppable + object.") + (reified-construct :associate (ReifiedAssociationC reifier-topic) + :documentation "Contains all association objects that + relate a topic that is a reifier with + its reified object.") + (in-topicmaps :associate (TopicMapC topics) + :many-to-many t + :documentation "List of all topic maps this topic is part of.")) + (:index t) + (:documentation "Represents a TM topic.")) + + + +;;; characteristics ... +(defpclass OccurrenceC(CharacteristicC DatatypableC) + () + (:documentation "Represents a TM occurrence.")) + + +(defpclass NameC(CharacteristicC) + ((variants :associate (VariantAssociationC parent-construct) + :documentation "Associates this obejct with varian-associations.")) + (:documentation "Scoped name of a topic.")) + + +(defpclass VariantC(CharacteristicC DatatypableC) + () + (:documentation "Represents a TM variant.")) + + +(defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC) + ((parent :associate (CharacteriticAssociationC characteristic) + :inherit t + :documentation "Assocates the characterist obejct with the + parent-association.") + (charvalue :initarg :charvalue + :accessor charvalue + :type string + :inherit t + :initform "" + :index t + :documentation "Contains the actual data of this object.")) + (:documentation "Scoped characteristic of a topic (meant to be used + as an abstract class).")) + + +;;; versioned associations ... +(defpclass TypeAssociationC(VersionedAssociationC) + ((type-topic :initarg :type-topic + :accessor type-topic + :initform (error "From TypeAssociationC(): type-topic must be set") + :associate TopicC + :documentation "Associates this object with a topic that is used + as type.") + (typable-construct :initarg :typable-construct + :accessor typable-construct + :initform (error "From TypeAssociationC(): typable-construct must be set") + :associate TypableC + :documentation "Associates this object with the typable + construct that is typed by the + type-topic.")) + (:documentation "This class associates topics that are used as type for + typable constructcs. Additionally there are stored some + version-infos.")) + + +(defpclass ScopeAssociationC(VersionedAssociationC) + ((theme-topic :initarg :theme-topic + :accessor theme-topic + :initform (error "From ScopeAssociationC(): theme-topic must be set") + :associate TopicC + :documentation "Associates this opbject with a topic that is a + scopable construct.") + (scopable-construct :initarg :scopable-construct + :accessor scopable-construct + :initform (error "From ScopeAssociationC(): scopable-construct must be set") + :associate ScopableC + :documentation "Associates this object with the socpable + construct that is scoped by the + scope-topic.")) + (:documentation "This class associates topics that are used as scope with + scopable construtcs. Additionally there are stored some + version-infos")) + + +(defpclass ReifierAssociationC(VersionedAssociationC) + ((reifiable-construct :initarg :reifiable-construct + :accessor reifiable-construct + :initform (error "From ReifierAssociation(): reifiable-construct must be set") + :associate ReifiableConstructC + :documentation "The actual construct which is reified + by a topic.") + (reifier-topic :initarg :reifier-topic + :accessor reifier-topic + :initform (error "From ReifierAssociationC(): reifier-topic must be set") + :associate TopicC + :documentation "The reifier-topic that reifies the + reifiable-construct.")) + (:documentation "A versioned-association that relates a reifiable-construct + with a topic.")) + + +(defpclass VersionedAssociationC(VersionedConstructC) + () + (:documentation "An abstract base class for all versioned associations.")) + + + +;;; pointer associations ... +(defpclass SubjectLocatorAssociationC(PointerAssociationC) + ((parent-construct :initarg :parent-construct + :accessor parent-construct + :initform (error "From SubjectLocatorAssociationC(): parent-construct must be set") + :associate TopicC + :documentation "The actual topic which is associated + with the subject-locator.")) + (:documentation "A pointer that associates subject-locators, versions + and topics.")) + + +(defpclass PersistentIdAssociationC(PointerAssociationC) + ((parent-construct :initarg :parent-construct + :accessor parent-construct + :initform (error "From PersistentIdAssociationC(): parent-construct must be set") + :associate TopicC + :documentation "The actual topic which is associated + with the subject-identifier/psi.")) + (:documentation "A pointer that associates subject-identifiers, versions + and topics.")) + + +(defpclass TopicIdAssociationC(PointerAssociationC) + ((parent-construct :initarg :parent-construct + :accessor parent-construct + :initform (error "From TopicIdAssociationC(): parent-construct must be set") + :associate TopicC + :documentation "The actual topic which is associated + with the topic-identifier.")) + (:documentation "A pointer that associates topic-identifiers, versions + and topics.")) + + +(defpclass ItemIdAssociationC(PointerAssociationC) + ((parent-construct :initarg :parent-construct + :accessor parent-construct + :initform (error "From ItemIdAssociationC(): parent-construct must be set") + :associate ReifiableConstructC + :documentation "The actual parent which is associated + with the item-identifier.")) + (:documentation "A pointer that associates item-identifiers, versions + and reifiable-constructs.")) + + +(defpclass PointerAssociationC (VersionedAssociationC) + ((identifier :initarg :identifier + :accessor identifier + :inherit t + :initform (error "From PointerAssociationC(): identifier must be set") + :associate PointerC + :documentation "The actual data that is associated with + the pointer-association's parent.")) + (:documentation "An abstract base class for all versioned + pointer-associations.")) + + +;;; characteristic associations ... +(defpclass VariantAssociationC(CharateristicAssociationC) + ((parent-construct :initarg :parent-construct + :accessor parent-construct + :initform (error "From VariantAssociationC(): parent-construct must be set") + :associate NameC + :documentation "Associates this object with a name.")) + (:documentation "Associates variant objects with name obejcts. + Additionally version-infos are stored.")) + + +(defpclass NameAssociationC(CharacteristicAssociationC) + ((parent-construct :initarg :parent-construct + :accessor parent-construct + :initform (error "From NameAssociationC(): parent-construct must be set") + :associate TopicC + :documentation "Associates this object with a topic.")) + (:documentation "Associates name objects with their parent topics. + Additionally version-infos are stored.")) + + +(defpclass OccurrenceAssociationC(CharacteristicAssociationC) + ((parent-construct :initarg :parent-construct + :accessor parent-construct + :initform (error "From OccurrenceAssociationC(): parent-construct must be set") + :associate TopicC + :documentation "Associates this object with a topic.")) + (:documentation "Associates occurrence objects with their parent topics. + Additionally version-infos are stored.")) + + +(defpclass CharacteristicAssociationC(VersionedAssociationC) + ((characteristic :initarg :characteristic + :accessor characteristic + :inherit t + :initform (error "From CharacteristicCAssociation(): characteristic must be set") + :associate CharactersiticC + :documentation "Associates this object with the actual + characteristic object.")) + (:documentation "An abstract base class for all association-objects that + associates characteristics with topics.")) + + +;;; roles/association associations ... +(defpclass PlayerAssociationC(VersionedAssociationC) + ((player-topic :initarg :player-topic + :accessor player-topic + :associate TopicC + :initform (error "From PlayerAssociationC(): player-topic must be set") + :documentation "Associates this object with a topic that is + a player.") + (parent-construct :initarg :parent-construct + :accessor parent-construct + :associate RoleC + :initform (error "From PlayerAssociationC(): parent-construct must be set") + :documentation "Associates this object with the parent-association.")) + (:documentation "This class associates roles and their player in given + revisions.")) + + +(defpclass RoleAssociationC(VersionedAssociationC) + ((role :initarg :role + :accessor role + :associate RoleC + :initform (error "From RoleAssociationC(): role must be set") + :documentation "Associates this objetc with a role-object.") + (parent-construct :initarg :parent-construct + :accessor parent-construct + :associate AssociationC + :initform (error "From RoleAssociationC(): parent-construct must be set") + :documentation "Assocates thius object with an + association-object.")) + (:documentation "Associates roles with assoications and adds some + version-infos between these realtions.")) + + +;;; base classes ... +(defpclass TopicMapConstructC() + () + (:documentation "An abstract base class for all classes that describes + Topic Maps data.")) + + +(defpclass ScopableC() + ((themes :associate (ScopeAssociationC scopable-construct) + :inherit t + :documentation "Contains all association-objects that contain the + actual scope-topics.")) + (:documentation "An abstract base class for all constructs that are scoped.")) + + +(defpclass TypableC() + ((instance-of :associate (TypeAssociationC type-topic) + :inherit t + :documentation "Contains all association-objects that contain + the actual type-topic.")) + (:documentation "An abstract base class for all typed constructcs.")) + + +(defpclass DatatypableC() + ((datatype :accessor datatype + :initarg :datatype + :initform constants:*xml-string* + :type string + :documentation "The XML Schema datatype of the occurrencevalue + (optional, always IRI for resourceRef).")) + (:index t) + (:documentation "An abstract base class for characteristics that own + an xml-datatype.")) + + ;;; some helpers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun slot-p (instance slot-symbol) "Returns t if the slot depending on slot-symbol is bound and not nil." @@ -154,46 +597,18 @@ properties)))))) -;;; VersionInfoC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defpclass VersionInfoC() - ((start-revision :initarg :start-revision - :accessor start-revision - :type integer - :initform 0 - :documentation "The start-revision of the version's - interval of a versioned object.") - (end-revision :initarg :end-revision - :accessor end-revision - :type integer - :initform 0 - :documentation "The end-revision of the version's interval - of a versioned object.") - (versioned-construct :initarg :versioned-construct - :accessor versioned-construct - :associate VersionedConstructC - :documentation "The reference of the versioned - object that is described by this - VersionInfoC-object.")) - (:documentation "A VersionInfoC-object describes the revision information - of a versioned object in intervals starting by the value - start-revision and ending by the value end-revision - 1. - end-revision=0 means always the latest version.")) +(defun get-revision () + "TODO: replace by something that does not suffer from a 1 second resolution." + (get-universal-time)) +;;; generic functions/accessors ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; VersionInfocC (defmethod delete-construct :before ((version-info VersionInfoC)) (delete-1-n-association version-info 'versioned-construct)) -;;; VersionedConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defpclass VersionedConstructC() - ((versions :initarg :versions - :accessor versions - :inherit t - :associate (VersionInfoC versioned-construct) - :documentation "Version infos for former versions of this base - class."))) - - +;;; VersionedConstructC (defmethod delete-construct :before ((construct VersionedConstructC)) (dolist (version-info (versions construct)) (delete-construct version-info))) @@ -303,80 +718,7 @@ (setf (end-revision last-version) revision)))) -;;; TopicMapC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(elephant:defpclass TopicMapC (ReifiableConstructC) - ((topics :accessor topics - :associate (TopicC in-topicmaps) - :documentation "List of topics that explicitly belong to this TM.") - (associations :accessor associations - :associate (AssociationC in-topicmaps) - :documentation "List of associations that belong to this TM.")) - (:documentation "Represnets a topic map.")) - - -;;; Pointers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; SubjectLocatorC -;;; PersistentIdC -;;; ItemIdentifierC -;;; IdentifierC -;;; TopicIdentificationC ;;; PointerC -(defpclass SubjectLocatorC(IdentifierC) - () - (:index t) - (:documentation "A subject-locator that contains an uri-value and an - association to SubjectLocatorAssociationC's which are in - turn associated with TopicC's.")) - - -(defpclass PersistentIdC(IdentifierC) - () - (:index t) - (:documentation "A subject-identifier that contains an uri-value and an - association to PersistentIdAssociationC's which are in - turn associated with TopicC's.")) - - -(defpclass ItemIdentifierC(IdentifierC) - () - (:index t) - (:documentation "An item-identifier that contains an uri-value and an - association to ItemIdAssociationC's which are in turn - associated with RiefiableConstructC's.")) - - -(defpclass IdentifierC(PointerC) - () - (:documentation "An abstract base class for all TM-Identifiers.")) - - -(defpclass TopicIdentificationC(PointerC) - ((xtm-id :initarg :xtm-id - :accessor xtm-id - :type string - :initform (error "From TopicIdentificationC(): xtm-id must be seet for a topic-identifier") - :index t - :documentation "ID of the TM this identification came from.")) - (:index t) - (:documentation "Identify topic items through generalized topic-ids. - A topic may have many original topicids, the class - representing one of them.")) - - -(defpclass PointerC(TopicMapConstructC) - ((uri :initarg :uri - :accessor uri - :inherit t - :type string - :initform (error "From PointerC(): uri must be set for a pointer") - :index t - :documentation "The actual value of a pointer, i.e. uri or ID.") - (identified-construct :initarg :identified-construct - :associate (PointerAssociationC identifier) - :inherit t)) - (:documentation "An abstract base class for all pointers.")) - - (defgeneric identified-construct (construct &key revision) (:documentation "Returns the identified-construct -> ReifiableConstructC or TopicC that corresponds with the passed revision.") @@ -389,77 +731,7 @@ (first assocs))))) -;;; TopicC + Characterics ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defpclass TopicC (ReifiableConstructC) - ((topic-identifiers :associate (TopicIdAssociationC parent-construct) - :documentation "Contains all association objects that - relate a topic with its actual - topic-identifiers.") - (psis :associate (PersistentIdAssociationC parent-construct) - :documentation "Contains all association objects that relate a topic - with its actual psis.") - (locators :associate (PersistentIdAssociationC parent-construct) - :documentation "Contains all association objects that relate a - topic with its actual subject-lcoators.") - (names :associate (NameAssociationC parent-construct) - :documentation "Contains all association objects that relate a topic - with its actual names.") - (occurrences :associate (OccurrenceAssociationC parent-construct) - :documentation "Contains all association objects that relate a - topic with its actual occurrences.") - (player-in-roles :associate (PlayerAssociationC player-topic) - :documentation "Contains all association objects that relate - a topic that is a player with its role.") - (used-as-type :associate (TypeAssociationC type-topic) - :documentation "Contains all association objects that relate a - topic that is a type with its typable obejct.") - (used-as-theme :associate (ScopeAssociationC theme-topic) - :documentation "Contains all association objects that relate a - topic that is a theme with its scoppable - object.") - (reified-construct :associate (ReifiedAssociationC reifier-topic) - :documentation "Contains all association objects that - relate a topic that is a reifier with - its reified object.") - (in-topicmaps :associate (TopicMapC topics) - :many-to-many t - :documentation "List of all topic maps this topic is part of.")) - (:index t) - (:documentation "Represents a TM topic.")) - - -(defpclass OccurrenceC(CharacteristicC DatatypableC) - () - (:documentation "Represents a TM occurrence.")) - - -(defpclass NameC(CharacteristicC) - ((variants :associate (VariantAssociationC parent-construct) - :documentation "Associates this obejct with varian-associations.")) - (:documentation "Scoped name of a topic.")) - - -(defpclass VariantC(CharacteristicC DatatypableC) - () - (:documentation "Represents a TM variant.")) - - -(defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC) - ((parent :associate (CharacteriticAssociationC characteristic) - :inherit t - :documentation "Assocates the characterist obejct with the - parent-association.") - (charvalue :initarg :charvalue - :accessor charvalue - :type string - :inherit t - :initform "" - :index t - :documentation "Contains the actual data of this object.")) - (:documentation "Scoped characteristic of a topic (meant to be used - as an abstract class).")) - - +;;; TopicC (defmethod delete-construct :before ((construct TopicC)) "Deletes all association objects of the passed construct." (dolist (assoc (append (slot-p construct 'topic-identifiers) @@ -509,10 +781,10 @@ :revision revision) construct)) (t - (make-construct 'TopicIdAssociationC - :start-revision revision - :parent-construct construct - :identifier topic-identifier) + (make-instance 'TopicIdAssociationC + :start-revision revision + :parent-construct construct + :identifier topic-identifier) construct))))) @@ -560,10 +832,10 @@ :revision revision) construct)) (t - (make-construct 'PersistentIdAssociationC - :start-revision revision - :parent-construct construct - :identifier psi) + (make-instance 'PersistentIdAssociationC + :start-revision revision + :parent-construct construct + :identifier psi) construct))))) @@ -611,10 +883,10 @@ :revision revision) construct)) (t - (make-construct 'SubjectLocatorAssociationC - :start-revision revision - :parent-construct construct - :identifier locator) + (make-instance 'SubjectLocatorAssociationC + :start-revision revision + :parent-construct construct + :identifier locator) construct))))) @@ -660,10 +932,10 @@ when (eql (parent-construct name-assoc) name) return name-assoc))) (add-to-version-history name-assoc :start-revision revision)) - (make-construct 'NameAssociationC - :start-revision revision - :parent-construct construct - :characteristic name)) + (make-instance 'NameAssociationC + :start-revision revision + :parent-construct construct + :characteristic name)) construct))) @@ -709,10 +981,10 @@ when (eql (parent-construct occ-assoc) occurrence) return occ-assoc))) (add-to-version-history occ-assoc :start-revision revision)) - (make-construct 'OccurrenceAssociationC - :start-revision revision - :parent-construct construct - :characteristic occurrence)) + (make-instance 'OccurrenceAssociationC + :start-revision revision + :parent-construct construct + :characteristic occurrence)) construct))) @@ -773,6 +1045,8 @@ (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision)) + +;;; NameC (defgeneric variants (construct &key revision) (:documentation "Returns all variants that correspond with the given revision and that are associated with the passed construct.") @@ -786,7 +1060,7 @@ (defgeneric add-variant (construct variant &key revision) (:documentation "Adds the given theme-topic to the passed scopable-construct.") - (:method ((construct ScopableC) (variant VariantC) + (:method ((construct NameC) (variant VariantC) &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" @@ -822,6 +1096,7 @@ construct))) +;;; CharacteristicC (defmethod delete-construct :before ((construct CharacteristicC)) "Deletes all association-obejcts." (dolist (parent-assoc (slot-p construct 'parent)) @@ -923,66 +1198,20 @@ (let ((assoc-to-delete (loop for parent-assoc in (slot-p construct 'parent) when (eql (characteristic parent-assoc) parent-construct) - return parent-assoc))) - (when assoc-to-delete - (mark-as-deleted assoc-to-delete :revision revision)) - construct)) - - -;;; Versioned-Associations ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; PlayerAssociationC -;;; RoleAssociationC -;;; VariantAssociationC -;;; NameAssociationC -;;; OccurrenceAssociationC -;;; CharacteristicAssociationC -;;; TypeAssociationC -;;; ScopeAssociationC -;;; ReifierAssociationC -;;; SubjectLocatorAssociationC -;;; PersistentIdAssociationC -;;; TopicIdAssociationC -;;; ItemIdAssociationC -;;; PointerAssociationC -;;; VersionedAssociationC -(defpclass PlayerAssociationC(VersionedAssociationC) - ((player-topic :initarg :player-topic - :accessor player-topic - :associate TopicC - :initform (error "From PlayerAssociationC(): player-topic must be set") - :documentation "Associates this object with a topic that is - a player.") - (parent-construct :initarg :parent-construct - :accessor parent-construct - :associate RoleC - :initform (error "From PlayerAssociationC(): parent-construct must be set") - :documentation "Associates this object with the parent-association.")) - (:documentation "This class associates roles and their player in given - revisions.")) + return parent-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision)) + 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)) -(defpclass RoleAssociationC(VersionedAssociationC) - ((role :initarg :role - :accessor role - :associate RoleC - :initform (error "From RoleAssociationC(): role must be set") - :documentation "Associates this objetc with a role-object.") - (parent-construct :initarg :parent-construct - :accessor parent-construct - :associate AssociationC - :initform (error "From RoleAssociationC(): parent-construct must be set") - :documentation "Assocates thius object with an - association-object.")) - (:documentation "Associates roles with assoications and adds some - version-infos between these realtions.")) - - +;;; RoleAssociationC (defmethod delete-construct :before ((construct RoleAssociationC)) "Deletes all elephant-associations and the entire role if it is not associated with another AssociationC object." @@ -993,60 +1222,22 @@ (delete-1-n-association construct 'parent-construct))) -(defpclass VariantAssociationC(CharateristicAssociationC) - ((parent-construct :initarg :parent-construct - :accessor parent-construct - :initform (error "From VariantAssociationC(): parent-construct must be set") - :associate NameC - :documentation "Associates this object with a name.")) - (:documentation "Associates variant objects with name obejcts. - Additionally version-infos are stored.")) - - +;;; VariantAssociationC (defmethod delete-construct :before ((construct VariantAssociationC)) (delete-1-n-association construct 'parent-construct)) -(defpclass NameAssociationC(CharacteristicAssociationC) - ((parent-construct :initarg :parent-construct - :accessor parent-construct - :initform (error "From NameAssociationC(): parent-construct must be set") - :associate TopicC - :documentation "Associates this object with a topic.")) - (:documentation "Associates name objects with their parent topics. - Additionally version-infos are stored.")) - - +;;; NameAssociationC (defmethod delete-construct :before ((construct NameAssociationC)) (delete-1-n-association construct 'parent-construct)) -(defpclass OccurrenceAssociationC(CharacteristicAssociationC) - ((parent-construct :initarg :parent-construct - :accessor parent-construct - :initform (error "From OccurrenceAssociationC(): parent-construct must be set") - :associate TopicC - :documentation "Associates this object with a topic.")) - (:documentation "Associates occurrence objects with their parent topics. - Additionally version-infos are stored.")) - - +;;; OccurrenceAssociationC (defmethod delete-construct :before ((construct OccurrenceAssociationC)) (delete-1-n-association construct 'parent-construct)) -(defpclass CharacteristicAssociationC(VersionedAssociationC) - ((characteristic :initarg :characteristic - :accessor characteristic - :inherit t - :initform (error "From CharacteristicCAssociation(): characteristic must be set") - :associate CharactersiticC - :documentation "Associates this object with the actual - characteristic object.")) - (:documentation "An abstract base class for all association-objects that - associates characteristics with topics.")) - - +;;; CharacteristicAssociationC (defmethod delete-construct :before ((construct CharacteristicAssociationC)) "Deletes all elephant-associations." (let ((characteristic (characteristic construct))) @@ -1056,73 +1247,21 @@ (delete-construct characteristic)))) -(defpclass TypeAssociationC(VersionedAssociationC) - ((type-topic :initarg :type-topic - :accessor type-topic - :initform (error "From TypeAssociationC(): type-topic must be set") - :associate TopicC - :documentation "Associates this object with a topic that is used - as type.") - (typable-construct :initarg :typable-construct - :accessor typable-construct - :initform (error "From TypeAssociationC(): typable-construct must be set") - :associate TypableC - :documentation "Associates this object with the typable - construct that is typed by the - type-topic.")) - (:documentation "This class associates topics that are used as type for - typable constructcs. Additionally there are stored some - version-infos.")) - - +;;; 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)) -(defpclass ScopeAssociationC(VersionedAssociationC) - ((theme-topic :initarg :theme-topic - :accessor theme-topic - :initform (error "From ScopeAssociationC(): theme-topic must be set") - :associate TopicC - :documentation "Associates this opbject with a topic that is a - scopable construct.") - (scopable-construct :initarg :scopable-construct - :accessor scopable-construct - :initform (error "From ScopeAssociationC(): scopable-construct must be set") - :associate ScopableC - :documentation "Associates this object with the socpable - construct that is scoped by the - scope-topic.")) - (:documentation "This class associates topics that are used as scope with - scopable construtcs. Additionally there are stored some - version-infos")) - - +;;; 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)) -(defpclass ReifierAssociationC(VersionedAssociationC) - ((reifiable-construct :initarg :reifiable-construct - :accessor reifiable-construct - :initform (error "From ReifierAssociation(): reifiable-construct must be set") - :associate ReifiableConstructC - :documentation "The actual construct which is reified - by a topic.") - (reifier-topic :initarg :reifier-topic - :accessor reifier-topic - :initform (error "From ReifierAssociationC(): reifier-topic must be set") - :associate TopicC - :documentation "The reifier-topic that reifies the - reifiable-construct.")) - (:documentation "A versioned-association that relates a reifiable-construct - with a 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." @@ -1133,78 +1272,27 @@ (delete-construct reifier-top)))) -(defpclass SubjectLocatorAssociationC(PointerAssociationC) - ((parent-construct :initarg :parent-construct - :accessor parent-construct - :initform (error "From SubjectLocatorAssociationC(): parent-construct must be set") - :associate TopicC - :documentation "The actual topic which is associated - with the subject-locator.")) - (:documentation "A pointer that associates subject-locators, versions - and topics.")) - - +;;; SubjectLocatorAssociationC (defmethod delete-construct :before ((construct SubjectLocatorAssociationC)) (delete-1-n-association construct 'parent-construct)) -(defpclass PersistentIdAssociationC(PointerAssociationC) - ((parent-construct :initarg :parent-construct - :accessor parent-construct - :initform (error "From PersistentIdAssociationC(): parent-construct must be set") - :associate TopicC - :documentation "The actual topic which is associated - with the subject-identifier/psi.")) - (:documentation "A pointer that associates subject-identifiers, versions - and topics.")) - - +;;; PersistentIdAssociationC (defmethod delete-construct :before ((construct PersistentIdAssociationC)) (delete-1-n-association construct 'parent-construct)) -(defpclass TopicIdAssociationC(PointerAssociationC) - ((parent-construct :initarg :parent-construct - :accessor parent-construct - :initform (error "From TopicIdAssociationC(): parent-construct must be set") - :associate TopicC - :documentation "The actual topic which is associated - with the topic-identifier.")) - (:documentation "A pointer that associates topic-identifiers, versions - and topics.")) - - +;;; TopicIdAssociationC (defmethod delete-construct :before ((construct TopicIdAssociationC)) (delete-1-n-association construct 'parent-construct)) -(defpclass ItemIdAssociationC(PointerAssociationC) - ((parent-construct :initarg :parent-construct - :accessor parent-construct - :initform (error "From ItemIDAssociationC(): parent-construct must be set") - :associate ReifiableConstructC - :documentation "The actual parent which is associated - with the item-identifier.")) - (:documentation "A pointer that associates item-identifiers, versions - and reifiable-constructs.")) - - +;;; ItemIdAssociationC (defmethod delete-construct :before ((construct ItemIdAssociationC)) (delete-1-n-association construct 'parent-construct)) -(defpclass PointerAssociationC (VersionedAssociationC) - ((identifier :initarg :identifier - :accessor identifier - :inherit t - :initform (error "From VersionedAssociationC(): identifier must be set") - :associate PointerC - :documentation "The actual data that is associated with - the pointer-association's parent.")) - (:documentation "An abstract base class for all versioned - pointer-associations.")) - - +;;; 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." @@ -1214,31 +1302,7 @@ (delete-construct id)))) -(defpclass VersionedAssociationC() - () - (:documentation "An abstract base class for all versioned associations.")) - - -;;; RoleC + AssociationC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defpclass AssociationC(ReifiableConstructC ScopableC TypableC) - ((roles :associate (RoleAssociationC association) - :documentation "Contains all association-objects of all roles this - association contains.") - (in-topicmaps :associate (TopicMapC associations) - :many-to-many t - :documentation "List of all topic maps this association is - part of")) - (:index t) - (:documentation "Association in a Topic Map")) - - -(defpclass RoleC(ReifiableConstructC TypableC) - ((parent :associate (RoleAssociationC role) - :documentation "Associates this object with a role-association.") - (player :associate (PlayerAssociationC parent-construct) - :documentation "Associates this object with a player-association."))) - - +;;; AssociationC (defmethod delete-construct :before ((construct AssociationC)) "Removes all elephant-associations and deleted all roles that are not associated by another associations." @@ -1295,6 +1359,7 @@ (filter-slot-value-by-revision association 'in-topicmaps :start-revision revision)) +;;; RoleC (defmethod delete-construct :before ((construct RoleC)) "Deletes all association-objects." (dolist (assoc (slot-p construct 'parent)) @@ -1341,7 +1406,7 @@ &key (revision (error "From delete-parent(): revision must be set"))) (let ((assoc-to-delete (loop for parent-assoc in (slot-p construct 'parent) - when (eql (association parent-assoc) parent-construct) + when (eql (parent-construct parent-assoc) parent-construct) return parent-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) @@ -1399,18 +1464,7 @@ construct))) -;;; ReifiableConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defpclass ReifiableConstructC(TopicMapConstructC) - ((item-identifiers :associate (ItemIdAssociationC identified-construct) - :inherit t - :documentation "A relation to all item-identifiers of - this construct.") - (reifier :associate (ReifierAssociationC reified-construct) - :inherit t - :documentation "A relation to a reifier-topic.")) - (:documentation "Reifiable constructs as per TMDM.")) - - +;;; ReifiableConstructC (defgeneric item-identifiers (construct &key revision) (:documentation "Returns the ItemIdentifierC-objects that correspond with the passed construct and the passed version.") @@ -1463,11 +1517,11 @@ :revision revision) construct)) (t - (make-construct 'ItemIdAssociationC - :start-revision revision - :parent-construct construct - :identifier item-identifier) - construct))))) + (make-instance 'ItemIdAssociationC + :start-revision revision + :parent-construct construct + :identifier item-identifier))) + construct))) (defgeneric delete-item-identifier (construct item-identifier &key revision) @@ -1509,10 +1563,10 @@ (all-constructs (merge-constructs (first all-constructs) construct)) (t - (make-construct 'ReifierAssociationC - :start-revision revision - :reifiable-construct construct - :reifier-topic merged-reifier-topic) + (make-instance 'ReifierAssociationC + :start-revision revision + :reifiable-construct construct + :reifier-topic merged-reifier-topic) construct)))))) @@ -1529,22 +1583,7 @@ construct))) -;;; TopicMapConstructC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defpclass TopicMapConstructC() - () - (:documentation "An abstract base class for all classes that describes - Topic Maps data.")) - - -;;; ScopableC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defpclass ScopableC() - ((themes :associate (ScopeAssociationC scopable-construct) - :inherit t - :documentation "Contains all association-objects that contain the - actual scope-topics.")) - (:documentation "An abstract base class for all constructs that are scoped.")) - - +;;; ScopableC (defmethod delete-construct :before ((construct ScopableC)) "Deletes all ScopeAssociationCs that are associated with the given object." (dolist (theme (slot-p construct 'themes)) @@ -1595,15 +1634,7 @@ construct))) -;;; TypableC ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defpclass TypableC() - ((instance-of :associate (TypeAssociationC type-topic) - :inherit t - :documentation "Contains all association-objects that contain - the actual type-topic.")) - (:documentation "An abstract base class for all typed constructcs.")) - - +;;; TypableC (defmethod delete-construct :before ((construct TypableC)) "Deletes all TypeAssociationCs that are associated with this object." (dolist (type (slot-p construct 'instance-of)) @@ -1663,18 +1694,6 @@ construct))) -;;; DatatypableC -(defpclass DatatypableC() - ((datatype :accessor datatype - :initarg :datatype - :initform constants:*xml-string* - :documentation "The XML Schema datatype of the occurrencevalue - (optional, always IRI for resourceRef).")) - (:index t) - (:documentation "An abstract base class for characteristics that own - an xml-datatype.")) - - 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 20 09:49:30 2010 @@ -16,7 +16,8 @@ :unittests-constants) (:export :run-datamodel-tests :test-VersionInfoC - :test-VersionedConstructC)) + :test-VersionedConstructC + :test-ItemIdentifierC)) (declaim (optimize (debug 3))) @@ -91,11 +92,28 @@ (is (= (length (elephant:get-instances-by-class 'd::VersionInfoC)) 0)) (is (= (length (elephant:get-instances-by-class 'd::VersionedConstructC)) 0))))) - - +(test test-ItemIdentifierC () + "Tests various functions of the VersionedCoinstructC class." + (with-fixture with-empty-db (*db-dir*) + (setf d:*TM-REVISION* 100) + (let ((ii-1 (make-instance 'd:ItemIdentifierC + :uri "ii-1")) + (ii-2 (make-instance 'd:ItemIdentifierC + :uri "ii-2")) + (topic (make-instance 'd:TopicC))) + (is-false (d:identified-construct ii-1)) + (signals error (make-instance 'd:ItemIdentifierC)) + (is-false (item-identifiers topic)) + (d:add-item-identifier topic ii-1) + (format t ">>> ~a~%" (d::parent-construct ii-1)) + (is (= (length (d:item-identifiers topic)) 1)) + ))) + + (defun run-datamodel-tests() (it.bese.fiveam:run! 'test-VersionInfoC) (it.bese.fiveam:run! 'test-VersionedConstructC) + (it.bese.fiveam:run! 'test-ItemIdentifierC) ) \ No newline at end of file

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

isidorus-cvs February 2010