- isidorus-cvs@common-lisp.net - mailman3.common-lisp.net

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

26 Feb '10

Author: lgiessmann Date: Fri Feb 26 15:22:11 2010 New Revision: 214 Log: new-datamodel: added some unit-tests for the base class ScopableC. Modified: branches/new-datamodel/docs/isidorus_data_model.pdf branches/new-datamodel/docs/isidorus_data_model.vsd branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/unit_tests/datamodel_test.lisp Modified: branches/new-datamodel/docs/isidorus_data_model.pdf ============================================================================== Binary files branches/new-datamodel/docs/isidorus_data_model.pdf (original) and branches/new-datamodel/docs/isidorus_data_model.pdf Fri Feb 26 15:22:11 2010 differ Modified: branches/new-datamodel/docs/isidorus_data_model.vsd ============================================================================== Binary files. No diff available. Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Fri Feb 26 15:22:11 2010 @@ -1711,8 +1711,7 @@ (:method ((construct ScopableC) (theme-topic TopicC) &key (revision *TM-REVISION*)) (let ((all-themes - (map 'list #'theme-topic - (remove-if #'marked-as-deleted-p (slot-p construct 'themes))))) + (map 'list #'theme-topic (slot-p construct 'themes)))) (if (find theme-topic all-themes) (let ((theme-assoc (loop for theme-assoc in (slot-p construct 'themes) @@ -1720,7 +1719,7 @@ return theme-assoc))) (add-to-version-history theme-assoc :start-revision revision)) (let ((assoc - (make-instance 'ScopeAssociationCn + (make-instance 'ScopeAssociationC :theme-topic theme-topic :scopable-construct construct))) (add-to-version-history assoc :start-revision 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 Fri Feb 26 15:22:11 2010 @@ -31,7 +31,8 @@ :test-OccurrenceC :test-VariantC :test-NameC - :test-TypableC)) + :test-TypableC + :test-ScopableC)) ;;TODO: test delete-construct @@ -725,6 +726,56 @@ (is (= (length (union (list name-1 name-2) (used-as-type top-1))) 2)) (is (= (length (slot-value top-1 'd::used-as-type)) 2))))) + + +(test test-ScopableC () + "Tests various functions of the base class ScopableC." + (with-fixture with-empty-db (*db-dir*) + (let ((occ-1 (make-instance 'OccurrenceC)) + (occ-2 (make-instance 'OccurrenceC)) + (top-1 (make-instance 'TopicC)) + (top-2 (make-instance 'TopicC)) + (revision-1 100) + (revision-2 200) + (revision-3 300)) + (setf *TM-REVISION* revision-1) + (is-false (themes occ-1)) + (is-false (used-as-theme top-1)) + (add-theme occ-1 top-1) + (is (= (length (union (list top-1) + (themes occ-1))) 1)) + (is (= (length (union (list occ-1) + (used-as-theme top-1))) 1)) + (delete-theme occ-1 top-1 :revision revision-2) + (is (= (length (union (list top-1) + (themes occ-1 :revision revision-1))) 1)) + (is-false (themes occ-1)) + (is-false (used-as-theme top-1)) + (is-false (themes occ-1 :revision revision-2)) + (add-theme occ-1 top-1 :revision revision-3) + (is (= (length (union (list top-1) + (themes occ-1))) 1)) + (is (= (length (slot-value occ-1 'd::themes)) 1)) + (add-theme occ-1 top-2 :revision revision-2) + (is (= (length (union (list top-1 top-2) + (themes occ-1))) 2)) + (is (= (length (union (list top-2) + (themes occ-1 :revision revision-2))) 1)) + (is (= (length (union (list top-1 top-2) + (themes occ-1))) 2)) + (add-theme occ-2 top-2 :revision revision-3) + (is (= (length (union (list top-1 top-2) + (themes occ-1))) 2)) + (is (= (length (union (list top-2) + (themes occ-2))) 1)) + (is (= (length (union (list occ-1) + (used-as-theme top-1))) 1)) + (is (= (length (union (list occ-1 occ-2) + (used-as-theme top-2))) 2)) + (is (= (length (slot-value occ-1 'd::themes)) 2)) + (is (= (length (slot-value occ-2 'd::themes)) 1)) + (is (= (length (slot-value top-1 'd::used-as-theme)) 1)) + (is (= (length (slot-value top-2 'd::used-as-theme)) 2))))) @@ -744,4 +795,5 @@ (it.bese.fiveam:run! 'test-VariantC) (it.bese.fiveam:run! 'test-NameC) (it.bese.fiveam:run! 'test-TypableC) + (it.bese.fiveam:run! 'test-ScopableC) ) \ No newline at end of file

1 0

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

26 Feb '10

Author: lgiessmann Date: Fri Feb 26 10:50:44 2010 New Revision: 213 Log: new-datamodel: added some unit-tests for the base class TypableC; optimized the function add-type. 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 Fri Feb 26 10:50:44 2010 @@ -94,6 +94,9 @@ (in-package :datamodel) +;;TODO: add-type/add-parent/add-<x>-identifier handle situation where +;; new objects hve to be bound in an earlier revision than one +;; where a object is already bound ;;TODO: finalize add-reifier ;;TODO: replace add-to-version-history in VersionedAssociationC with a pseudo ;; initarg in make-construct @@ -170,7 +173,7 @@ (defpclass TypableC() - ((instance-of :associate (TypeAssociationC type-topic) + ((instance-of :associate (TypeAssociationC typable-construct) :inherit t :documentation "Contains all association-objects that contain the actual type-topic.")) @@ -1527,6 +1530,7 @@ (map 'list #'player-topic (filter-slot-value-by-revision construct 'player :start-revision revision)))) + ;;TODO: search a player-assoc for the passed construct that was set in an older version (cond ((and already-set-player (eql (first already-set-player) player-topic)) (let ((player-assoc @@ -1763,24 +1767,30 @@ (let ((already-set-type (map 'list #'type-topic (filter-slot-value-by-revision construct 'instance-of - :start-revision revision)))) - (cond ((and already-set-type - (eql (first already-set-type) type-topic)) + :start-revision revision))) + (same-type-assoc + (loop for type-assoc in (slot-p construct 'instance-of) + when (eql (type-topic type-assoc) type-topic) + return type-assoc))) + (when (and already-set-type + (not (eql type-topic already-set-type))) + (error "From add-type(): ~a can't be typed by ~a since it is typed by ~a" + construct type-topic already-set-type)) + (cond (already-set-type (let ((type-assoc (loop for type-assoc in (slot-p construct 'instance-of) when (eql type-topic (type-topic type-assoc)) return type-assoc))) (add-to-version-history type-assoc :start-revision revision))) - ((not already-set-type) + (same-type-assoc + (add-to-version-history same-type-assoc :start-revision revision)) + (t (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))) - construct))) + (add-to-version-history assoc :start-revision revision))))) + construct)) (defgeneric delete-type (construct type-topic &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 Fri Feb 26 10:50:44 2010 @@ -30,7 +30,8 @@ :test-ReifiableConstructC :test-OccurrenceC :test-VariantC - :test-NameC)) + :test-NameC + :test-TypableC)) ;;TODO: test delete-construct @@ -689,6 +690,41 @@ (is-false (parent name-2)) (add-parent name-2 top-1 :revision revision-8) (is (eql top-1 (parent name-2)))))) + + +(test test-TypableC () + "Tests various functions of the base class TypableC." + (with-fixture with-empty-db (*db-dir*) + (let ((name-1 (make-instance 'NameC)) + (name-2 (make-instance 'NameC)) + (top-1 (make-instance 'TopicC)) + (top-2 (make-instance 'TopicC)) + (revision-0-5 50) + (revision-1 100) + (revision-2 200) + (revision-3 300)) + (setf *TM-REVISION* revision-1) + (is-false (instance-of name-1)) + (add-type name-1 top-1) + (is (eql top-1 (instance-of name-1))) + (is-false (instance-of name-1 :revision revision-0-5)) + (is (eql top-1 (instance-of name-1 :revision revision-2))) + (signals error (add-type name-1 top-2)) + (add-type name-2 top-1 :revision revision-2) + (is (= (length (union (list name-1 name-2) + (used-as-type top-1))) 2)) + (is (= (length (union (list name-1) + (used-as-type top-1 + :revision revision-1))) 1)) + (delete-type name-1 top-1 :revision revision-3) + (is-false (instance-of name-1)) + (is (= (length (union (list name-2) + (used-as-type top-1))) 1)) + (add-type name-1 top-1 :revision revision-3) + (is (eql top-1 (instance-of name-1))) + (is (= (length (union (list name-1 name-2) + (used-as-type top-1))) 2)) + (is (= (length (slot-value top-1 'd::used-as-type)) 2))))) @@ -707,4 +743,5 @@ (it.bese.fiveam:run! 'test-OccurrenceC) (it.bese.fiveam:run! 'test-VariantC) (it.bese.fiveam:run! 'test-NameC) + (it.bese.fiveam:run! 'test-TypableC) ) \ No newline at end of file

1 0

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

26 Feb '10

Author: lgiessmann Date: Fri Feb 26 03:07:41 2010 New Revision: 212 Log: new-datamodel: added some unit-test for NameC; fixed a bug in delete-name and add-name 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 Fri Feb 26 03:07:41 2010 @@ -948,15 +948,16 @@ an error is thrown.") (:method ((construct TopicC) (name NameC) &key (revision *TM-REVISION*)) - (when (and (parent name) - (not (eql (parent name) construct))) + (when (and (parent name :revision revision) + (not (eql (parent name :revision revision) 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))) + name construct (parent name :revision revision))) (let ((all-names (map 'list #'characteristic (slot-p construct 'names)))) (if (find name all-names) (let ((name-assoc (loop for name-assoc in (slot-p construct 'names) - when (eql (parent-construct name-assoc) name) + when (eql (parent-construct name-assoc) + construct) return name-assoc))) (add-to-version-history name-assoc :start-revision revision)) (let ((assoc @@ -973,7 +974,7 @@ (:method ((construct TopicC) (name NameC) &key (revision (error "From delete-name(): revision must be set"))) (let ((assoc-to-delete (loop for name-assoc in (slot-p construct 'names) - when (eql (parent-construct name-assoc) name) + when (eql (parent-construct name-assoc) construct) return name-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision 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 Fri Feb 26 03:07:41 2010 @@ -29,7 +29,8 @@ :test-get-item-by-psi :test-ReifiableConstructC :test-OccurrenceC - :test-VariantC)) + :test-VariantC + :test-NameC)) ;;TODO: test delete-construct @@ -573,7 +574,7 @@ (test test-VariantC () -"Tests various functions of VariantC." + "Tests various functions of VariantC." (with-fixture with-empty-db (*db-dir*) (let ((v-1 (make-instance 'VariantC)) (v-2 (make-instance 'VariantC)) @@ -618,7 +619,6 @@ (is (eql (parent v-1) name-2)) (is (eql (parent v-1 :revision revision-2) name-1)) (delete-parent v-2 name-1 :revision revision-4) - (format t "-->") (is-false (parent v-2 :revision revision-4)) (is (eql name-1 (parent v-2 :revision revision-3))) (add-parent v-2 name-1 :revision revision-5) @@ -630,6 +630,65 @@ (is-false (parent v-2)) (add-parent v-2 name-1 :revision revision-8) (is (eql name-1 (parent v-2)))))) + + +(test test-NameC () + "Tests various functions of NameC." + (with-fixture with-empty-db (*db-dir*) + (let ((name-1 (make-instance 'NameC)) + (name-2 (make-instance 'NameC)) + (top-1 (make-instance 'TopicC)) + (top-2 (make-instance 'TopicC)) + (revision-1 100) + (revision-2 200) + (revision-3 300) + (revision-4 400) + (revision-5 500) + (revision-6 600) + (revision-7 700) + (revision-8 800)) + (setf *TM-REVISION* revision-1) + (is-false (parent name-1)) + (is-false (names top-1)) + (add-name top-1 name-1 :revision revision-1) + (is (= (length (union (list name-1) + (names top-1))) 1)) + (add-name top-1 name-2 :revision revision-2) + (is (= (length (union (list name-1 name-2) + (names top-1))) 2)) + (is (= (length (union (list name-1) + (names top-1 :revision revision-1))) 1)) + (add-name top-1 name-2 :revision revision-3) + (is (= (length (d::slot-p top-1 'd::names)) 2)) + (delete-name top-1 name-1 :revision revision-4) + (is (= (length (union (list name-2) + (names top-1 :revision revision-4))) 1)) + (is (= (length (union (list name-2) + (names top-1))) 1)) + (is (= (length (union (list name-1 name-2) + (names top-1 :revision revision-2))) 2)) + (add-name top-1 name-1 :revision revision-4) + (is (= (length (union (list name-2 name-1) + (names top-1))) 2)) + (signals error (add-name top-2 name-1 :revision revision-4)) + (delete-name top-1 name-1 :revision revision-5) + (is (= (length (union (list name-2) + (names top-1 :revision revision-5))) 1)) + (add-name top-2 name-1 :revision revision-5) + (is (eql (parent name-1) top-2)) + (is (eql (parent name-1 :revision revision-2) top-1)) + (delete-parent name-2 top-1 :revision revision-4) + (is-false (parent name-2 :revision revision-4)) + (is (eql top-1 (parent name-2 :revision revision-3))) + (add-parent name-2 top-1 :revision revision-5) + (is-false (parent name-2 :revision revision-4)) + (is (eql top-1 (parent name-2))) + (delete-parent name-2 top-1 :revision revision-6) + (add-parent name-2 top-2 :revision revision-7) + (delete-parent name-2 top-2 :revision revision-8) + (is-false (parent name-2)) + (add-parent name-2 top-1 :revision revision-8) + (is (eql top-1 (parent name-2)))))) @@ -647,4 +706,5 @@ (it.bese.fiveam:run! 'test-ReifiableConstructC) (it.bese.fiveam:run! 'test-OccurrenceC) (it.bese.fiveam:run! 'test-VariantC) + (it.bese.fiveam:run! 'test-NameC) ) \ No newline at end of file

1 0

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

26 Feb '10

Author: lgiessmann Date: Fri Feb 26 02:58:57 2010 New Revision: 211 Log: new-datamodel: merged the generic functions delete-parent, so there is only one generic function with the signature ((construct CharacteristicC) (parent-construct ReifiableConstructC) &key (revision (error "From delete-parent(): revision must be set"))); added some unit-tests for the class VariantC 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 Fri Feb 26 02:58:57 2010 @@ -493,7 +493,7 @@ associates characteristics with topics.")) -(defpclass VariantAssociationC(CharateristicAssociationC) +(defpclass VariantAssociationC(CharacteristicAssociationC) ((parent-construct :initarg :parent-construct :accessor parent-construct :initform (error "From VariantAssociationC(): parent-construct must be set") @@ -1187,8 +1187,8 @@ scopable-construct.") (:method ((construct NameC) (variant VariantC) &key (revision *TM-REVISION*)) - (when (and (parent variant) - (not (eql (parent variant) construct))) + (when (and (parent variant :revision revision) + (not (eql (parent variant :revision revision) 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))) (let ((all-variants @@ -1285,29 +1285,16 @@ (defgeneric delete-parent (construct parent-construct &key revision) (:documentation "Sets the assoication-object between the passed - constructs as marded-as-deleted.")) - - -(defmethod delete-parent ((construct CharacteristicC) (parent-construct TopicC) - &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 (parent-construct parent-assoc) parent-construct) - return parent-assoc))) - (when assoc-to-delete - (mark-as-deleted assoc-to-delete :revision revision)) - construct)) - - -(defmethod delete-parent ((construct CharacteristicC) (parent-construct NameC) - &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 (characteristic parent-assoc) parent-construct) - return parent-assoc))) - (when assoc-to-delete - (mark-as-deleted assoc-to-delete :revision revision)) - construct)) + constructs as marded-as-deleted.") + (:method ((construct CharacteristicC) (parent-construct ReifiableConstructC) + &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 (parent-construct parent-assoc) parent-construct) + return parent-assoc))) + (when assoc-to-delete + (mark-as-deleted assoc-to-delete :revision revision)) + construct))) ;;; PlayerAssociationC 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 Fri Feb 26 02:58:57 2010 @@ -518,7 +518,7 @@ (with-fixture with-empty-db (*db-dir*) (let ((occ-1 (make-instance 'OccurrenceC)) (occ-2 (make-instance 'OccurrenceC)) - (top (make-instance 'TopicC)) + (top-1 (make-instance 'TopicC)) (top-2 (make-instance 'TopicC)) (revision-1 100) (revision-2 200) @@ -530,46 +530,46 @@ (revision-8 800)) (setf *TM-REVISION* revision-1) (is-false (parent occ-1)) - (is-false (occurrences top)) - (add-occurrence top occ-1 :revision revision-1) + (is-false (occurrences top-1)) + (add-occurrence top-1 occ-1 :revision revision-1) (is (= (length (union (list occ-1) - (occurrences top))) 1)) - (add-occurrence top occ-2 :revision revision-2) + (occurrences top-1))) 1)) + (add-occurrence top-1 occ-2 :revision revision-2) (is (= (length (union (list occ-1 occ-2) - (occurrences top))) 2)) + (occurrences top-1))) 2)) (is (= (length (union (list occ-1) - (occurrences top :revision revision-1))) 1)) - (add-occurrence top occ-2 :revision revision-3) - (is (= (length (d::slot-p top 'd::occurrences)) 2)) - (delete-occurrence top occ-1 :revision revision-4) + (occurrences top-1 :revision revision-1))) 1)) + (add-occurrence top-1 occ-2 :revision revision-3) + (is (= (length (d::slot-p top-1 'd::occurrences)) 2)) + (delete-occurrence top-1 occ-1 :revision revision-4) (is (= (length (union (list occ-2) - (occurrences top :revision revision-4))) 1)) + (occurrences top-1 :revision revision-4))) 1)) (is (= (length (union (list occ-2) - (occurrences top))) 1)) + (occurrences top-1))) 1)) (is (= (length (union (list occ-1 occ-2) - (occurrences top :revision revision-2))) 2)) - (add-occurrence top occ-1 :revision revision-4) + (occurrences top-1 :revision revision-2))) 2)) + (add-occurrence top-1 occ-1 :revision revision-4) (is (= (length (union (list occ-2 occ-1) - (occurrences top))) 2)) + (occurrences top-1))) 2)) (signals error (add-occurrence top-2 occ-1 :revision revision-4)) - (delete-occurrence top occ-1 :revision revision-5) + (delete-occurrence top-1 occ-1 :revision revision-5) (is (= (length (union (list occ-2) - (occurrences top :revision revision-5))) 1)) + (occurrences top-1 :revision revision-5))) 1)) (add-occurrence top-2 occ-1 :revision revision-5) (is (eql (parent occ-1) top-2)) - (is (eql (parent occ-1 :revision revision-2) top)) - (delete-parent occ-2 top :revision revision-4) + (is (eql (parent occ-1 :revision revision-2) top-1)) + (delete-parent occ-2 top-1 :revision revision-4) (is-false (parent occ-2 :revision revision-4)) - (is (eql top (parent occ-2 :revision revision-3))) - (add-parent occ-2 top :revision revision-5) + (is (eql top-1 (parent occ-2 :revision revision-3))) + (add-parent occ-2 top-1 :revision revision-5) (is-false (parent occ-2 :revision revision-4)) - (is (eql top (parent occ-2))) - (delete-parent occ-2 top :revision revision-6) + (is (eql top-1 (parent occ-2))) + (delete-parent occ-2 top-1 :revision revision-6) (add-parent occ-2 top-2 :revision revision-7) (delete-parent occ-2 top-2 :revision revision-8) (is-false (parent occ-2)) - (add-parent occ-2 top :revision revision-8) - (is (eql top (parent occ-2)))))) + (add-parent occ-2 top-1 :revision revision-8) + (is (eql top-1 (parent occ-2)))))) (test test-VariantC () @@ -577,14 +577,59 @@ (with-fixture with-empty-db (*db-dir*) (let ((v-1 (make-instance 'VariantC)) (v-2 (make-instance 'VariantC)) - (name (make-instance 'NameC)) + (name-1 (make-instance 'NameC)) + (name-2 (make-instance 'NameC)) (revision-1 100) (revision-2 200) (revision-3 300) - (revision-4 400)) + (revision-4 400) + (revision-5 500) + (revision-6 600) + (revision-7 700) + (revision-8 800)) (setf *TM-REVISION* revision-1) - - ))) + (is-false (parent v-1)) + (is-false (variants name-1)) + (add-variant name-1 v-1 :revision revision-1) + (is (= (length (union (list v-1) + (variants name-1))) 1)) + (add-variant name-1 v-2 :revision revision-2) + (is (= (length (union (list v-1 v-2) + (variants name-1))) 2)) + (is (= (length (union (list v-1) + (variants name-1 :revision revision-1))) 1)) + (add-variant name-1 v-2 :revision revision-3) + (is (= (length (d::slot-p name-1 'd::variants)) 2)) + (delete-variant name-1 v-1 :revision revision-4) + (is (= (length (union (list v-2) + (variants name-1 :revision revision-4))) 1)) + (is (= (length (union (list v-2) + (variants name-1))) 1)) + (is (= (length (union (list v-1 v-2) + (variants name-1 :revision revision-2))) 2)) + (add-variant name-1 v-1 :revision revision-4) + (is (= (length (union (list v-2 v-1) + (variants name-1))) 2)) + (signals error (add-variant name-2 v-1 :revision revision-4)) + (delete-variant name-1 v-1 :revision revision-5) + (is (= (length (union (list v-2) + (variants name-1 :revision revision-5))) 1)) + (add-variant name-2 v-1 :revision revision-5) + (is (eql (parent v-1) name-2)) + (is (eql (parent v-1 :revision revision-2) name-1)) + (delete-parent v-2 name-1 :revision revision-4) + (format t "-->") + (is-false (parent v-2 :revision revision-4)) + (is (eql name-1 (parent v-2 :revision revision-3))) + (add-parent v-2 name-1 :revision revision-5) + (is-false (parent v-2 :revision revision-4)) + (is (eql name-1 (parent v-2))) + (delete-parent v-2 name-1 :revision revision-6) + (add-parent v-2 name-2 :revision revision-7) + (delete-parent v-2 name-2 :revision revision-8) + (is-false (parent v-2)) + (add-parent v-2 name-1 :revision revision-8) + (is (eql name-1 (parent v-2))))))

1 0

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

26 Feb '10

Author: lgiessmann Date: Fri Feb 26 02:14:11 2010 New Revision: 210 Log: new-datamodel: merged the generic functions add-parent, so there is only one for the parents TopicC and NameC; added some unit-tests for add-parent, delete-parent and parent 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 Fri Feb 26 02:14:11 2010 @@ -331,7 +331,7 @@ ;;; characteristics ... (defpclass CharacteristicC(ReifiableConstructC ScopableC TypableC) - ((parent :associate (CharacteriticAssociationC characteristic) + ((parent :associate (CharacteristicAssociationC characteristic) :inherit t :documentation "Assocates the characterist obejct with the parent-association.") @@ -948,13 +948,12 @@ an error is thrown.") (:method ((construct TopicC) (name NameC) &key (revision *TM-REVISION*)) - (when (not (eql (parent name) construct)) + (when (and (parent name) + (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))) (let ((all-names - (map 'list #'characteristic - (remove-if #'marked-as-deleted-p - (slot-p construct 'names))))) + (map 'list #'characteristic (slot-p construct 'names)))) (if (find name all-names) (let ((name-assoc (loop for name-assoc in (slot-p construct 'names) when (eql (parent-construct name-assoc) name) @@ -998,14 +997,12 @@ an error is thrown.") (:method ((construct TopicC) (occurrence OccurrenceC) &key (revision *TM-REVISION*)) - (when (and (parent occurrence) + (when (and (parent occurrence :revision revision) (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))) (let ((all-occurrences - (map 'list #'characteristic - (remove-if #'marked-as-deleted-p - (slot-p construct 'occurrences))))) + (map 'list #'characteristic (slot-p construct 'occurrences)))) (if (find occurrence all-occurrences) (let ((occ-assoc (loop for occ-assoc in (slot-p construct 'occurrences) when (eql (parent-construct occ-assoc) construct) @@ -1190,13 +1187,12 @@ scopable-construct.") (:method ((construct NameC) (variant VariantC) &key (revision *TM-REVISION*)) - (when (not (eql (parent variant) construct)) + (when (and (parent variant) + (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))) (let ((all-variants - (map 'list #'characteristic - (remove-if #'marked-as-deleted-p - (slot-p construct 'variants))))) + (map 'list #'characteristic (slot-p construct 'variants)))) (if (find variant all-variants) (let ((variant-assoc (loop for variant-assoc in (slot-p construct 'variants) @@ -1252,60 +1248,39 @@ (defgeneric add-parent (construct parent-construct &key revision) (:documentation "Adds the parent-construct (TopicC or NameC) in form of - a corresponding association to the given object.")) - - -(defmethod add-parent ((construct CharacteristicC) (parent-construct TopicC) - &key (revision *TM-REVISION*)) - (let ((already-set-topic - (map 'list #'parent-construct - (filter-slot-value-by-revision construct 'parent - :start-revision revision)))) - (cond ((and already-set-topic - (eql (first already-set-topic) parent-construct)) - (let ((parent-assoc - (loop for parent-assoc in (slot-p construct 'parent) - when (eql parent-construct (parent-construct - parent-assoc)) - return parent-assoc))) - (add-to-version-history parent-assoc :start-revision revision))) - ((not already-set-topic) - (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))) - construct)) - - -(defmethod add-parent ((construct CharacteristicC) (parent-construct NameC) - &key (revision *TM-REVISION*)) - (let ((already-set-name - (map 'list #'characteristic - (filter-slot-value-by-revision construct 'parent - :start-revision revision)))) - (cond ((and already-set-name - (eql (first already-set-name) parent-construct)) + a corresponding association to the given object.") + (:method ((construct CharacteristicC) (parent-construct ReifiableConstructC) + &key (revision *TM-REVISION*)) + (let ((already-set-parent (parent construct :revision revision)) + (same-parent-assoc ;should contain a object that was marked as deleted + (loop for parent-assoc in (slot-p construct 'parent) + when (eql parent-construct (parent-construct parent-assoc)) + return parent-assoc))) + (when (and already-set-parent + (not (eql already-set-parent parent-construct))) + (error "From add-parent(): ~a can't be owned by ~a since it is already owned by ~a" + construct parent-construct already-set-parent)) + (cond (already-set-parent (let ((parent-assoc (loop for parent-assoc in (slot-p construct 'parent) - when (eql parent-construct (characteristic parent-assoc)) + when (eql parent-construct + (parent-construct parent-assoc)) return parent-assoc))) (add-to-version-history parent-assoc :start-revision revision))) - ((not already-set-name) - (let ((assoc - (make-instance 'VariantAssociationC - :parent-construct parent-construct - :characteristic construct))) - (add-to-version-history assoc :start-revision revision))) + (same-parent-assoc + (add-to-version-history same-parent-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))) - construct)) + (let ((association-type (cond ((typep construct 'OccurrenceC) + 'OccurrenceAssociationC) + ((typep construct 'NameC) + 'NameAssociationC) + (t + 'VariantAssociationC)))) + (let ((assoc (make-instance association-type + :characteristic construct + :parent-construct parent-construct))) + (add-to-version-history assoc :start-revision revision)))))) + construct)) (defgeneric delete-parent (construct parent-construct &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 Fri Feb 26 02:14:11 2010 @@ -28,7 +28,8 @@ :test-get-item-by-locator :test-get-item-by-psi :test-ReifiableConstructC - :test-OccurrenceC)) + :test-OccurrenceC + :test-VariantC)) ;;TODO: test delete-construct @@ -518,10 +519,15 @@ (let ((occ-1 (make-instance 'OccurrenceC)) (occ-2 (make-instance 'OccurrenceC)) (top (make-instance 'TopicC)) + (top-2 (make-instance 'TopicC)) (revision-1 100) (revision-2 200) (revision-3 300) - (revision-4 400)) + (revision-4 400) + (revision-5 500) + (revision-6 600) + (revision-7 700) + (revision-8 800)) (setf *TM-REVISION* revision-1) (is-false (parent occ-1)) (is-false (occurrences top)) @@ -544,7 +550,42 @@ (occurrences top :revision revision-2))) 2)) (add-occurrence top occ-1 :revision revision-4) (is (= (length (union (list occ-2 occ-1) - (occurrences top))) 2))))) + (occurrences top))) 2)) + (signals error (add-occurrence top-2 occ-1 :revision revision-4)) + (delete-occurrence top occ-1 :revision revision-5) + (is (= (length (union (list occ-2) + (occurrences top :revision revision-5))) 1)) + (add-occurrence top-2 occ-1 :revision revision-5) + (is (eql (parent occ-1) top-2)) + (is (eql (parent occ-1 :revision revision-2) top)) + (delete-parent occ-2 top :revision revision-4) + (is-false (parent occ-2 :revision revision-4)) + (is (eql top (parent occ-2 :revision revision-3))) + (add-parent occ-2 top :revision revision-5) + (is-false (parent occ-2 :revision revision-4)) + (is (eql top (parent occ-2))) + (delete-parent occ-2 top :revision revision-6) + (add-parent occ-2 top-2 :revision revision-7) + (delete-parent occ-2 top-2 :revision revision-8) + (is-false (parent occ-2)) + (add-parent occ-2 top :revision revision-8) + (is (eql top (parent occ-2)))))) + + +(test test-VariantC () +"Tests various functions of VariantC." + (with-fixture with-empty-db (*db-dir*) + (let ((v-1 (make-instance 'VariantC)) + (v-2 (make-instance 'VariantC)) + (name (make-instance 'NameC)) + (revision-1 100) + (revision-2 200) + (revision-3 300) + (revision-4 400)) + (setf *TM-REVISION* revision-1) + + ))) + (defun run-datamodel-tests() @@ -560,4 +601,5 @@ (it.bese.fiveam:run! 'test-get-item-by-psi) (it.bese.fiveam:run! 'test-ReifiableConstructC) (it.bese.fiveam:run! 'test-OccurrenceC) + (it.bese.fiveam:run! 'test-VariantC) ) \ No newline at end of file

1 0

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

25 Feb '10

Author: lgiessmann Date: Thu Feb 25 16:36:10 2010 New Revision: 209 Log: new-datamodel: added some unit-tests for add-occurrence, delete-occurrence, occurrences; fixed some bugs in these funtions 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 16:36:10 2010 @@ -486,7 +486,7 @@ :accessor characteristic :inherit t :initform (error "From CharacteristicCAssociation(): characteristic must be set") - :associate CharactersiticC + :associate CharacteristicC :documentation "Associates this object with the actual characteristic object.")) (:documentation "An abstract base class for all association-objects that @@ -986,7 +986,7 @@ with the passed construct and the passed version.") (:method ((construct TopicC) &key (revision 0)) (let ((assocs (filter-slot-value-by-revision - construct 'occurences :start-revision revision))) + construct 'occurrences :start-revision revision))) (map 'list #'characteristic assocs)))) @@ -998,7 +998,8 @@ an error is thrown.") (:method ((construct TopicC) (occurrence OccurrenceC) &key (revision *TM-REVISION*)) - (when (not (eql (parent occurrence) construct)) + (when (and (parent occurrence) + (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))) (let ((all-occurrences @@ -1007,7 +1008,7 @@ (slot-p construct 'occurrences))))) (if (find occurrence all-occurrences) (let ((occ-assoc (loop for occ-assoc in (slot-p construct 'occurrences) - when (eql (parent-construct occ-assoc) occurrence) + when (eql (parent-construct occ-assoc) construct) return occ-assoc))) (add-to-version-history occ-assoc :start-revision revision)) (let ((assoc @@ -1024,7 +1025,7 @@ (:method ((construct TopicC) (occurrence OccurrenceC) &key (revision (error "From delete-occurrence(): revision must be set"))) (let ((assoc-to-delete (loop for occ-assoc in (slot-p construct 'occurrences) - when (eql (parent-construct occ-assoc) occurrence) + when (eql (parent-construct occ-assoc) construct) return occ-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision 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 Thu Feb 25 16:36:10 2010 @@ -27,14 +27,13 @@ :test-get-item-by-item-identifier :test-get-item-by-locator :test-get-item-by-psi - :test-ReifiableConstructC)) + :test-ReifiableConstructC + :test-OccurrenceC)) ;;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 an item-dentifier, +;; a psi, a subject-locator, 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 @@ -513,6 +512,41 @@ (is-false (reified-construct reifier-top :revision 50))))) +(test test-OccurrenceC () + "Tests various functions of OccurrenceC." + (with-fixture with-empty-db (*db-dir*) + (let ((occ-1 (make-instance 'OccurrenceC)) + (occ-2 (make-instance 'OccurrenceC)) + (top (make-instance 'TopicC)) + (revision-1 100) + (revision-2 200) + (revision-3 300) + (revision-4 400)) + (setf *TM-REVISION* revision-1) + (is-false (parent occ-1)) + (is-false (occurrences top)) + (add-occurrence top occ-1 :revision revision-1) + (is (= (length (union (list occ-1) + (occurrences top))) 1)) + (add-occurrence top occ-2 :revision revision-2) + (is (= (length (union (list occ-1 occ-2) + (occurrences top))) 2)) + (is (= (length (union (list occ-1) + (occurrences top :revision revision-1))) 1)) + (add-occurrence top occ-2 :revision revision-3) + (is (= (length (d::slot-p top 'd::occurrences)) 2)) + (delete-occurrence top occ-1 :revision revision-4) + (is (= (length (union (list occ-2) + (occurrences top :revision revision-4))) 1)) + (is (= (length (union (list occ-2) + (occurrences top))) 1)) + (is (= (length (union (list occ-1 occ-2) + (occurrences top :revision revision-2))) 2)) + (add-occurrence top occ-1 :revision revision-4) + (is (= (length (union (list occ-2 occ-1) + (occurrences top))) 2))))) + + (defun run-datamodel-tests() (it.bese.fiveam:run! 'test-VersionInfoC) (it.bese.fiveam:run! 'test-VersionedConstructC) @@ -525,4 +559,5 @@ (it.bese.fiveam:run! 'test-get-item-by-locator) (it.bese.fiveam:run! 'test-get-item-by-psi) (it.bese.fiveam:run! 'test-ReifiableConstructC) + (it.bese.fiveam:run! 'test-OccurrenceC) ) \ No newline at end of file

1 0

[isidorus-cvs] r208 - branches/new-datamodel/src/rest_interface trunk/src/rest_interface
by Lukas Giessmann 25 Feb '10

25 Feb '10

Author: lgiessmann Date: Thu Feb 25 15:45:39 2010 New Revision: 208 Log: rest-interface: fixed a bug in the restful-handler return-overview that caused a memory-leak Modified: branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp trunk/src/rest_interface/set-up-json-interface.lisp Modified: branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp ============================================================================== --- branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp (original) +++ branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp Thu Feb 25 15:45:39 2010 @@ -331,15 +331,15 @@ (defun return-overview (&optional param) "Returns a json-object representing a topic map overview as a tree(s)" (declare (ignorable param)) - (handler-case (let ((json-string - (with-reader-lock - (json-tmcl::tree-view-to-json-string (json-tmcl::make-tree-view))))) - (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 - json-string) - (Condition (err) (progn - (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) - (setf (hunchentoot:content-type*) "text") - (format nil "Condition: \"~a\"" err))))) + (with-reader-lock + (handler-case (let ((json-string + (json-tmcl::tree-view-to-json-string (json-tmcl::make-tree-view)))) + (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 + json-string) + (Condition (err) (progn + (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) + (setf (hunchentoot:content-type*) "text") + (format nil "Condition: \"~a\"" err)))))) ;; ============================================================================= @@ -385,4 +385,4 @@ (setf ret-str (concatenate 'string ret-str (subseq str idx (1+ idx)))) (incf idx))) (unless (< idx (length str)) - (return ret-str))))))) \ No newline at end of file + (return ret-str))))))) Modified: trunk/src/rest_interface/set-up-json-interface.lisp ============================================================================== --- trunk/src/rest_interface/set-up-json-interface.lisp (original) +++ trunk/src/rest_interface/set-up-json-interface.lisp Thu Feb 25 15:45:39 2010 @@ -331,15 +331,15 @@ (defun return-overview (&optional param) "Returns a json-object representing a topic map overview as a tree(s)" (declare (ignorable param)) - (handler-case (let ((json-string - (with-reader-lock - (json-tmcl::tree-view-to-json-string (json-tmcl::make-tree-view))))) - (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 - json-string) - (Condition (err) (progn - (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) - (setf (hunchentoot:content-type*) "text") - (format nil "Condition: \"~a\"" err))))) + (with-reader-lock + (handler-case (let ((json-string + (json-tmcl::tree-view-to-json-string (json-tmcl::make-tree-view)))) + (setf (hunchentoot:content-type*) "application/json") ;RFC 4627 + json-string) + (Condition (err) (progn + (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) + (setf (hunchentoot:content-type*) "text") + (format nil "Condition: \"~a\"" err)))))) ;; =============================================================================

1 0

[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