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