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

[isidorus-cvs] r254 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 27 Mar '10

27 Mar '10

Author: lgiessmann Date: Sat Mar 27 16:30:12 2010 New Revision: 254 Log: new-datamodel: added the generic "equivalent-constructs" that checks the TMDM equality of two "TopicMapConstructC"s and is needed for "merge-constructs" Modified: branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/unit_tests/datamodel_test.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Sat Mar 27 16:30:12 2010 @@ -155,7 +155,6 @@ (in-package :datamodel) - ;;TODO: check merge-constructs in add-topic-identifier, ;; add-item-identifier/add-reifier (can merge the parent constructs ;; and the parent's parent construct + the reifier constructs), @@ -779,7 +778,14 @@ (defgeneric equivalent-construct (construct &key start-revision &allow-other-keys) (:documentation "Returns t if the passed construct is equivalent to the passed - key arguments (TMDM equality rules. Parent-equality is not + key arguments (TMDM equality rules). Parent-equality is not + checked in this methods, so the user has to pass children of + the same parent.")) + + +(defgeneric equivalent-constructs (construct-1 construct-2 &key revision) + (:documentation "Returns t if the passed constructs are equivalent to each + other (TMDM equality rules). Parent-equality is not checked in this methods, so the user has to pass children of the same parent.")) @@ -923,6 +929,17 @@ ;;; TopicMapconstructC +(defgeneric strictly-equivalent-constructs (construct-1 construct-2 + &key revision) + (:documentation "Checks if two topic map constructs are not identical but + equal according to the TMDM equality rules.") + (:method ((construct-1 TopicMapConstructC) (construct-2 TopicMapConstructC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (and (equivalent-constructs construct-1 construct-2 :revision revision) + (not (eql construct-1 construct-2))))) + + (defmethod check-for-duplicate-identifiers ((construct TopicMapConstructC) &key revision) (declare (ignorable revision construct)) @@ -948,6 +965,12 @@ ;;; PointerC +(defmethod equivalent-constructs ((construct-1 PointerC) (construct-2 PointerC) + &key (revision nil)) + (declare (ignorable revision)) + (string= (uri construct-1) (uri construct-2))) + + (defgeneric PointerC-p (class-symbol) (:documentation "Returns t if the passed symbol corresponds to the class PointerC or one of its subclasses.") @@ -1018,6 +1041,14 @@ ;;; TopicIdentificationC +(defmethod equivalent-constructs ((construct-1 PointerC) (construct-2 PointerC) + &key (revision nil)) + (declare (ignorable revision)) + (and (call-next-method) + (string= (xtm-id construct-1) (xtm-id construct-2)))) + + + (defgeneric TopicIdentificationC-p (class-symbol) (:documentation "Returns t if the passed class symbol is equal to TopicIdentificationC.") @@ -1143,6 +1174,20 @@ ;;; TopicC +(defmethod equivalent-constructs ((construct-1 TopicC) (construct-2 TopicC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (when (intersection (union + (union (item-identifiers construct-1 :revision revision) + (locators construct-1 :revision revision)) + (psis construct-1 :revision revision)) + (union + (union (item-identifiers construct-2 :revision revision) + (locators construct-2 :revision revision)) + (psis construct-2 :revision revision))) + t)) + + (defgeneric TopicC-p (class-symbol) (:documentation "Returns t if the passed symbol is equal to TopicC.") (:method ((class-symbol symbol)) @@ -1714,6 +1759,17 @@ ;;; CharacteristicC +(defmethod equivalent-constructs ((construct-1 CharacteristicC) + (construct-2 CharacteristicC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (and (string= (charvalue construct-1) (charvalue construct-2)) + (eql (instance-of construct-1 :revision revision) + (instance-of construct-2 :revision revision)) + (not (set-exclusive-or (themes construct-1 :revision revision) + (themes construct-2 :revision revision))))) + + (defgeneric CharacteristicC-p (class-symbol) (:documentation "Returns t if the passed symbol is equal to CharacteristicC or one of its subtypes.") @@ -1845,6 +1901,13 @@ ;;; OccurrenceC +(defmethod equivalent-constructs ((construct-1 OccurrenceC) (construct-2 OccurrenceC) + &key (revision *TM-REVISION*)) + (declare (ignorable revision)) + (and (call-next-method) + (string= (datatype construct-1) (datatype construct-2)))) + + (defgeneric OccurrenceC-p (class-symbol) (:documentation "Returns t if the passed symbol is equal to OccurrenceC.") (:method ((class-symbol symbol)) @@ -1867,6 +1930,13 @@ ;;; VariantC +(defmethod equivalent-constructs ((construct-1 VariantC) (construct-2 VariantC) + &key (revision *TM-REVISION*)) + (declare (ignorable revision)) + (and (call-next-method) + (string= (datatype construct-1) (datatype construct-2)))) + + (defgeneric VariantC-p (class-symbol) (:documentation "Returns t if the passed symbol is equal to VariantC.") (:method ((class-symbol symbol)) @@ -1977,6 +2047,18 @@ ;;; AssociationC +(defmethod equivalent-constructs ((construct-1 AssociationC) + (construct-2 AssociationC) + &key (revision *TM-REVISION*)) + (declare (ignorable revision)) + (and (eql (instance-of construct-1 :revision revision) + (instance-of construct-2 :revision revision)) + (not (set-exclusive-or (themes construct-1 :revision revision) + (themes construct-1 :revision revision))) + (not (set-exclusive-or (roles construct-1 :revision revision) + (roles construct-2 :revision revision))))) + + (defgeneric AssociationC-p (class-symbol) (:documentation "Returns t if the passed symbol is equal to AssociationC.") (:method ((class-symbol symbol)) @@ -2082,6 +2164,15 @@ ;;; RoleC +(defmethod equivalent-constructs ((construct-1 RoleC) (construct-2 RoleC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (and (eql (instance-of construct-1 :revision revision) + (instance-of construct-2 :revision revision)) + (eql (player construct-1 :revision revision) + (player construct-1 :revision revision)))) + + (defgeneric RoleC-p (class-symbol) (:documentation "Returns t if the passed symbol is equal to RoleC.") (:method ((class-symbol symbol)) @@ -2364,6 +2455,11 @@ (let ((id-owner (identified-construct item-identifier :revision revision))) (when (not (eql id-owner construct)) + (unless (typep construct 'TopicC) + (error (make-condition 'duplicate-identifier-error + :message "From add-item-identifier(): duplicate ItemIdentifier has been found: ~a" + (uri item-identifier) + :uri (uri item-identifier)))) id-owner)))) (let ((merged-construct construct)) (cond (construct-to-be-merged @@ -2649,6 +2745,14 @@ ;;; TopicMapC +(defmethod equivalent-constructs ((construct-1 TopicMapC) (construct-2 TopicMapC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (when (intersection (item-identifiers construct-1 :revision revision) + (item-identifiers construct-2 :revision revision)) + t)) + + (defgeneric TopicMapC-p (class-symbol) (:documentation "Returns t if the passed symbol is equal to TopicMapC.") (:method ((class-symbol symbol)) Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/datamodel_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp Sat Mar 27 16:30:12 2010 @@ -75,6 +75,7 @@ :test-make-TopicC)) +;;TODO: test equivalent-constructs ;;TODO: test merge-constructs

1 0

[isidorus-cvs] r253 - branches/new-datamodel/src/unit_tests
by Lukas Giessmann 24 Mar '10

24 Mar '10

Author: lgiessmann Date: Wed Mar 24 14:06:03 2010 New Revision: 253 Log: new-datamodel: added unit-tests for "make-construct" --> "TopicC" Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp 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 Mar 24 14:06:03 2010 @@ -71,10 +71,10 @@ :test-make-VariantC :test-make-RoleC :test-make-TopicMapC - :test-make-AssociationC)) + :test-make-AssociationC + :test-make-TopicC)) -;;TODO: test make-construct ;;TODO: test merge-constructs @@ -2485,6 +2485,86 @@ (is (= (length (roles assoc-3)) 2)))))))) +(test test-make-TopicC () + "Tests the function make-construct corresponding to TopicC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) + (ii-3 (make-construct 'ItemIdentifierC :uri "ii-3")) + (psi-1 (make-construct 'PersistentIdC :uri "psi-1")) + (psi-2 (make-construct 'PersistentIdC :uri "psi-2")) + (psi-3 (make-construct 'PersistentIdC :uri "psi-3")) + (sl-1 (make-construct 'SubjectLocatorC :uri "sl-1")) + (sl-2 (make-construct 'SubjectLocatorC :uri "sl-2")) + (sl-3 (make-construct 'SubjectLocatorC :uri "sl-3")) + (variant-1 (make-construct 'VariantC :datatype "dt-1" + :charvalue "cv-1")) + (variant-2 (make-construct 'VariantC :datatype "dt-2" + :charvalue "cv-2")) + (type-1 (make-instance 'TopicC)) + (type-2 (make-instance 'TopicC)) + (type-3 (make-instance 'TopicC)) + (theme-1 (make-instance 'TopicC)) + (theme-2 (make-instance 'TopicC)) + (theme-3 (make-instance 'TopicC))) + (let ((name-1 (make-construct 'NameC :charvalue "cv-3" + :start-revision rev-1 + :variants (list variant-1) + :instance-of type-1 + :themes (list theme-1 theme-2))) + (name-2 (make-construct 'NameC :charvalue "cv-4" + :start-revision rev-1 + :variants (list variant-2) + :instance-of type-2 + :themes (list theme-3 theme-2))) + (occ-1 (make-construct 'OccurrenceC :charvalue "cv-5" + :start-revision rev-1 + :themes (list theme-1) + :instance-of type-3))) + (let ((top-1 (make-construct 'TopicC :start-revision rev-1)) + (top-2 (make-construct 'TopicC :start-revision rev-1 + :item-identifiers (list ii-1 ii-2) + :psis (list psi-1 psi-2 psi-3) + :locators (list sl-1 sl-2) + :names (list name-1) + :occurrences (list occ-1)))) + (setf *TM-REVISION* rev-1) + (signals error (make-construct 'TopicC)) + (is-false (item-identifiers top-1)) + (is-false (psis top-1)) + (is-false (locators top-1)) + (is-false (names top-1)) + (is-false (occurrences top-1)) + (is (eql (find-item-by-revision top-1 rev-1) top-1)) + (is (= (length (item-identifiers top-2)) 2)) + (is (= (length (union (list ii-1 ii-2) (item-identifiers top-2))) 2)) + (is (= (length (locators top-2)) 2)) + (is (= (length (union (list sl-1 sl-2) (locators top-2))) 2)) + (is (= (length (psis top-2)) 3)) + (is (= (length (union (list psi-1 psi-2 psi-3) (psis top-2))) 3)) + (is (= (length (names top-2)) 1)) + (is (eql (first (names top-2)) name-1)) + (is (= (length (occurrences top-2)) 1)) + (is (eql (first (occurrences top-2)) occ-1)) + (is (eql (find-item-by-revision occ-1 rev-1 top-2) occ-1)) + (let ((top-3 (make-construct 'TopicC :start-revision rev-1 + :item-identifiers (list ii-2 ii-3) + :locators (list sl-3) + :names (list name-2)))) + (is (= (length (item-identifiers top-3)) 3)) + (is (= (length (union (list ii-1 ii-2 ii-3) + (item-identifiers top-3))) 3)) + (is (= (length (locators top-3)) 3)) + (is (= (length (union (list sl-1 sl-2 sl-3) (locators top-3))) 3)) + (is (= (length (psis top-3)) 3)) + (is (= (length (union (list psi-1 psi-2 psi-3) (psis top-3))) 3)) + (is (= (length (names top-3)) 2)) + (is (= (length (union (list name-1 name-2) (names top-3))) 2)) + (is (= (length (occurrences top-3)) 1)) + (is (eql (first (occurrences top-3)) occ-1)))))))) + + (defun run-datamodel-tests() @@ -2541,4 +2621,5 @@ (it.bese.fiveam:run! 'test-make-RoleC) (it.bese.fiveam:run! 'test-make-TopicMapC) (it.bese.fiveam:run! 'test-make-AssociationC) + (it.bese.fiveam:run! 'test-make-TopicC) ) \ No newline at end of file

1 0

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

24 Mar '10

Author: lgiessmann Date: Wed Mar 24 12:37:21 2010 New Revision: 252 Log: new-datamodel: added unit-tests for "make-construct" --> "AssociationC"; fixed a bug in "make-association" and "equivalent-construct" --> "AssociationC"; changed the general concept of creating associations 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 Mar 24 12:37:21 2010 @@ -1987,17 +1987,33 @@ &key (start-revision *TM-REVISION*) (roles nil) (instance-of nil) (themes nil)) "Associations are equal if their themes, instance-of and roles - properties are equal." + properties are equal. + To avoid ceation of duplicate roles the parameter roles is a list of plists + of the form: ((:player <TopicC> :instance-of <TopicC> + :item-identifiers <(ItemIdentifierC)> :reifier <TopicC>))." (declare (integer start-revision) (list roles themes) (type (or null TopicC) instance-of)) ;; item-identifiers and reifers are not checked because the equality have to ;; be variafied without them - (and - (not (set-exclusive-or roles (roles construct :revision start-revision))) - (equivalent-typable-construct construct instance-of - :start-revision start-revision) - (equivalent-scopable-construct construct themes - :start-revision start-revision))) + (let ((checked-roles + (loop for assoc-role in (roles construct :revision start-revision) + when (loop for plist in roles + when (equivalent-construct + assoc-role :player (getf plist :player) + :start-revision (or (getf plist :start-revision) + start-revision) + :instance-of (getf plist :instance-of)) + return t) + collect assoc-role))) + (and + (not (set-exclusive-or (roles construct :revision start-revision) + checked-roles)) + (= (length (roles construct :revision start-revision)) + (length roles)) + (equivalent-typable-construct construct instance-of + :start-revision start-revision) + (equivalent-scopable-construct construct themes + :start-revision start-revision)))) (defmethod delete-construct :before ((construct AssociationC)) @@ -2730,6 +2746,9 @@ :start-revision start-revision)) (when (typep construct 'VersionedConstructC) (add-to-version-history construct :start-revision start-revision)) + (when (or (typep construct 'TopicC) (typep construct 'AssociationC)) + (dolist (tm (getf args :in-topicmaps)) + (add-to-tm tm construct))) (if (typep construct 'ReifiableConstructC) (complete-reifiable construct (getf args :item-identifiers) (getf args :reifier) :start-revision start-revision) @@ -2742,8 +2761,8 @@ This function exists only for being used by make-construct!" (let ((instance-of (getf args :instance-of)) (start-revision (getf args :start-revision)) - (themes (get args :themes)) - (roles (get args :roles))) + (themes (getf args :themes)) + (roles (getf args :roles))) (when (and (or roles instance-of themes) (not start-revision)) (error "From make-association(): start-revision must be set")) @@ -2760,10 +2779,14 @@ existing-association)) (elephant:get-instances-by-class 'AssociationC))))) (if existing-association - existing-association + (first existing-association) (make-instance 'AssociationC))))) - (dolist (role roles) - (add-role association role :revision start-revision)) + (dolist (role-plist roles) + (add-role association + (apply #'make-construct 'RoleC + (append role-plist (list :parent association))) + :revision (getf role-plist :start-revision))) + (format t "~%~%~%") association))) @@ -2786,12 +2809,13 @@ (map 'list #'(lambda(existing-role) (when (equivalent-construct existing-role + :start-revision start-revision :player player :instance-of instance-of) existing-role)) - (slot-p parent 'roles)))))) + (map 'list #'role (slot-p parent 'roles))))))) (if existing-role - existing-role + (first existing-role) (make-instance 'RoleC))))) (when player (add-player role player :revision start-revision)) @@ -2914,7 +2938,7 @@ existing-characteristic)) (get-all-characteristics parent class-symbol)))))) (if existing-characteristic - existing-characteristic + (first existing-characteristic) (make-instance class-symbol :charvalue charvalue :datatype datatype))))) (when (typep characteristic 'NameC) 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 Mar 24 12:37:21 2010 @@ -70,7 +70,8 @@ :test-make-NameC :test-make-VariantC :test-make-RoleC - :test-make-TopicMapC)) + :test-make-TopicMapC + :test-make-AssociationC)) ;;TODO: test make-construct @@ -619,6 +620,7 @@ (version-1 100) (version-2 200) (version-3 300)) + (setf *TM-REVISION* version-1) (is-false (reifier reified-rc)) (is-false (reified-construct reifier-top)) (add-reifier reified-rc reifier-top :revision version-1) @@ -1125,7 +1127,7 @@ (name-2 (make-instance 'NameC)) (revision-1 100) (revision-2 200)) - (setf *TM-REVISION* 100) + (setf *TM-REVISION* revision-1) (add-item-identifier occ-1 ii-1 :revision revision-1) (add-item-identifier occ-1 ii-2 :revision revision-2) (delete-item-identifier occ-1 ii-1 :revision revision-2) @@ -1173,7 +1175,7 @@ (topic-4 (make-instance 'TopicC)) (revision-1 100) (revision-2 200)) - (setf *TM-REVISION* 100) + (setf *TM-REVISION* revision-1) (add-psi topic-1 psi-1 :revision revision-1) (add-psi topic-1 psi-2 :revision revision-2) (delete-psi topic-1 psi-1 :revision revision-2) @@ -1218,7 +1220,7 @@ (topic-4 (make-instance 'TopicC)) (revision-1 100) (revision-2 200)) - (setf *TM-REVISION* 100) + (setf *TM-REVISION* revision-1) (add-locator topic-1 sl-1 :revision revision-1) (add-locator topic-1 sl-2 :revision revision-2) (delete-locator topic-1 sl-1 :revision revision-2) @@ -1675,34 +1677,66 @@ (test test-equivalent-AssociationC () "Tests the functions equivalent-construct depending on AssociationC." (with-fixture with-empty-db (*db-dir*) - (let ((assoc-1 (make-instance 'd:AssociationC)) - (role-1 (make-instance 'd:RoleC)) - (role-2 (make-instance 'd:RoleC)) - (role-3 (make-instance 'd:RoleC)) - (type-1 (make-instance 'd:TopicC)) - (type-2 (make-instance 'd:TopicC)) - (scope-1 (make-instance 'd:TopicC)) - (scope-2 (make-instance 'd:TopicC)) - (scope-3 (make-instance 'd:TopicC)) + (let ((player-1 (make-instance 'TopicC)) + (player-2 (make-instance 'TopicC)) + (player-3 (make-instance 'TopicC)) + (r-type-1 (make-instance 'TopicC)) + (r-type-2 (make-instance 'TopicC)) + (r-type-3 (make-instance 'TopicC)) (revision-1 100)) - (setf *TM-REVISION* revision-1) - (d:add-role assoc-1 role-1) - (d:add-role assoc-1 role-2) - (d:add-type assoc-1 type-1) - (d:add-theme assoc-1 scope-1) - (d:add-theme assoc-1 scope-2) - (is-true (d::equivalent-construct - assoc-1 :roles (list role-1 role-2) :instance-of type-1 - :themes (list scope-1 scope-2))) - (is-false (d::equivalent-construct - assoc-1 :roles (list role-1 role-2 role-3) :instance-of type-1 - :themes (list scope-1 scope-2))) - (is-false (d::equivalent-construct - assoc-1 :roles (list role-1 role-2) :instance-of type-2 - :themes (list scope-1 scope-2))) - (is-false (d::equivalent-construct - assoc-1 :roles (list role-1 role-2) :instance-of type-1 - :themes (list scope-1 scope-3 scope-2)))))) + (let ((assoc-1 (make-instance 'd:AssociationC)) + (role-1 (make-construct 'd:RoleC + :start-revision revision-1 + :player player-1 + :instance-of r-type-1)) + (role-2 (make-construct 'd:RoleC + :start-revision revision-1 + :player player-2 + :instance-of r-type-2)) + (type-1 (make-instance 'd:TopicC)) + (type-2 (make-instance 'd:TopicC)) + (scope-1 (make-instance 'd:TopicC)) + (scope-2 (make-instance 'd:TopicC)) + (scope-3 (make-instance 'd:TopicC))) + (setf *TM-REVISION* revision-1) + (d:add-role assoc-1 role-1) + (d:add-role assoc-1 role-2) + (d:add-type assoc-1 type-1) + (d:add-theme assoc-1 scope-1) + (d:add-theme assoc-1 scope-2) + (is-true (d::equivalent-construct + assoc-1 :roles (list + (list :instance-of r-type-1 :player player-1 + :start-revision revision-1) + (list :instance-of r-type-2 :player player-2 + :start-revision revision-1)) + :instance-of type-1 :themes (list scope-1 scope-2) + :start-revision revision-1)) + (is-false (d::equivalent-construct + assoc-1 :roles (list + (list :instance-of r-type-1 :player player-1) + (list :instance-of r-type-2 :player player-2) + (list :instance-of r-type-3 :player player-3)) + :instance-of type-1 :themes (list scope-1 scope-2))) + (is-false (d::equivalent-construct + assoc-1 :roles (list + (list :instance-of r-type-1 :player player-1)) + :instance-of type-1 :themes (list scope-1 scope-2))) + (is-false (d::equivalent-construct + assoc-1 :roles (list + (list :instance-of r-type-1 :player player-1) + (list :instance-of r-type-3 :player player-3)) + :instance-of type-1 :themes (list scope-1 scope-2))) + (is-false (d::equivalent-construct + assoc-1 :roles (list + (list :instance-of r-type-1 :player player-1) + (list :instance-of r-type-2 :player player-2)) + :instance-of type-2 :themes (list scope-1 scope-2))) + (is-false (d::equivalent-construct + assoc-1 :roles (list + (list :instance-of r-type-1 :player player-1) + (list :instance-of r-type-2 :player player-2)) + :instance-of type-2 :themes (list scope-1 scope-3))))))) (test test-equivalent-TopicC () @@ -1888,11 +1922,10 @@ (test test-make-Unknown () "Tests the function make-construct corresponding to an unknown class." (defclass Unknown () - ((value :initarg :value - :accessor value))) + ((value :initarg :value))) (let ((construct (make-construct 'Unknown :value "value"))) (is-true construct) - (is (string= (value construct) "value")))) + (is (string= (slot-value construct 'value) "value")))) (test test-make-VersionedConstructC () @@ -1903,6 +1936,7 @@ (rev-0 0) (rev-1 100) (rev-2 200)) + (setf *TM-REVISION* rev-1) (let ((vc (make-construct 'VersionedConstructC :start-revision rev-2)) (psi-assoc (make-construct 'd::PersistentIdAssociationC @@ -1912,6 +1946,7 @@ (signals error (make-construct 'd::PersistentIdAssociationC :start-revision rev-1 :identifier psi-1)) + (setf *TM-REVISION* rev-1) (signals error (make-construct 'VersionedConstructC)) (is (= (length (d::versions vc)) 1)) (is-true (find-if #'(lambda(vi) @@ -1942,6 +1977,9 @@ :uri "uri")) (signals error (make-construct 'TopicIdentificationC :xtm-id "xtm-id")) + (setf *TM-REVISION* rev-1) + (signals error (make-construct 'TopicIdentificationC :uri "uri" + :identified-construct top-1)) (is (string= (uri tid-1) "tid-1")) (is (string= (xtm-id tid-1) "xtm-id-1")) (is-false (d::slot-p tid-1 'd::identified-construct)) @@ -1975,7 +2013,10 @@ :uri "psi-2" :identified-construct top-1 :start-revision rev-1))) + (setf *TM-REVISION* rev-1) (signals error (make-construct 'PersistentIdC)) + (signals error (make-construct 'PersistentIdC :uri "uri" + :identified-construct top-1)) (is (string= (uri psi-1) "psi-1")) (is-false (d::slot-p psi-1 'd::identified-construct)) (is (string= (uri psi-2) "psi-2")) @@ -2007,7 +2048,10 @@ :uri "sl-2" :identified-construct top-1 :start-revision rev-1))) + (setf *TM-REVISION* rev-1) (signals error (make-construct 'SubjectLocatorC)) + (signals error (make-construct 'SubjectLocatorC :uri "uri" + :identified-construct top-1)) (is (string= (uri sl-1) "sl-1")) (is-false (d::slot-p sl-1 'd::identified-construct)) (is (string= (uri sl-2) "sl-2")) @@ -2039,7 +2083,10 @@ :uri "ii-2" :identified-construct top-1 :start-revision rev-1))) + (setf *TM-REVISION* rev-1) (signals error (make-construct 'ItemIdentifierC)) + (signals error (make-construct 'ItemIdentifierC :uri "uri" + :identified-construct top-1)) (is (string= (uri ii-1) "ii-1")) (is-false (d::slot-p ii-1 'd::identified-construct)) (is (string= (uri ii-2) "ii-2")) @@ -2085,6 +2132,7 @@ :charvalue "charvalue-2" :parent top-1 :start-revision rev-1))) + (setf *TM-REVISION* rev-1) (signals error (make-construct 'OccurrenceC :item-identifiers (list ii-1))) (signals error (make-construct 'OccurrenceC :reifier reifier-1)) @@ -2141,6 +2189,7 @@ :charvalue "charvalue-2" :parent top-1 :start-revision rev-1))) + (setf *TM-REVISION* rev-1) (signals error (make-construct 'NameC :item-identifiers (list ii-1))) (signals error (make-construct 'NameC :reifier reifier-1)) @@ -2195,6 +2244,7 @@ :charvalue "charvalue-2" :parent name-1 :start-revision rev-1))) + (setf *TM-REVISION* rev-1) (signals error (make-construct 'VariantC :item-identifiers (list ii-1))) (signals error (make-construct 'VariantC :reifier reifier-1)) @@ -2243,6 +2293,7 @@ (role-3 (make-construct 'RoleC :parent assoc-1 :start-revision rev-1))) + (setf *TM-REVISION* rev-1) (signals error (make-construct 'RoleC :item-identifiers (list ii-1))) (signals error (make-construct 'RoleC :reifier reifier-1)) @@ -2266,7 +2317,6 @@ (is (eql role-3 (find-item-by-revision role-3 rev-1 assoc-1))))))) - (test test-make-TopicMapC () "Tests the function make-construct corresponding to TopicMapC." (with-fixture with-empty-db (*db-dir*) @@ -2291,6 +2341,7 @@ (tm-2 (make-construct 'TopicMapC :start-revision rev-1 :item-identifiers (list ii-3)))) + (setf *TM-REVISION* rev-1) (signals error (make-construct 'TopicMapC)) (is (eql (reifier tm-1) reifier-1)) (is (= (length (item-identifiers tm-1)) 2)) @@ -2323,6 +2374,117 @@ (is (eql (find-item-by-revision tm-3 rev-1) tm-3))))))) +(test test-make-AssociationC () + "Tests the function make-construct corresponding to TopicMapC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (player-1 (make-instance 'TopicC)) + (player-2 (make-instance 'TopicC)) + (type-1 (make-instance 'TopicC)) + (r-type-1 (make-instance 'TopicC)) + (r-type-2 (make-instance 'TopicC)) + (theme-1 (make-instance 'TopicC)) + (theme-2 (make-instance 'TopicC)) + (reifier-1 (make-instance 'TopicC)) + (r-reifier-1 (make-instance 'TopicC)) + (ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC :uri "ii-2")) + (r-ii-1 (make-construct 'ItemIdentifierC :uri "r-ii-1")) + (r-ii-2 (make-construct 'ItemIdentifierC :uri "r-ii-2")) + (r-ii-3 (make-construct 'ItemIdentifierC :uri "r-ii-3"))) + (let ((role-1 (list :item-identifiers (list r-ii-1) :player player-1 + :instance-of r-type-1 :reifier r-reifier-1 + :start-revision rev-1)) + (role-2 (list :item-identifiers (list r-ii-2 r-ii-3) + :player player-2 :instance-of r-type-2 + :start-revision rev-1)) + (role-2-2 (list :player player-2 :instance-of r-type-2 + :start-revision rev-1)) + (tm-1 (make-construct 'TopicMapC :start-revision rev-1)) + (tm-2 (make-construct 'TopicMapC :start-revision rev-1))) + (let ((assoc-1 (make-construct 'AssociationC + :start-revision rev-1 + :instance-of type-1 + :themes (list theme-1 theme-2) + :item-identifiers (list ii-1 ii-2) + :reifier reifier-1 + :in-topicmaps (list tm-1 tm-2) + :roles (list role-1 role-2 role-2-2))) + (assoc-2 (make-construct 'AssociationC :start-revision rev-1))) + (setf *TM-REVISION* rev-1) + (signals error (make-construct 'AssociationC)) + (signals error (make-construct 'AssociationC + :start-revision rev-1 + :roles (list + (list :player player-1 + :instance-of r-type-1)))) + (is (eql (instance-of assoc-1) type-1)) + (is-true (themes assoc-1)) + (is (= (length (union (list theme-1 theme-2) (themes assoc-1))) 2)) + (is-true (item-identifiers assoc-1)) + (is (= (length (union (list ii-1 ii-2) (item-identifiers assoc-1))) 2)) + (is (eql (reifier assoc-1) reifier-1)) + (is-true (in-topicmaps assoc-1)) + (is (= (length (union (list tm-1 tm-2) (in-topicmaps assoc-1))) 2)) + (is (= (length (roles assoc-1)) 2)) + (is (= (length + (remove-if + #'null + (map + 'list + #'(lambda(role) + (when (or (and (eql (player role :revision rev-1) + player-1) + (eql (instance-of role :revision rev-1) + r-type-1) + (= (length (item-identifiers + role :revision rev-1)) 1) + (string= + (uri (first (item-identifiers role))) + "r-ii-1")) + (and (eql (player role :revision rev-1) + player-2) + (eql (instance-of role :revision rev-1) + r-type-2) + (= (length (item-identifiers role)) 2) + (let ((uri-1 + (uri (first + (item-identifiers + role :revision rev-1)))) + (uri-2 + (uri (second + (item-identifiers + role :revision rev-1))))) + (and (or (string= uri-1 "r-ii-2") + (string= uri-2 "r-ii-2")) + (or (string= uri-1 "r-ii-3") + (string= uri-2 "r-ii-3")))))) + role)) + (roles assoc-1 :revision rev-1)))) + 2)) + (is (eql (find-item-by-revision assoc-1 rev-1) assoc-1)) + (is-false (item-identifiers assoc-2)) + (is-false (reifier assoc-2)) + (is-false (instance-of assoc-2)) + (is-false (themes assoc-2)) + (is-false (roles assoc-2)) + (is-false (in-topicmaps assoc-2)) + (let ((assoc-3 (make-construct 'AssociationC + :start-revision rev-1 + :roles (list role-1 role-2) + :instance-of type-1 + :themes (list theme-1 theme-2)))) + (is (eql (instance-of assoc-3) type-1)) + (is-true (themes assoc-3)) + (is (= (length (union (list theme-1 theme-2) (themes assoc-3))) 2)) + (is-true (item-identifiers assoc-3)) + (is (= (length (union (list ii-1 ii-2) (item-identifiers assoc-3))) 2)) + (is (eql (reifier assoc-3) reifier-1)) + (is-true (in-topicmaps assoc-3)) + (is (= (length (union (list tm-1 tm-2) (in-topicmaps assoc-3))) 2)) + (is (= (length (roles assoc-3)) 2)))))))) + + (defun run-datamodel-tests() @@ -2378,4 +2540,5 @@ (it.bese.fiveam:run! 'test-make-VariantC) (it.bese.fiveam:run! 'test-make-RoleC) (it.bese.fiveam:run! 'test-make-TopicMapC) + (it.bese.fiveam:run! 'test-make-AssociationC) ) \ No newline at end of file

1 0

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

24 Mar '10

Author: lgiessmann Date: Wed Mar 24 05:47:39 2010 New Revision: 251 Log: new-datamodel: added unit-tests for "make-construct" --> "TopicMapC"; fixed a parameter bug in "make-tm" and "make-association" 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 Mar 24 05:47:39 2010 @@ -2736,7 +2736,7 @@ construct))) -(defun make-association (args) +(defun make-association (&rest args) "Returns an association object. If the association has already existed the existing one is returned otherwise a new one is created. This function exists only for being used by make-construct!" @@ -2800,7 +2800,7 @@ role))) -(defun make-tm (args) +(defun make-tm (&rest args) "Returns a topic map object. If the topic map has already existed the existing one is returned otherwise a new one is created. This function exists only for being used by make-construct!" 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 Mar 24 05:47:39 2010 @@ -69,7 +69,8 @@ :test-make-OccurrenceC :test-make-NameC :test-make-VariantC - :test-make-RoleC)) + :test-make-RoleC + :test-make-TopicMapC)) ;;TODO: test make-construct @@ -2266,6 +2267,64 @@ +(test test-make-TopicMapC () + "Tests the function make-construct corresponding to TopicMapC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-1 100) + (top-1 (make-instance 'TopicC)) + (top-2 (make-instance 'TopicC)) + (top-3 (make-instance 'TopicC)) + (assoc-1 (make-instance 'AssociationC)) + (assoc-2 (make-instance 'AssociationC)) + (assoc-3 (make-instance 'AssociationC)) + (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2")) + (ii-3 (make-instance 'ItemIdentifierC :uri "ii-3")) + (ii-4 (make-instance 'ItemIdentifierC :uri "ii-4")) + (reifier-1 (make-instance 'TopicC))) + (let ((tm-1 (make-construct 'TopicMapC + :start-revision rev-1 + :topics (list top-1 top-2) + :associations (list assoc-1 assoc-2) + :item-identifiers (list ii-1 ii-2) + :reifier reifier-1)) + (tm-2 (make-construct 'TopicMapC + :start-revision rev-1 + :item-identifiers (list ii-3)))) + (signals error (make-construct 'TopicMapC)) + (is (eql (reifier tm-1) reifier-1)) + (is (= (length (item-identifiers tm-1)) 2)) + (is (= (length (union (item-identifiers tm-1) (list ii-1 ii-2))) 2)) + (is (= (length (topics tm-1)) 2)) + (is (= (length (union (topics tm-1) (list top-1 top-2))) 2)) + (is (= (length (associations tm-1)) 2)) + (is (= (length (union (associations tm-1) (list assoc-1 assoc-2))) 2)) + (is (eql (find-item-by-revision tm-1 rev-1) tm-1)) + (is (= (length (item-identifiers tm-2)) 1)) + (is (= (length (union (item-identifiers tm-2) (list ii-3))) 1)) + (is-false (topics tm-2)) + (is-false (associations tm-2)) + (is-false (reifier tm-2)) + (let ((tm-3 (make-construct 'TopicMapC + :start-revision rev-1 + :topics (list top-3) + :associations (list assoc-3) + :item-identifiers (list ii-2 ii-4)))) + (is (eql (reifier tm-3) reifier-1)) + (is (= (length (item-identifiers tm-3)) 3)) + (is (= (length (union (item-identifiers tm-3) (list ii-1 ii-2 ii-4))) + 3)) + (is (= (length (topics tm-3)) 3)) + (is (= (length (union (topics tm-3) (list top-1 top-2 top-3))) 3)) + (is (= (length (associations tm-3)) 3)) + (is (= (length (union (associations tm-3) + (list assoc-1 assoc-2 assoc-3))) + 3)) + (is (eql (find-item-by-revision tm-3 rev-1) tm-3))))))) + + + + (defun run-datamodel-tests() "Runs all tests of this test-suite." (it.bese.fiveam:run! 'test-VersionInfoC) @@ -2318,4 +2377,5 @@ (it.bese.fiveam:run! 'test-make-NameC) (it.bese.fiveam:run! 'test-make-VariantC) (it.bese.fiveam:run! 'test-make-RoleC) + (it.bese.fiveam:run! 'test-make-TopicMapC) ) \ No newline at end of file

1 0

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

24 Mar '10

Author: lgiessmann Date: Wed Mar 24 05:18:11 2010 New Revision: 250 Log: new-datamodel: added unit-tests for "make-conmstruct" --> "RoleC"; fixed 2 bugs in "make-role" 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 Mar 24 05:18:11 2010 @@ -2767,7 +2767,7 @@ association))) -(defun make-role (args) +(defun make-role (&rest args) "Returns a role object. If the role has already existed the existing one is returned otherwise a new one is created. This function exists only for being used by make-construct!" @@ -2780,15 +2780,16 @@ (error "From make-role(): start-revision must be set")) (let ((role (let ((existing-role - (remove-if - #'null - (map 'list #'(lambda(existing-role) - (when (equivalent-construct - existing-role - :player player - :instance-of instance-of) - existing-role)) - (slot-p parent 'roles))))) + (when parent + (remove-if + #'null + (map 'list #'(lambda(existing-role) + (when (equivalent-construct + existing-role + :player player + :instance-of instance-of) + existing-role)) + (slot-p parent 'roles)))))) (if existing-role existing-role (make-instance 'RoleC))))) 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 Mar 24 05:18:11 2010 @@ -68,7 +68,8 @@ :test-make-ItemIdentifierC :test-make-OccurrenceC :test-make-NameC - :test-make-VariantC)) + :test-make-VariantC + :test-make-RoleC)) ;;TODO: test make-construct @@ -2219,6 +2220,50 @@ (is (eql variant-3 (find-item-by-revision variant-3 rev-1 name-1))))))) +(test test-make-RoleC () + "Tests the function make-construct corresponding to RoleC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-0-5 50) + (rev-1 100) + (type-1 (make-instance 'TopicC)) + (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2")) + (player-1 (make-instance 'TopicC)) + (reifier-1 (make-instance 'TopicC)) + (assoc-1 (make-instance 'AssociationC))) + (setf *TM-REVISION* rev-1) + (let ((role-1 (make-construct 'RoleC)) + (role-2 (make-construct 'RoleC + :item-identifiers (list ii-1 ii-2) + :player player-1 + :reifier reifier-1 + :instance-of type-1 + :start-revision rev-1)) + (role-3 (make-construct 'RoleC + :parent assoc-1 + :start-revision rev-1))) + (signals error (make-construct 'RoleC + :item-identifiers (list ii-1))) + (signals error (make-construct 'RoleC :reifier reifier-1)) + (signals error (make-construct 'RoleC :parent assoc-1)) + (signals error (make-construct 'RoleC :instance-of type-1)) + (signals error (make-construct 'RoleC :player player-1)) + (is-false (item-identifiers role-1)) + (is-false (reifier role-1)) + (is-false (instance-of role-1)) + (is-false (parent role-1)) + (is-false (player role-1)) + (is-true (item-identifiers role-2)) + (is (= (length (union (list ii-1 ii-2) (item-identifiers role-2))) 2)) + (is (eql (reifier role-2) reifier-1)) + (is (eql (instance-of role-2) type-1)) + (is-false (parent role-2)) + (is (eql (player role-2) player-1)) + (is (eql ii-1 (find-item-by-revision ii-1 rev-1 role-2))) + (is-false (item-identifiers role-2 :revision rev-0-5)) + (is (eql (parent role-3) assoc-1)) + (is (eql role-3 (find-item-by-revision role-3 rev-1 assoc-1))))))) + (defun run-datamodel-tests() @@ -2272,4 +2317,5 @@ (it.bese.fiveam:run! 'test-make-OccurrenceC) (it.bese.fiveam:run! 'test-make-NameC) (it.bese.fiveam:run! 'test-make-VariantC) + (it.bese.fiveam:run! 'test-make-RoleC) ) \ No newline at end of file

1 0

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

23 Mar '10

Author: lgiessmann Date: Tue Mar 23 14:45:50 2010 New Revision: 249 Log: new-datamodel: added unit-tests for "make-construct" corresponding to "OccurrenceC", "NameC" and "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 Tue Mar 23 14:45:50 2010 @@ -981,16 +981,17 @@ (slot-p construct 'identified-construct))))) (when assocs (first assocs))))) - (cond ((= revision 0) - (find-most-recent-revision parent-assoc)) - (t - (when (find-if - #'(lambda(vi) - (and (>= revision (start-revision vi)) - (or (< revision (end-revision vi)) - (= 0 (end-revision vi))))) - (versions parent-assoc)) - construct)))) + (when parent-assoc + (cond ((= revision 0) + (find-most-recent-revision parent-assoc)) + (t + (when (find-if + #'(lambda(vi) + (and (>= revision (start-revision vi)) + (or (< revision (end-revision vi)) + (= 0 (end-revision vi))))) + (versions parent-assoc)) + construct))))) nil)) @@ -1754,18 +1755,19 @@ (slot-p construct 'parent))))) (when assocs (first assocs))))) - (cond ((= revision 0) - (when - (find-most-recent-revision parent-assoc) - construct)) - (t - (when (find-if - #'(lambda(vi) - (and (>= revision (start-revision vi)) - (or (< revision (end-revision vi)) - (= 0 (end-revision vi))))) - (versions parent-assoc)) - construct)))) + (when parent-assoc + (cond ((= revision 0) + (when + (find-most-recent-revision parent-assoc) + construct)) + (t + (when (find-if + #'(lambda(vi) + (and (>= revision (start-revision vi)) + (or (< revision (end-revision vi)) + (= 0 (end-revision vi))))) + (versions parent-assoc)) + construct))))) nil)) @@ -2084,29 +2086,32 @@ (defmethod find-item-by-revision ((construct RoleC) (revision integer) &optional parent-construct) - (let ((parent-assoc - (let ((assocs - (remove-if - #'null - (map 'list #'(lambda(assoc) - (when (eql (parent-construct assoc) - parent-construct) - assoc)) - (slot-p construct 'parent))))) - (when assocs - (first assocs))))) - (cond ((= revision 0) - (when - (find-most-recent-revision parent-assoc) - construct)) - (t - (when (find-if - #'(lambda(vi) - (and (>= revision (start-revision vi)) - (or (< revision (end-revision vi)) - (= 0 (end-revision vi))))) - (versions parent-assoc)) - construct))))) + (if parent-construct + (let ((parent-assoc + (let ((assocs + (remove-if + #'null + (map 'list #'(lambda(assoc) + (when (eql (parent-construct assoc) + parent-construct) + assoc)) + (slot-p construct 'parent))))) + (when assocs + (first assocs))))) + (when parent-assoc + (cond ((= revision 0) + (when + (find-most-recent-revision parent-assoc) + construct)) + (t + (when (find-if + #'(lambda(vi) + (and (>= revision (start-revision vi)) + (or (< revision (end-revision vi)) + (= 0 (end-revision vi))))) + (versions parent-assoc)) + construct))))) + nil)) (defmethod delete-construct :before ((construct RoleC)) @@ -2692,7 +2697,9 @@ history accordingly. Returns the object in question. Methods use specific keyword arguments for their purpose." (declare (symbol class-symbol)) - (when (and (VersionedConstructC-p class-symbol) + (when (and (or (VersionedConstructC-p class-symbol) + (and (ReifiableConstructC-p class-symbol) + (or (getf args :item-identifiers) (getf args :reifier)))) (not (getf args :start-revision))) (error "From make-construct(): start-revision must be set")) (let ((construct @@ -2714,7 +2721,7 @@ (rec-remf args :start-revision))) (t (apply #'make-instance class-symbol args)))) - (start-revision (getf args :start-revision))) + (start-revision (or (getf args :start-revision) *TM-REVISION*))) (when (typep construct 'TypableC) (complete-typable construct (getf args :instance-of) :start-revision start-revision)) @@ -2724,7 +2731,7 @@ (when (typep construct 'VersionedConstructC) (add-to-version-history construct :start-revision start-revision)) (if (typep construct 'ReifiableConstructC) - (complete-reifiable construct (getf args :item-identtifiers) + (complete-reifiable construct (getf args :item-identifiers) (getf args :reifier) :start-revision start-revision) construct))) @@ -2881,9 +2888,9 @@ To check if there is existing an equivalent construct the parameter parent-construct must be set. This function only exists for being used by make-construct!" - (let ((charvalue (getf args :charvalue)) + (let ((charvalue (or (getf args :charvalue) "")) (start-revision (getf args :start-revision)) - (datatype (getf args :datatype)) + (datatype (or (getf args :datatype) *xml-string*)) (instance-of (getf args :instance-of)) (themes (getf args :themes)) (variants (getf args :variants)) @@ -2909,7 +2916,8 @@ existing-characteristic (make-instance class-symbol :charvalue charvalue :datatype datatype))))) - (complete-name characteristic variants :start-revision start-revision) + (when (typep characteristic 'NameC) + (complete-name characteristic variants :start-revision start-revision)) (when parent (add-parent characteristic parent :revision start-revision)) characteristic))) @@ -2922,9 +2930,15 @@ (let ((uri (getf args :uri)) (xtm-id (getf args :xtm-id)) (start-revision (getf args :start-revision)) - (identified-construct (getf args :identified-construct))) + (identified-construct (getf args :identified-construct)) + (err "From make-pointer(): ")) (when (and identified-construct (not start-revision)) - (error "From make-pointer(): start-revision must be set")) + (error "~astart-revision must be set" err)) + (unless uri + (error "~auri must be set" err)) + (when (and (TopicIdentificationC-p class-symbol) + (not xtm-id)) + (error "~axtm-id must be set" err)) (let ((identifier (let ((existing-pointer (remove-if Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/datamodel_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp Tue Mar 23 14:45:50 2010 @@ -65,7 +65,10 @@ :test-make-TopicIdentificationC :test-make-PersistentIdC :test-make-SubjectLocatorC - :test-make-ItemIdentifierC)) + :test-make-ItemIdentifierC + :test-make-OccurrenceC + :test-make-NameC + :test-make-VariantC)) ;;TODO: test make-construct @@ -1887,7 +1890,7 @@ :accessor value))) (let ((construct (make-construct 'Unknown :value "value"))) (is-true construct) - (string= (value construct) "value"))) + (is (string= (value construct) "value")))) (test test-make-VersionedConstructC () @@ -1933,6 +1936,10 @@ :uri "tid-2" :xtm-id "xtm-id-2" :identified-construct top-1 :start-revision rev-1))) + (signals error (make-construct 'TopicIdentificationC + :uri "uri")) + (signals error (make-construct 'TopicIdentificationC + :xtm-id "xtm-id")) (is (string= (uri tid-1) "tid-1")) (is (string= (xtm-id tid-1) "xtm-id-1")) (is-false (d::slot-p tid-1 'd::identified-construct)) @@ -1966,6 +1973,7 @@ :uri "psi-2" :identified-construct top-1 :start-revision rev-1))) + (signals error (make-construct 'PersistentIdC)) (is (string= (uri psi-1) "psi-1")) (is-false (d::slot-p psi-1 'd::identified-construct)) (is (string= (uri psi-2) "psi-2")) @@ -1997,6 +2005,7 @@ :uri "sl-2" :identified-construct top-1 :start-revision rev-1))) + (signals error (make-construct 'SubjectLocatorC)) (is (string= (uri sl-1) "sl-1")) (is-false (d::slot-p sl-1 'd::identified-construct)) (is (string= (uri sl-2) "sl-2")) @@ -2028,6 +2037,7 @@ :uri "ii-2" :identified-construct top-1 :start-revision rev-1))) + (signals error (make-construct 'ItemIdentifierC)) (is (string= (uri ii-1) "ii-1")) (is-false (d::slot-p ii-1 'd::identified-construct)) (is (string= (uri ii-2) "ii-2")) @@ -2045,7 +2055,168 @@ (is (eql (identified-construct ii-2 :revision rev-1) top-1)) (is-false (identified-construct ii-2 :revision rev-0-5)) (is (eql (find-item-by-revision ii-2 rev-1 top-1) ii-2)))))) - + + +(test test-make-OccurrenceC () + "Tests the function make-construct corresponding to OccurrenceC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-0-5 50) + (rev-1 100) + (type-1 (make-instance 'TopicC)) + (theme-1 (make-instance 'TopicC)) + (theme-2 (make-instance 'TopicC)) + (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2")) + (reifier-1 (make-instance 'TopicC)) + (top-1 (make-instance 'TopicC))) + (setf *TM-REVISION* rev-1) + (let ((occ-1 (make-construct 'OccurrenceC)) + (occ-2 (make-construct 'OccurrenceC + :charvalue "charvalue" + :datatype "datatype" + :item-identifiers (list ii-1 ii-2) + :reifier reifier-1 + :instance-of type-1 + :themes (list theme-1 theme-2) + :start-revision rev-1)) + (occ-3 (make-construct 'OccurrenceC + :charvalue "charvalue-2" + :parent top-1 + :start-revision rev-1))) + (signals error (make-construct 'OccurrenceC + :item-identifiers (list ii-1))) + (signals error (make-construct 'OccurrenceC :reifier reifier-1)) + (signals error (make-construct 'OccurrenceC :parent top-1)) + (signals error (make-construct 'OccurrenceC :instance-of type-1)) + (signals error (make-construct 'OccurrenceC :themes (list theme-1))) + (is (string= (charvalue occ-1) "")) + (is (string= (datatype occ-1) *xml-string*)) + (is-false (item-identifiers occ-1)) + (is-false (reifier occ-1)) + (is-false (instance-of occ-1)) + (is-false (themes occ-1)) + (is-false (parent occ-1)) + (is (string= (charvalue occ-2) "charvalue")) + (is (string= (datatype occ-2) "datatype")) + (is-true (item-identifiers occ-2)) + (is (= (length (union (list ii-1 ii-2) (item-identifiers occ-2))) 2)) + (is (eql (reifier occ-2) reifier-1)) + (is (eql (instance-of occ-2) type-1)) + (is-true (themes occ-2)) + (is (= (length (union (list theme-1 theme-2) (themes occ-2))) 2)) + (is-false (parent occ-2)) + (is (eql ii-1 (find-item-by-revision ii-1 rev-1 occ-2))) + (is-false (item-identifiers occ-2 :revision rev-0-5)) + (is (eql (parent occ-3) top-1)) + (is (eql occ-3 (find-item-by-revision occ-3 rev-1 top-1))))))) + + +(test test-make-NameC () + "Tests the function make-construct corresponding to NameC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-0-5 50) + (rev-1 100) + (type-1 (make-instance 'TopicC)) + (theme-1 (make-instance 'TopicC)) + (theme-2 (make-instance 'TopicC)) + (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2")) + (reifier-1 (make-instance 'TopicC)) + (variant-1 (make-instance 'VariantC)) + (variant-2 (make-instance 'VariantC)) + (top-1 (make-instance 'TopicC))) + (setf *TM-REVISION* rev-1) + (let ((name-1 (make-construct 'NameC)) + (name-2 (make-construct 'NameC + :charvalue "charvalue" + :variants (list variant-1 variant-2) + :item-identifiers (list ii-1 ii-2) + :reifier reifier-1 + :instance-of type-1 + :themes (list theme-1 theme-2) + :start-revision rev-1)) + (name-3 (make-construct 'NameC + :charvalue "charvalue-2" + :parent top-1 + :start-revision rev-1))) + (signals error (make-construct 'NameC + :item-identifiers (list ii-1))) + (signals error (make-construct 'NameC :reifier reifier-1)) + (signals error (make-construct 'NameC :parent top-1)) + (signals error (make-construct 'NameC :instance-of type-1)) + (signals error (make-construct 'NameC :themes (list theme-1))) + (signals error (make-construct 'NameC :variants (list variant-1))) + (is (string= (charvalue name-1) "")) + (is-false (item-identifiers name-1)) + (is-false (reifier name-1)) + (is-false (instance-of name-1)) + (is-false (themes name-1)) + (is-false (parent name-1)) + (is-false (variants name-1)) + (is (string= (charvalue name-2) "charvalue")) + (is-true (item-identifiers name-2)) + (is (= (length (union (list ii-1 ii-2) (item-identifiers name-2))) 2)) + (is (eql (reifier name-2) reifier-1)) + (is (eql (instance-of name-2) type-1)) + (is-true (themes name-2)) + (is (= (length (union (list theme-1 theme-2) (themes name-2))) 2)) + (is-true (variants name-2)) + (is (= (length (union (list variant-1 variant-2) (variants name-2))) 2)) + (is-false (parent name-2)) + (is (eql ii-1 (find-item-by-revision ii-1 rev-1 name-2))) + (is-false (item-identifiers name-2 :revision rev-0-5)) + (is (eql (parent name-3) top-1)) + (is (eql name-3 (find-item-by-revision name-3 rev-1 top-1))))))) + + +(test test-make-VariantC () + "Tests the function make-construct corresponding to VariantC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-0-5 50) + (rev-1 100) + (theme-1 (make-instance 'TopicC)) + (theme-2 (make-instance 'TopicC)) + (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-instance 'ItemIdentifierC :uri "ii-2")) + (reifier-1 (make-instance 'TopicC)) + (name-1 (make-instance 'NameC))) + (setf *TM-REVISION* rev-1) + (let ((variant-1 (make-construct 'VariantC)) + (variant-2 (make-construct 'VariantC + :charvalue "charvalue" + :datatype "datatype" + :item-identifiers (list ii-1 ii-2) + :reifier reifier-1 + :themes (list theme-1 theme-2) + :start-revision rev-1)) + (variant-3 (make-construct 'VariantC + :charvalue "charvalue-2" + :parent name-1 + :start-revision rev-1))) + (signals error (make-construct 'VariantC + :item-identifiers (list ii-1))) + (signals error (make-construct 'VariantC :reifier reifier-1)) + (signals error (make-construct 'VariantC :parent name-1)) + (signals error (make-construct 'VariantC :themes (list theme-1))) + (is (string= (charvalue variant-1) "")) + (is (string= (datatype variant-1) *xml-string*)) + (is-false (item-identifiers variant-1)) + (is-false (reifier variant-1)) + (is-false (instance-of variant-1)) + (is-false (themes variant-1)) + (is-false (parent variant-1)) + (is (string= (charvalue variant-2) "charvalue")) + (is (string= (datatype variant-2) "datatype")) + (is-true (item-identifiers variant-2)) + (is (= (length (union (list ii-1 ii-2) (item-identifiers variant-2))) 2)) + (is (eql (reifier variant-2) reifier-1)) + (is-true (themes variant-2)) + (is (= (length (union (list theme-1 theme-2) (themes variant-2))) 2)) + (is-false (parent variant-2)) + (is (eql ii-1 (find-item-by-revision ii-1 rev-1 variant-2))) + (is-false (item-identifiers variant-2 :revision rev-0-5)) + (is (eql (parent variant-3) name-1)) + (is (eql variant-3 (find-item-by-revision variant-3 rev-1 name-1))))))) @@ -2098,4 +2269,7 @@ (it.bese.fiveam:run! 'test-make-PersistentIdC) (it.bese.fiveam:run! 'test-make-SubjectLocatorC) (it.bese.fiveam:run! 'test-make-ItemIdentifierC) + (it.bese.fiveam:run! 'test-make-OccurrenceC) + (it.bese.fiveam:run! 'test-make-NameC) + (it.bese.fiveam:run! 'test-make-VariantC) ) \ No newline at end of file

1 0

[isidorus-cvs] r248 - branches/new-datamodel/src/unit_tests
by Lukas Giessmann 22 Mar '10

22 Mar '10

Author: lgiessmann Date: Mon Mar 22 17:58:31 2010 New Revision: 248 Log: new-datamodel: added unit-tests for "make-construct" related to "ItemIdentifierC", "PersistentIdC", "SubjectLocatorC" and "TopicIdentificationC" Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/datamodel_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp Mon Mar 22 17:58:31 2010 @@ -61,7 +61,11 @@ :test-class-p :test-find-item-by-revision :test-make-Unknown - :test-make-VersionedConstructC)) + :test-make-VersionedConstructC + :test-make-TopicIdentificationC + :test-make-PersistentIdC + :test-make-SubjectLocatorC + :test-make-ItemIdentifierC)) ;;TODO: test make-construct @@ -1916,6 +1920,134 @@ (d::versions psi-assoc))))))) +(test test-make-TopicIdentificationC () + "Tests the function make-construct corresponding to TopicIdentificationC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-0 0) + (rev-0-5 50) + (rev-1 100) + (top-1 (make-instance 'TopicC))) + (let ((tid-1 (make-construct 'TopicIdentificationC + :uri "tid-1" :xtm-id "xtm-id-1")) + (tid-2 (make-construct 'TopicIdentificationC + :uri "tid-2" :xtm-id "xtm-id-2" + :identified-construct top-1 + :start-revision rev-1))) + (is (string= (uri tid-1) "tid-1")) + (is (string= (xtm-id tid-1) "xtm-id-1")) + (is-false (d::slot-p tid-1 'd::identified-construct)) + (is (string= (uri tid-2) "tid-2")) + (is (string= (xtm-id tid-2) "xtm-id-2")) + (is (= (length (d::slot-p tid-2 'd::identified-construct)) 1)) + (is (= (length (d::versions + (first (d::slot-p tid-2 'd::identified-construct)))) 1)) + (is (= (d::start-revision + (first (d::versions + (first (d::slot-p tid-2 'd::identified-construct))))) + rev-1)) + (is (= (d::end-revision + (first (d::versions + (first (d::slot-p tid-2 'd::identified-construct))))) + rev-0)) + (is (eql (identified-construct tid-2 :revision rev-1) top-1)) + (is-false (identified-construct tid-2 :revision rev-0-5)) + (is (eql (find-item-by-revision tid-2 rev-1 top-1) tid-2)))))) + + +(test test-make-PersistentIdC () + "Tests the function make-construct corresponding to PersistentIdC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-0 0) + (rev-0-5 50) + (rev-1 100) + (top-1 (make-instance 'TopicC))) + (let ((psi-1 (make-construct 'PersistentIdC :uri "psi-1")) + (psi-2 (make-construct 'PersistentIdC + :uri "psi-2" + :identified-construct top-1 + :start-revision rev-1))) + (is (string= (uri psi-1) "psi-1")) + (is-false (d::slot-p psi-1 'd::identified-construct)) + (is (string= (uri psi-2) "psi-2")) + (is (= (length (d::slot-p psi-2 'd::identified-construct)) 1)) + (is (= (length (d::versions + (first (d::slot-p psi-2 'd::identified-construct)))) 1)) + (is (= (d::start-revision + (first (d::versions + (first (d::slot-p psi-2 'd::identified-construct))))) + rev-1)) + (is (= (d::end-revision + (first (d::versions + (first (d::slot-p psi-2 'd::identified-construct))))) + rev-0)) + (is (eql (identified-construct psi-2 :revision rev-1) top-1)) + (is-false (identified-construct psi-2 :revision rev-0-5)) + (is (eql (find-item-by-revision psi-2 rev-1 top-1) psi-2)))))) + + +(test test-make-SubjectLocatorC () + "Tests the function make-construct corresponding to SubjectLocatorC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-0 0) + (rev-0-5 50) + (rev-1 100) + (top-1 (make-instance 'TopicC))) + (let ((sl-1 (make-construct 'SubjectLocatorC :uri "sl-1")) + (sl-2 (make-construct 'SubjectLocatorC + :uri "sl-2" + :identified-construct top-1 + :start-revision rev-1))) + (is (string= (uri sl-1) "sl-1")) + (is-false (d::slot-p sl-1 'd::identified-construct)) + (is (string= (uri sl-2) "sl-2")) + (is (= (length (d::slot-p sl-2 'd::identified-construct)) 1)) + (is (= (length (d::versions + (first (d::slot-p sl-2 'd::identified-construct)))) 1)) + (is (= (d::start-revision + (first (d::versions + (first (d::slot-p sl-2 'd::identified-construct))))) + rev-1)) + (is (= (d::end-revision + (first (d::versions + (first (d::slot-p sl-2 'd::identified-construct))))) + rev-0)) + (is (eql (identified-construct sl-2 :revision rev-1) top-1)) + (is-false (identified-construct sl-2 :revision rev-0-5)) + (is (eql (find-item-by-revision sl-2 rev-1 top-1) sl-2)))))) + + +(test test-make-ItemIdentifierC () + "Tests the function make-construct corresponding to ItemIdentifierC." + (with-fixture with-empty-db (*db-dir*) + (let ((rev-0 0) + (rev-0-5 50) + (rev-1 100) + (top-1 (make-instance 'AssociationC))) + (let ((ii-1 (make-construct 'ItemIdentifierC :uri "ii-1")) + (ii-2 (make-construct 'ItemIdentifierC + :uri "ii-2" + :identified-construct top-1 + :start-revision rev-1))) + (is (string= (uri ii-1) "ii-1")) + (is-false (d::slot-p ii-1 'd::identified-construct)) + (is (string= (uri ii-2) "ii-2")) + (is (= (length (d::slot-p ii-2 'd::identified-construct)) 1)) + (is (= (length (d::versions + (first (d::slot-p ii-2 'd::identified-construct)))) 1)) + (is (= (d::start-revision + (first (d::versions + (first (d::slot-p ii-2 'd::identified-construct))))) + rev-1)) + (is (= (d::end-revision + (first (d::versions + (first (d::slot-p ii-2 'd::identified-construct))))) + rev-0)) + (is (eql (identified-construct ii-2 :revision rev-1) top-1)) + (is-false (identified-construct ii-2 :revision rev-0-5)) + (is (eql (find-item-by-revision ii-2 rev-1 top-1) ii-2)))))) + + + (defun run-datamodel-tests() @@ -1962,4 +2094,8 @@ (it.bese.fiveam:run! 'test-find-item-by-revision) (it.bese.fiveam:run! 'test-make-Unknown) (it.bese.fiveam:run! 'test-make-VersionedConstructC) + (it.bese.fiveam:run! 'test-make-TopicIdentificationC) + (it.bese.fiveam:run! 'test-make-PersistentIdC) + (it.bese.fiveam:run! 'test-make-SubjectLocatorC) + (it.bese.fiveam:run! 'test-make-ItemIdentifierC) ) \ No newline at end of file

1 0

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

22 Mar '10

Author: lgiessmann Date: Mon Mar 22 14:49:05 2010 New Revision: 247 Log: new-datamodel: added some unit-test for "make-construct" --> "VersionedConstructC" and unknown class; fixed a problem in "make-construct" that appears when creating "VersionedConstructC"s Modified: branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/unit_tests/datamodel_test.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Mon Mar 22 14:49:05 2010 @@ -2692,6 +2692,9 @@ history accordingly. Returns the object in question. Methods use specific keyword arguments for their purpose." (declare (symbol class-symbol)) + (when (and (VersionedConstructC-p class-symbol) + (not (getf args :start-revision))) + (error "From make-construct(): start-revision must be set")) (let ((construct (cond ((PointerC-p class-symbol) @@ -2707,7 +2710,8 @@ ((AssociationC-p class-symbol) (apply #'make-association args)) ((VersionedConstructC-p class-symbol) - (apply #'make-instance (rec-remf args :start-revision))) + (apply #'make-instance class-symbol + (rec-remf args :start-revision))) (t (apply #'make-instance class-symbol args)))) (start-revision (getf args :start-revision))) @@ -2718,8 +2722,6 @@ (complete-scopable construct (getf args :themes) :start-revision start-revision)) (when (typep construct 'VersionedConstructC) - (unless start-revision - (error "From make-construct(): start-revision must be set")) (add-to-version-history construct :start-revision start-revision)) (if (typep construct 'ReifiableConstructC) (complete-reifiable construct (getf args :item-identtifiers) Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/datamodel_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp Mon Mar 22 14:49:05 2010 @@ -59,7 +59,9 @@ :test-equivalent-TopicC :test-equivalent-TopicMapC :test-class-p - :test-find-item-by-revision)) + :test-find-item-by-revision + :test-make-Unknown + :test-make-VersionedConstructC)) ;;TODO: test make-construct @@ -1874,6 +1876,46 @@ +(test test-make-Unknown () + "Tests the function make-construct corresponding to an unknown class." + (defclass Unknown () + ((value :initarg :value + :accessor value))) + (let ((construct (make-construct 'Unknown :value "value"))) + (is-true construct) + (string= (value construct) "value"))) + + +(test test-make-VersionedConstructC () + "Tests the function make-construct corresponding to VersionedConstructC." + (with-fixture with-empty-db (*db-dir*) + (let ((psi-1 (make-instance 'PersistentIdC :uri "psi-1")) + (top-1 (make-instance 'TopicC)) + (rev-0 0) + (rev-1 100) + (rev-2 200)) + (let ((vc (make-construct 'VersionedConstructC + :start-revision rev-2)) + (psi-assoc (make-construct 'd::PersistentIdAssociationC + :start-revision rev-1 + :identifier psi-1 + :parent-construct top-1))) + (signals error (make-construct 'd::PersistentIdAssociationC + :start-revision rev-1 + :identifier psi-1)) + (signals error (make-construct 'VersionedConstructC)) + (is (= (length (d::versions vc)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) rev-2) + (= (d::end-revision vi) rev-0))) + (d::versions vc))) + (is (= (length (d::versions psi-assoc)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) rev-1) + (= (d::end-revision vi) rev-0))) + (d::versions psi-assoc))))))) + + (defun run-datamodel-tests() @@ -1918,4 +1960,6 @@ (it.bese.fiveam:run! 'test-equivalent-TopicMapC) (it.bese.fiveam:run! 'test-class-p) (it.bese.fiveam:run! 'test-find-item-by-revision) + (it.bese.fiveam:run! 'test-make-Unknown) + (it.bese.fiveam:run! 'test-make-VersionedConstructC) ) \ No newline at end of file

1 0

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

22 Mar '10

Author: lgiessmann Date: Mon Mar 22 14:14:02 2010 New Revision: 246 Log: replaced all keyword parameters of the form "(revision 0)" or "(start-revision 0)" to "(revision *TM-REVISION*)" and "(start-revision *TM-REVISION*)" to be compatible with the macro "with-revision" which uses the variable "*TM-REVISION*" Modified: branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/unit_tests/datamodel_test.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Mon Mar 22 14:14:02 2010 @@ -156,9 +156,6 @@ -;;TOOD: replace the key argument (revision 0)/(start-revision 0) -;; by (start-revision *TM-REVISION*) (revision *TM-REVISION*) -;; to be compatible to the macro with-revision ;;TODO: check merge-constructs in add-topic-identifier, ;; add-item-identifier/add-reifier (can merge the parent constructs ;; and the parent's parent construct + the reifier constructs), @@ -765,7 +762,7 @@ its parent-construct.")) -(defgeneric check-for-duplicate-identifiers (construct) +(defgeneric check-for-duplicate-identifiers (construct &key revision) (:documentation "Check for possibly duplicate identifiers and signal an duplicate-identifier-error is such duplicates are found")) @@ -926,8 +923,9 @@ ;;; TopicMapconstructC -(defmethod check-for-duplicate-identifiers ((construct TopicMapConstructC)) - (declare (ignore construct)) +(defmethod check-for-duplicate-identifiers ((construct TopicMapConstructC) + &key revision) + (declare (ignorable revision construct)) ;do nothing ) @@ -1009,7 +1007,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 0)) + (:method ((construct PointerC) &key (revision *TM-REVISION*)) (let ((assocs (map 'list #'parent-construct (filter-slot-value-by-revision construct 'identified-construct @@ -1218,7 +1216,7 @@ (= essentially the OID). If xtm-id is explicitly given, returns one of the topic-ids in that TM (which must then exist).") - (:method ((construct TopicC) &optional (xtm-id nil) (revision 0)) + (:method ((construct TopicC) &optional (xtm-id nil) (revision *TM-REVISION*)) (declare (type (or null string) xtm-id) (integer revision)) (if xtm-id (let ((possible-identifiers @@ -1240,7 +1238,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 0)) + (:method ((construct TopicC) &key (revision *TM-REVISION*)) (let ((assocs (filter-slot-value-by-revision construct 'topic-identifiers :start-revision revision))) (map 'list #'identifier assocs)))) @@ -1257,7 +1255,8 @@ (let ((all-ids (map 'list #'identifier (slot-p construct 'topic-identifiers))) (construct-to-be-merged - (let ((id-owner (identified-construct topic-identifier))) + (let ((id-owner (identified-construct topic-identifier + :revision revision))) (when (not (eql id-owner construct)) id-owner)))) (let ((merged-construct construct)) @@ -1298,7 +1297,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 0)) + (:method ((construct TopicC) &key (revision *TM-REVISION*)) (let ((assocs (filter-slot-value-by-revision construct 'psis :start-revision revision))) (map 'list #'identifier assocs)))) @@ -1315,7 +1314,7 @@ (let ((all-ids (map 'list #'identifier (slot-p construct 'psis))) (construct-to-be-merged - (let ((id-owner (identified-construct psi))) + (let ((id-owner (identified-construct psi :revision revision))) (when (not (eql id-owner construct)) id-owner)))) (let ((merged-construct construct)) @@ -1354,7 +1353,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 0)) + (:method ((construct TopicC) &key (revision *TM-REVISION*)) (let ((assocs (filter-slot-value-by-revision construct 'locators :start-revision revision))) (map 'list #'identifier assocs)))) @@ -1371,7 +1370,7 @@ (let ((all-ids (map 'list #'identifier (slot-p construct 'locators))) (construct-to-be-merged - (let ((id-owner (identified-construct locator))) + (let ((id-owner (identified-construct locator :revision revision))) (when (not (eql id-owner construct)) id-owner)))) (let ((merged-construct construct)) @@ -1409,7 +1408,7 @@ (defmethod get-all-identifiers-of-construct ((construct TopicC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (declare (integer revision)) (append (psis construct :revision revision) (locators construct :revision revision) @@ -1419,7 +1418,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 0)) + (:method ((construct TopicC) &key (revision *TM-REVISION*)) (let ((assocs (filter-slot-value-by-revision construct 'names :start-revision revision))) (map 'list #'characteristic assocs)))) @@ -1470,7 +1469,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 0)) + (:method ((construct TopicC) &key (revision *TM-REVISION*)) (let ((assocs (filter-slot-value-by-revision construct 'occurrences :start-revision revision))) (map 'list #'characteristic assocs)))) @@ -1485,9 +1484,9 @@ (:method ((construct TopicC) (occurrence OccurrenceC) &key (revision *TM-REVISION*)) (when (and (parent occurrence :revision revision) - (not (eql (parent occurrence) construct))) + (not (eql (parent occurrence :revision revision) 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))) + occurrence construct (parent occurrence :revision revision))) (let ((all-occurrences (map 'list #'characteristic (slot-p construct 'occurrences)))) (if (find occurrence all-occurrences) @@ -1520,7 +1519,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 0)) + (:method ((construct TopicC) &key (revision *TM-REVISION*)) (let ((assocs (filter-slot-value-by-revision construct 'player-in-roles :start-revision revision))) (map 'list #'parent-construct assocs)))) @@ -1529,7 +1528,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 0)) + (:method ((construct TopicC) &key (revision *TM-REVISION*)) (let ((assocs (filter-slot-value-by-revision construct 'used-as-type :start-revision revision))) (map 'list #'typable-construct assocs)))) @@ -1538,7 +1537,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 0)) + (:method ((construct TopicC) &key (revision *TM-REVISION*)) (let ((assocs (filter-slot-value-by-revision construct 'used-as-theme :start-revision revision))) (map 'list #'scopable-construct assocs)))) @@ -1547,18 +1546,19 @@ (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 0)) + (:method ((construct TopicC) &key (revision *TM-REVISION*)) (let ((assocs (filter-slot-value-by-revision construct 'reified-construct :start-revision revision))) (when assocs (reifiable-construct (first assocs)))))) -(defmethod in-topicmaps ((topic TopicC) &key (revision 0)) +(defmethod in-topicmaps ((topic TopicC) &key (revision *TM-REVISION*)) (filter-slot-value-by-revision topic 'in-topicmaps :start-revision revision)) -(defun get-item-by-id (topic-id &key (xtm-id *CURRENT-XTM*) (revision 0) (error-if-nil nil)) +(defun get-item-by-id (topic-id &key (xtm-id *CURRENT-XTM*) + (revision *TM-REVISION*) (error-if-nil nil)) "Gets a topic by its id, assuming an xtm-id. If xtm-id is empty, the current TM is chosen. If xtm-id is nil, choose the global TM with its internal ID, if applicable in the correct revision. If revison is provided, then the code checks @@ -1580,7 +1580,8 @@ 'uri topic-id)))) (when (and possible-top-ids - (identified-construct (first possible-top-ids) :revision revision)) + (identified-construct (first possible-top-ids) + :revision revision)) (unless (= (length possible-top-ids) 1) (error (make-condition 'duplicate-identifier-error @@ -1606,7 +1607,7 @@ result))) -(defun get-item-by-identifier (uri &key (revision 0) +(defun get-item-by-identifier (uri &key (revision *TM-REVISION*) (identifier-type-symbol 'PersistentIdC) (error-if-nil nil)) "Returns the construct that is bound to the given identifier-uri." @@ -1618,7 +1619,8 @@ (string= (uri id) uri)) (get-instances-by-value identifier-type-symbol 'uri uri)))) (when (and possible-ids - (identified-construct (first possible-ids) :revision revision)) + (identified-construct (first possible-ids) + :revision revision)) (unless (= (length possible-ids) 1) (error (make-condition 'duplicate-identifier-error :message (format nil "(length possible-items ~a) for id ~a" @@ -1634,21 +1636,22 @@ (error "No such item is bound to the given identifier uri."))))) -(defun get-item-by-item-identifier (uri &key (revision 0) (error-if-nil nil)) +(defun get-item-by-item-identifier (uri &key (revision *TM-REVISION*) + (error-if-nil nil)) "Returns a ReifiableConstructC that is bound to the identifier-uri." (get-item-by-identifier uri :revision revision :identifier-type-symbol 'ItemIdentifierC :error-if-nil error-if-nil)) -(defun get-item-by-psi (uri &key (revision 0) (error-if-nil nil)) +(defun get-item-by-psi (uri &key (revision *TM-REVISION*) (error-if-nil nil)) "Returns a TopicC that is bound to the identifier-uri." (get-item-by-identifier uri :revision revision :identifier-type-symbol 'PersistentIdC :error-if-nil error-if-nil)) -(defun get-item-by-locator (uri &key (revision 0) (error-if-nil nil)) +(defun get-item-by-locator (uri &key (revision *TM-REVISION*) (error-if-nil nil)) "Returns a TopicC that is bound to the identifier-uri." (get-item-by-identifier uri :revision revision :identifier-type-symbol 'SubjectLocatorC @@ -1658,7 +1661,7 @@ (defgeneric list-instanceOf (topic &key tm revision) (:documentation "Generates a list of all topics that this topic is an instance of, optionally filtered by a topic map") - (:method ((topic TopicC) &key (tm nil) (revision 0)) + (:method ((topic TopicC) &key (tm nil) (revision *TM-REVISION*)) (declare (type (or null TopicMapC) tm) (integer revision)) (remove-if @@ -1676,7 +1679,8 @@ (if tm (remove-if-not (lambda (role) - (in-topicmap tm (parent role :revision revision))) + (in-topicmap tm (parent role :revision revision) + :revision revision)) (player-in-roles topic :revision revision)) (player-in-roles topic :revision revision)))))) @@ -1684,7 +1688,7 @@ (defgeneric list-super-types (topic &key tm revision) (:documentation "Generate a list of all topics that this topic is an subclass of, optionally filtered by a topic map") - (:method ((topic TopicC) &key (tm nil) (revision 0)) + (:method ((topic TopicC) &key (tm nil) (revision *TM-REVISION*)) (declare (type (or null TopicMapC) tm) (integer revision)) (remove-if @@ -1702,7 +1706,8 @@ (if tm (remove-if-not (lambda (role) - (in-topicmap tm (parent role :revision revision))) + (in-topicmap tm (parent role :revision revision) + :revision revision)) (player-in-roles topic :revision revision)) (player-in-roles topic :revision revision)))))) @@ -1719,8 +1724,8 @@ (defmethod equivalent-construct ((construct CharacteristicC) - &key (start-revision 0) (charvalue "") - (instance-of nil) (themes nil)) + &key (start-revision *TM-REVISION*) + (charvalue "") (instance-of nil) (themes nil)) "Equality rule: Characteristics are equal if charvalue, themes and instance-of are equal." (declare (string charvalue) (list themes) @@ -1778,7 +1783,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 0)) + (:method ((construct CharacteristicC) &key (revision *TM-REVISION*)) (let ((valid-associations (filter-slot-value-by-revision construct 'parent :start-revision revision))) @@ -1845,15 +1850,15 @@ (defmethod equivalent-construct ((construct OccurrenceC) - &key (start-revision 0) (charvalue "") - (themes nil) (instance-of nil) + &key (start-revision *TM-REVISION*) + (charvalue "") (themes nil) (instance-of nil) (datatype "")) "Occurrences are equal if their charvalue, datatype, themes and instance-of properties are equal." (declare (type (or null TopicC) instance-of) (string datatype) (ignorable start-revision charvalue themes instance-of)) (let ((equivalent-characteristic (call-next-method))) - ;; item-identifiers and reifers are not checked because the equality have to + ;; item-identifiers and reifers are not checked because the equaity have to ;; be variafied without them (and equivalent-characteristic (string= (datatype construct) datatype)))) @@ -1867,8 +1872,8 @@ (defmethod equivalent-construct ((construct VariantC) - &key (start-revision 0) (charvalue "") - (themes nil) (datatype "")) + &key (start-revision *TM-REVISION*) + (charvalue "") (themes nil) (datatype "")) "Variants are equal if their charvalue, datatype and themes properties are equal." (declare (string datatype) (ignorable start-revision charvalue themes)) @@ -1902,8 +1907,8 @@ (defmethod equivalent-construct ((construct NameC) - &key (start-revision 0) (charvalue "") - (themes nil) (instance-of nil)) + &key (start-revision *TM-REVISION*) + (charvalue "") (themes nil) (instance-of nil)) "Names are equal if their charvalue, instance-of and themes properties are equal." (declare (type (or null TopicC) instance-of) @@ -1924,7 +1929,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 0)) + (:method ((construct NameC) &key (revision *TM-REVISION*)) (let ((valid-associations (filter-slot-value-by-revision construct 'variants :start-revision revision))) @@ -1939,7 +1944,7 @@ (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))) + variant construct (parent variant :revision revision))) (let ((all-variants (map 'list #'characteristic (slot-p construct 'variants)))) (if (find variant all-variants) @@ -1977,8 +1982,8 @@ (defmethod equivalent-construct ((construct AssociationC) - &key (start-revision 0) (roles nil) - (instance-of nil) (themes nil)) + &key (start-revision *TM-REVISION*) + (roles nil) (instance-of nil) (themes nil)) "Associations are equal if their themes, instance-of and roles properties are equal." (declare (integer start-revision) (list roles themes) @@ -2013,7 +2018,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 0)) + (:method ((construct AssociationC) &key (revision *TM-REVISION*)) (let ((valid-associations (filter-slot-value-by-revision construct 'roles :start-revision revision))) @@ -2054,7 +2059,7 @@ construct))) -(defmethod in-topicmaps ((association AssociationC) &key (revision 0)) +(defmethod in-topicmaps ((association AssociationC) &key (revision *TM-REVISION*)) (filter-slot-value-by-revision association 'in-topicmaps :start-revision revision)) @@ -2066,8 +2071,8 @@ (defmethod equivalent-construct ((construct RoleC) - &key (start-revision 0) (player nil) - (instance-of nil)) + &key (start-revision *TM-REVISION*) + (player nil) (instance-of nil)) "Roles are equal if their instance-of and player properties are equal." (declare (integer start-revision) (type (or null TopicC) player instance-of)) ;; item-identifiers and reifers are not checked because the equality have to @@ -2124,7 +2129,7 @@ t)) -(defmethod parent ((construct RoleC) &key (revision 0)) +(defmethod parent ((construct RoleC) &key (revision *TM-REVISION*)) "Returns the construct's parent corresponding to the given revision." (let ((valid-associations (filter-slot-value-by-revision construct 'parent @@ -2176,7 +2181,7 @@ (defgeneric player (construct &key revision) (:documentation "Returns the construct's player corresponding to the given revision.") - (:method ((construct RoleC) &key (revision 0)) + (:method ((construct RoleC) &key (revision *TM-REVISION*)) (let ((valid-associations (filter-slot-value-by-revision construct 'player :start-revision revision))) @@ -2228,8 +2233,10 @@ ;;; ReifiableConstructC -(defmethod check-for-duplicate-identifiers ((construct ReifiableConstructC)) - (dolist (id (get-all-identifiers-of-construct construct)) +(defmethod check-for-duplicate-identifiers ((construct ReifiableConstructC) + &key (revision *TM-REVISION*)) + (declare (integer revision)) + (dolist (id (get-all-identifiers-of-construct construct :revision revision)) (when (> (length (union @@ -2281,7 +2288,7 @@ the reifiable construct have to share an item identifier or reifier.") (:method ((construct ReifiableConstructC) reifier item-identifiers - &key (start-revision 0)) + &key (start-revision *TM-REVISION*)) (declare (integer start-revision) (list item-identifiers) (type (or null TopicC) reifier)) (or (and (reifier construct :revision start-revision) @@ -2306,7 +2313,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 0)) + (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*)) (let ((assocs (filter-slot-value-by-revision construct 'item-identifiers :start-revision revision))) (map 'list #'identifier assocs)))) @@ -2315,7 +2322,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 0)) + (:method ((construct ReifiableConstructC) &key (revision *TM-REVISION*)) (let ((assocs (filter-slot-value-by-revision construct 'reifier :start-revision revision))) (when assocs ;assocs must be nil or a list with exactly one item @@ -2333,7 +2340,8 @@ (let ((all-ids (map 'list #'identifier (slot-p construct 'item-identifiers))) (construct-to-be-merged - (let ((id-owner (identified-construct item-identifier))) + (let ((id-owner (identified-construct item-identifier + :revision revision))) (when (not (eql id-owner construct)) id-owner)))) (let ((merged-construct construct)) @@ -2381,8 +2389,9 @@ (:method ((construct ReifiableConstructC) (reifier-topic TopicC) &key (revision *TM-REVISION*)) (let ((merged-reifier-topic - (if (reifier construct) - (merge-constructs (reifier construct) reifier-topic) + (if (reifier construct :revision revision) + (merge-constructs (reifier construct :revision revision) + reifier-topic) reifier-topic))) (let ((all-constructs (let ((inner-construct (reified-construct merged-reifier-topic @@ -2427,7 +2436,7 @@ (defmethod get-all-identifiers-of-construct ((construct ReifiableConstructC) - &key (revision 0)) + &key (revision *TM-REVISION*)) (declare (integer revision)) (item-identifiers construct :revision revision)) @@ -2457,7 +2466,7 @@ &key start-revision) (:documentation "Returns t if the passed constructs are TMDM equal, i.e. the typable constructs have to own the same type.") - (:method ((construct TypableC) instance-of &key (start-revision 0)) + (:method ((construct TypableC) instance-of &key (start-revision *TM-REVISION*)) (declare (integer start-revision) (type (or null TopicC) instance-of)) (eql (instance-of construct :revision start-revision) instance-of))) @@ -2486,7 +2495,7 @@ (defgeneric equivalent-scopable-construct (construct themes &key start-revision) (:documentation "Returns t if the passed constructs are TMDM equal, i.e. the scopable constructs have to own the same themes.") - (:method ((construct ScopableC) themes &key (start-revision 0)) + (:method ((construct ScopableC) themes &key (start-revision *TM-REVISION*)) (declare (integer start-revision) (list themes)) (not (set-exclusive-or (themes construct :revision start-revision) themes)))) @@ -2500,7 +2509,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 0)) + (:method ((construct ScopableC) &key (revision *TM-REVISION*)) (let ((valid-associations (filter-slot-value-by-revision construct 'themes :start-revision revision))) @@ -2561,7 +2570,7 @@ (defgeneric instance-of (construct &key revision) (:documentation "Returns the type topic that is set on the passed revision.") - (:method ((construct TypableC) &key (revision 0)) + (:method ((construct TypableC) &key (revision *TM-REVISION*)) (let ((valid-associations (filter-slot-value-by-revision construct 'instance-of :start-revision revision))) @@ -2626,8 +2635,8 @@ (defmethod equivalent-construct ((construct TopicMapC) - &key (start-revision 0) (reifier nil) - (item-identifiers nil)) + &key (start-revision *TM-REVISION*) + (reifier nil) (item-identifiers nil)) "TopicMaps equality if they share the same item-identier or reifier." (declare (list item-identifiers) (integer start-revision) (type (or null TopicC) reifier)) @@ -2664,12 +2673,14 @@ topic map?")) -(defmethod in-topicmap ((tm TopicMapC) (top TopicC) &key (revision 0)) +(defmethod in-topicmap ((tm TopicMapC) (top TopicC) &key + (revision *TM-REVISION*)) (when (find-item-by-revision top revision) (find (internal-id top) (topics tm) :test #'= :key #'internal-id))) -(defmethod in-topicmap ((tm TopicMapC) (ass AssociationC) &key (revision 0)) +(defmethod in-topicmap ((tm TopicMapC) (ass AssociationC) + &key (revision *TM-REVISION*)) (when (find-item-by-revision ass revision) (find (internal-id ass) (associations tm) :test #'= :key #'internal-id))) Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/datamodel_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp Mon Mar 22 14:14:02 2010 @@ -417,44 +417,51 @@ (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")) + (rev-0 0) + (rev-1 100) + (rev-2 200)) + (setf d:*TM-REVISION* rev-1) + (is-false (get-item-by-id "any-top-id" :revision rev-0)) (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))) + (signals error (is-false (get-item-by-id "any-top-id" :error-if-nil t + :revision rev-0))) (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) + (add-topic-identifier top-1 top-id-3-1 :revision rev-1) + (add-topic-identifier top-1 top-id-3-2 :revision rev-1) (signals duplicate-identifier-error - (get-item-by-id "topid-3" :xtm-id "xtm-id-3" :revision revision)) + (get-item-by-id "topid-3" :xtm-id "xtm-id-3" :revision rev-1)) (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"))) + (add-topic-identifier top-2 top-id-2 :revision rev-2) + (is (eql top-2 (get-item-by-id "topid-1" :xtm-id "xtm-id-1" + :revision rev-0))) + (is (eql top-2 (get-item-by-id "topid-2" :xtm-id "xtm-id-2" + :revision rev-0))) (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")) + :revision rev-1)) + (delete-topic-identifier top-2 top-id-1 :revision rev-2) + (is-false (get-item-by-id "topid-1" :xtm-id "xtm-id-1" + :revision rev-0)) (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) + :revision rev-1))) + (add-topic-identifier top-3 top-id-1 :revision rev-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"))) + :revision rev-1))) + (d::add-to-version-history top-3 :start-revision rev-2) + (is (eql top-3 (get-item-by-id "topid-1" :xtm-id "xtm-id-1" + :revision rev-0))) (is (eql top-3 (get-item-by-id (concatenate 'string "t" (write-to-string - (elephant::oid top-3)))))) + (elephant::oid top-3))) + :revision rev-0))) (is-false (get-item-by-id (concatenate 'string "t" (write-to-string (elephant::oid top-3))) - :revision revision))))) + :revision rev-1))))) (test test-get-item-by-item-identifier () @@ -471,32 +478,35 @@ (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) + (rev-0 0) + (rev-1 100) + (rev-2 200)) + (setf d:*TM-REVISION* rev-1) (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))) + "any-ii-id" :error-if-nil t + :revision rev-1))) (signals error (is-false (get-item-by-item-identifier - "any-ii-id" :error-if-nil t))) + "any-ii-id" :error-if-nil t + :revision rev-1))) (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) + (add-item-identifier top-1 ii-3-1 :revision rev-1) + (add-item-identifier top-1 ii-3-2 :revision rev-1) (signals duplicate-identifier-error - (get-item-by-item-identifier "ii-3" :revision revision)) + (get-item-by-item-identifier "ii-3" :revision rev-1)) (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"))) + (add-item-identifier top-2 ii-2 :revision rev-2) + (is (eql top-2 (get-item-by-item-identifier "ii-1" :revision rev-0))) + (is (eql top-2 (get-item-by-item-identifier "ii-2" :revision rev-0))) (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")))))) + (is-false (get-item-by-item-identifier "ii-2" :revision rev-1)) + (delete-item-identifier top-2 ii-1 :revision rev-2) + (is-false (get-item-by-item-identifier "ii-1" :revision rev-0)) + (is (eql top-2 (get-item-by-item-identifier "ii-1" :revision rev-1))) + (add-item-identifier top-3 ii-1 :revision rev-2) + (is (eql top-2 (get-item-by-item-identifier "ii-1" :revision rev-1))) + (d::add-to-version-history top-3 :start-revision rev-2) + (is (eql top-3 (get-item-by-item-identifier "ii-1" :revision rev-0)))))) (test test-get-item-by-locator () @@ -513,32 +523,35 @@ (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) + (rev-0 0) + (rev-1 100) + (rev-2 200)) + (setf d:*TM-REVISION* rev-1) (is-false (get-item-by-id "any-sl-id")) (signals error (is-false (get-item-by-locator - "any-sl-id" :error-if-nil t))) + "any-sl-id" :error-if-nil t + :revision rev-0))) (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) + "any-sl-id" :error-if-nil t + :revision rev-0))) + (is-false (get-item-by-locator "any-sl-id" :revision rev-0)) + (add-locator top-1 sl-3-1 :revision rev-1) + (add-locator top-1 sl-3-2 :revision rev-1) (signals duplicate-identifier-error - (get-item-by-locator "sl-3" :revision revision)) + (get-item-by-locator "sl-3" :revision rev-1)) (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"))) + (add-locator top-2 sl-2 :revision rev-2) + (is (eql top-2 (get-item-by-locator "sl-1" :revision rev-0))) + (is (eql top-2 (get-item-by-locator "sl-2" :revision rev-0))) (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")))))) + (is-false (get-item-by-locator "sl-2" :revision rev-1)) + (delete-locator top-2 sl-1 :revision rev-2) + (is-false (get-item-by-locator "sl-1" :revision rev-0)) + (is (eql top-2 (get-item-by-locator "sl-1" :revision rev-1))) + (add-locator top-3 sl-1 :revision rev-2) + (is (eql top-2 (get-item-by-locator "sl-1" :revision rev-1))) + (d::add-to-version-history top-3 :start-revision rev-2) + (is (eql top-3 (get-item-by-locator "sl-1" :revision rev-0)))))) (test test-get-item-by-psi () @@ -555,32 +568,35 @@ (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) + (rev-0 0) + (rev-1 100) + (rev-2 200)) + (setf d:*TM-REVISION* rev-1) (is-false (get-item-by-id "any-psi-id")) (signals error (is-false (get-item-by-locator - "any-psi-id" :error-if-nil t))) + "any-psi-id" :error-if-nil t + :revision rev-0))) (signals error (is-false (get-item-by-locator - "any-psi-id" :error-if-nil t))) + "any-psi-id" :error-if-nil t + :revision rev-0))) (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) + (add-psi top-1 psi-3-1 :revision rev-1) + (add-psi top-1 psi-3-2 :revision rev-1) (signals duplicate-identifier-error - (get-item-by-locator "psi-3" :revision revision)) + (get-item-by-locator "psi-3" :revision rev-1)) (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"))) + (add-psi top-2 psi-2 :revision rev-2) + (is (eql top-2 (get-item-by-locator "psi-1" :revision rev-0))) + (is (eql top-2 (get-item-by-locator "psi-2" :revision rev-0))) (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")))))) + (is-false (get-item-by-locator "psi-2" :revision rev-1)) + (delete-psi top-2 psi-1 :revision rev-2) + (is-false (get-item-by-locator "psi-1" :revision rev-0)) + (is (eql top-2 (get-item-by-locator "psi-1" :revision rev-1))) + (add-psi top-3 psi-1 :revision rev-2) + (is (eql top-2 (get-item-by-locator "psi-1" :revision rev-1))) + (d::add-to-version-history top-3 :start-revision rev-2) + (is (eql top-3 (get-item-by-locator "psi-1" :revision rev-0)))))) (test test-ReifiableConstructC () @@ -621,81 +637,82 @@ (occ-2 (make-instance 'OccurrenceC)) (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 occ-1)) - (is-false (occurrences top-1)) - (add-occurrence top-1 occ-1 :revision revision-1) + (rev-0 0) + (rev-1 100) + (rev-2 200) + (rev-3 300) + (rev-4 400) + (rev-5 500) + (rev-6 600) + (rev-7 700) + (rev-8 800)) + (setf *TM-REVISION* rev-1) + (is-false (parent occ-1 :revision rev-0)) + (is-false (occurrences top-1 :revision rev-0)) + (add-occurrence top-1 occ-1 :revision rev-1) (is (= (length (d::versions top-1)) 1)) (is-true (find-if #'(lambda(vi) - (and (= (d::start-revision vi) revision-1) + (and (= (d::start-revision vi) rev-1) (= (d::end-revision vi) 0))) (d::versions top-1))) (is (= (length (union (list occ-1) - (occurrences top-1))) 1)) - (add-occurrence top-1 occ-2 :revision revision-2) + (occurrences top-1 :revision rev-0))) 1)) + (add-occurrence top-1 occ-2 :revision rev-2) (is (= (length (d::versions top-1)) 2)) (is-true (find-if #'(lambda(vi) - (and (= (d::start-revision vi) revision-2) + (and (= (d::start-revision vi) rev-2) (= (d::end-revision vi) 0))) (d::versions top-1))) (is (= (length (union (list occ-1 occ-2) - (occurrences top-1))) 2)) + (occurrences top-1 :revision rev-0))) 2)) (is (= (length (union (list occ-1) - (occurrences top-1 :revision revision-1))) 1)) - (add-occurrence top-1 occ-2 :revision revision-3) + (occurrences top-1 :revision rev-1))) 1)) + (add-occurrence top-1 occ-2 :revision rev-3) (is (= (length (d::slot-p top-1 'd::occurrences)) 2)) - (delete-occurrence top-1 occ-1 :revision revision-4) + (delete-occurrence top-1 occ-1 :revision rev-4) (is (= (length (d::versions top-1)) 4)) (is-true (find-if #'(lambda(vi) - (and (= (d::start-revision vi) revision-4) + (and (= (d::start-revision vi) rev-4) (= (d::end-revision vi) 0))) (d::versions top-1))) (is (= (length (union (list occ-2) - (occurrences top-1 :revision revision-4))) 1)) + (occurrences top-1 :revision rev-4))) 1)) (is (= (length (union (list occ-2) - (occurrences top-1))) 1)) + (occurrences top-1 :revision rev-0))) 1)) (is (= (length (union (list occ-1 occ-2) - (occurrences top-1 :revision revision-2))) 2)) - (add-occurrence top-1 occ-1 :revision revision-4) + (occurrences top-1 :revision rev-2))) 2)) + (add-occurrence top-1 occ-1 :revision rev-4) (is (= (length (union (list occ-2 occ-1) - (occurrences top-1))) 2)) - (signals error (add-occurrence top-2 occ-1 :revision revision-4)) - (delete-occurrence top-1 occ-1 :revision revision-5) + (occurrences top-1 :revision rev-0))) 2)) + (signals error (add-occurrence top-2 occ-1 :revision rev-4)) + (delete-occurrence top-1 occ-1 :revision rev-5) (is (= (length (union (list occ-2) - (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-1)) - (delete-parent occ-2 top-1 :revision revision-4) - (is-false (parent occ-2 :revision revision-4)) - (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-1 (parent occ-2))) - (delete-parent occ-2 top-1 :revision revision-6) - (add-parent occ-2 top-2 :revision revision-7) + (occurrences top-1 :revision rev-5))) 1)) + (add-occurrence top-2 occ-1 :revision rev-5) + (is (eql (parent occ-1 :revision rev-0) top-2)) + (is (eql (parent occ-1 :revision rev-2) top-1)) + (delete-parent occ-2 top-1 :revision rev-4) + (is-false (parent occ-2 :revision rev-4)) + (is (eql top-1 (parent occ-2 :revision rev-3))) + (add-parent occ-2 top-1 :revision rev-5) + (is-false (parent occ-2 :revision rev-4)) + (is (eql top-1 (parent occ-2 :revision rev-0))) + (delete-parent occ-2 top-1 :revision rev-6) + (add-parent occ-2 top-2 :revision rev-7) (is (= (length (d::versions top-2)) 2)) (is-true (find-if #'(lambda(vi) - (and (= (d::start-revision vi) revision-7) + (and (= (d::start-revision vi) rev-7) (= (d::end-revision vi) 0))) (d::versions top-2))) - (delete-parent occ-2 top-2 :revision revision-8) + (delete-parent occ-2 top-2 :revision rev-8) (is (= (length (d::versions top-2)) 3)) (is-true (find-if #'(lambda(vi) - (and (= (d::start-revision vi) revision-8) + (and (= (d::start-revision vi) rev-8) (= (d::end-revision vi) 0))) (d::versions top-2))) - (is-false (parent occ-2)) - (add-parent occ-2 top-1 :revision revision-8) - (is (eql top-1 (parent occ-2)))))) + (is-false (parent occ-2 :revision rev-0)) + (add-parent occ-2 top-1 :revision rev-8) + (is (eql top-1 (parent occ-2 :revision rev-0)))))) (test test-VariantC () @@ -705,56 +722,57 @@ (v-2 (make-instance 'VariantC)) (name-1 (make-instance 'NameC)) (name-2 (make-instance 'NameC)) - (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 v-1)) - (is-false (variants name-1)) - (add-variant name-1 v-1 :revision revision-1) + (rev-0 0) + (rev-1 100) + (rev-2 200) + (rev-3 300) + (rev-4 400) + (rev-5 500) + (rev-6 600) + (rev-7 700) + (rev-8 800)) + (setf *TM-REVISION* rev-1) + (is-false (parent v-1 :revision rev-0)) + (is-false (variants name-1 :revision rev-0)) + (add-variant name-1 v-1 :revision rev-1) (is (= (length (union (list v-1) - (variants name-1))) 1)) - (add-variant name-1 v-2 :revision revision-2) + (variants name-1 :revision rev-0))) 1)) + (add-variant name-1 v-2 :revision rev-2) (is (= (length (union (list v-1 v-2) - (variants name-1))) 2)) + (variants name-1 :revision rev-0))) 2)) (is (= (length (union (list v-1) - (variants name-1 :revision revision-1))) 1)) - (add-variant name-1 v-2 :revision revision-3) + (variants name-1 :revision rev-1))) 1)) + (add-variant name-1 v-2 :revision rev-3) (is (= (length (d::slot-p name-1 'd::variants)) 2)) - (delete-variant name-1 v-1 :revision revision-4) + (delete-variant name-1 v-1 :revision rev-4) (is (= (length (union (list v-2) - (variants name-1 :revision revision-4))) 1)) + (variants name-1 :revision rev-4))) 1)) (is (= (length (union (list v-2) - (variants name-1))) 1)) + (variants name-1 :revision rev-0))) 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) + (variants name-1 :revision rev-2))) 2)) + (add-variant name-1 v-1 :revision rev-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) + (variants name-1 :revision rev-0))) 2)) + (signals error (add-variant name-2 v-1 :revision rev-4)) + (delete-variant name-1 v-1 :revision rev-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) - (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)))))) + (variants name-1 :revision rev-5))) 1)) + (add-variant name-2 v-1 :revision rev-5) + (is (eql (parent v-1 :revision rev-0) name-2)) + (is (eql (parent v-1 :revision rev-2) name-1)) + (delete-parent v-2 name-1 :revision rev-4) + (is-false (parent v-2 :revision rev-4)) + (is (eql name-1 (parent v-2 :revision rev-3))) + (add-parent v-2 name-1 :revision rev-5) + (is-false (parent v-2 :revision rev-4)) + (is (eql name-1 (parent v-2 :revision rev-0))) + (delete-parent v-2 name-1 :revision rev-6) + (add-parent v-2 name-2 :revision rev-7) + (delete-parent v-2 name-2 :revision rev-8) + (is-false (parent v-2 :revision rev-0)) + (add-parent v-2 name-1 :revision rev-8) + (is (eql name-1 (parent v-2 :revision rev-0)))))) (test test-NameC () @@ -764,81 +782,82 @@ (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) + (rev-0 0) + (rev-1 100) + (rev-2 200) + (rev-3 300) + (rev-4 400) + (rev-5 500) + (rev-6 600) + (rev-7 700) + (rev-8 800)) + (setf *TM-REVISION* rev-1) + (is-false (parent name-1 :revision rev-0)) + (is-false (names top-1 :revision rev-0)) + (add-name top-1 name-1 :revision rev-1) (is (= (length (d::versions top-1)) 1)) (is-true (find-if #'(lambda(vi) - (and (= (d::start-revision vi) revision-1) + (and (= (d::start-revision vi) rev-1) (= (d::end-revision vi) 0))) (d::versions top-1))) (is (= (length (union (list name-1) - (names top-1))) 1)) - (add-name top-1 name-2 :revision revision-2) + (names top-1 :revision rev-0))) 1)) + (add-name top-1 name-2 :revision rev-2) (is (= (length (d::versions top-1)) 2)) (is-true (find-if #'(lambda(vi) - (and (= (d::start-revision vi) revision-2) + (and (= (d::start-revision vi) rev-2) (= (d::end-revision vi) 0))) (d::versions top-1))) (is (= (length (union (list name-1 name-2) - (names top-1))) 2)) + (names top-1 :revision rev-0))) 2)) (is (= (length (union (list name-1) - (names top-1 :revision revision-1))) 1)) - (add-name top-1 name-2 :revision revision-3) + (names top-1 :revision rev-1))) 1)) + (add-name top-1 name-2 :revision rev-3) (is (= (length (d::slot-p top-1 'd::names)) 2)) - (delete-name top-1 name-1 :revision revision-4) + (delete-name top-1 name-1 :revision rev-4) (is (= (length (d::versions top-1)) 4)) (is-true (find-if #'(lambda(vi) - (and (= (d::start-revision vi) revision-4) + (and (= (d::start-revision vi) rev-4) (= (d::end-revision vi) 0))) (d::versions top-1))) (is (= (length (union (list name-2) - (names top-1 :revision revision-4))) 1)) + (names top-1 :revision rev-4))) 1)) (is (= (length (union (list name-2) - (names top-1))) 1)) + (names top-1 :revision rev-0))) 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) + (names top-1 :revision rev-2))) 2)) + (add-name top-1 name-1 :revision rev-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) + (names top-1 :revision rev-0))) 2)) + (signals error (add-name top-2 name-1 :revision rev-4)) + (delete-name top-1 name-1 :revision rev-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) + (names top-1 :revision rev-5))) 1)) + (add-name top-2 name-1 :revision rev-5) + (is (eql (parent name-1 :revision rev-0) top-2)) + (is (eql (parent name-1 :revision rev-2) top-1)) + (delete-parent name-2 top-1 :revision rev-4) + (is-false (parent name-2 :revision rev-4)) + (is (eql top-1 (parent name-2 :revision rev-3))) + (add-parent name-2 top-1 :revision rev-5) + (is-false (parent name-2 :revision rev-4)) + (is (eql top-1 (parent name-2 :revision rev-0))) + (delete-parent name-2 top-1 :revision rev-6) + (add-parent name-2 top-2 :revision rev-7) (is (= (length (d::versions top-2)) 2)) (is-true (find-if #'(lambda(vi) - (and (= (d::start-revision vi) revision-7) + (and (= (d::start-revision vi) rev-7) (= (d::end-revision vi) 0))) (d::versions top-2))) - (delete-parent name-2 top-2 :revision revision-8) + (delete-parent name-2 top-2 :revision rev-8) (is (= (length (d::versions top-2)) 3)) (is-true (find-if #'(lambda(vi) - (and (= (d::start-revision vi) revision-8) + (and (= (d::start-revision vi) rev-8) (= (d::end-revision vi) 0))) (d::versions top-2))) - (is-false (parent name-2)) - (add-parent name-2 top-1 :revision revision-8) - (is (eql top-1 (parent name-2)))))) + (is-false (parent name-2 :revision rev-0)) + (add-parent name-2 top-1 :revision rev-8) + (is (eql top-1 (parent name-2 :revision rev-0)))))) (test test-TypableC () @@ -848,31 +867,31 @@ (name-2 (make-instance 'NameC)) (top-1 (make-instance 'TopicC)) (top-2 (make-instance 'TopicC)) + (revision-0 0) (revision-0-5 50) (revision-1 100) (revision-2 200) (revision-3 300)) (setf *TM-REVISION* revision-1) - (is-false (instance-of name-1)) + (is-false (instance-of name-1 :revision revision-0)) (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)) + (signals error (add-type name-1 top-2 :revision revision-0)) (add-type name-2 top-1 :revision revision-2) (is (= (length (union (list name-1 name-2) - (used-as-type top-1))) 2)) + (used-as-type top-1 :revision revision-0))) 2)) (is (= (length (union (list name-1) - (used-as-type top-1 - :revision revision-1))) 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-false (instance-of name-1 :revision revision-0)) (is (= (length (union (list name-2) - (used-as-type top-1))) 1)) + (used-as-type top-1 :revision revision-0))) 1)) (add-type name-1 top-1 :revision revision-3) - (is (eql top-1 (instance-of name-1))) + (is (eql top-1 (instance-of name-1 :revision revision-0))) (is (= (length (union (list name-1 name-2) - (used-as-type top-1))) 2)) + (used-as-type top-1 :revision revision-0))) 2)) (is (= (length (slot-value top-1 'd::used-as-type)) 2))))) @@ -883,43 +902,44 @@ (occ-2 (make-instance 'OccurrenceC)) (top-1 (make-instance 'TopicC)) (top-2 (make-instance 'TopicC)) + (revision-0 0) (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)) + (is-false (themes occ-1 :revision revision-0)) + (is-false (used-as-theme top-1 :revision revision-0)) (add-theme occ-1 top-1) (is (= (length (union (list top-1) - (themes occ-1))) 1)) + (themes occ-1 :revision revision-0))) 1)) (is (= (length (union (list occ-1) - (used-as-theme top-1))) 1)) + (used-as-theme top-1 :revision revision-0))) 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-0)) + (is-false (used-as-theme top-1 :revision revision-0)) (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)) + (themes occ-1 :revision revision-0))) 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)) + (themes occ-1 :revision revision-0))) 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)) + (themes occ-1 :revision revision-0))) 2)) (add-theme occ-2 top-2 :revision revision-3) (is (= (length (union (list top-1 top-2) - (themes occ-1))) 2)) + (themes occ-1 :revision revision-0))) 2)) (is (= (length (union (list top-2) - (themes occ-2))) 1)) + (themes occ-2 :revision revision-0))) 1)) (is (= (length (union (list occ-1) - (used-as-theme top-1))) 1)) + (used-as-theme top-1 :revision revision-0))) 1)) (is (= (length (union (list occ-1 occ-2) - (used-as-theme top-2))) 2)) + (used-as-theme top-2 :revision revision-0))) 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)) @@ -933,67 +953,68 @@ (role-2 (make-instance 'RoleC)) (assoc-1 (make-instance 'AssociationC)) (assoc-2 (make-instance 'AssociationC)) - (revision-1 100) - (revision-2 200) - (revision-3 300) - (revision-4 400)) - (setf *TM-REVISION* revision-1) - (is-false (roles assoc-1)) - (is-false (parent role-1)) + (rev-0 0) + (rev-1 100) + (rev-2 200) + (rev-3 300) + (rev-4 400)) + (setf *TM-REVISION* rev-1) + (is-false (roles assoc-1 :revision rev-0)) + (is-false (parent role-1 :revision rev-0)) (add-parent role-1 assoc-1) (is (= (length (d::versions assoc-1)) 1)) (is-true (find-if #'(lambda(vi) - (and (= (d::start-revision vi) revision-1) + (and (= (d::start-revision vi) rev-1) (= (d::end-revision vi) 0))) (d::versions assoc-1))) - (is (eql (parent role-1 :revision revision-1) assoc-1)) + (is (eql (parent role-1 :revision rev-1) assoc-1)) (is (= (length (union (list role-1) (roles assoc-1))) 1)) - (add-role assoc-1 role-2 :revision revision-2) + (add-role assoc-1 role-2 :revision rev-2) (is (= (length (d::versions assoc-1)) 2)) (is-true (find-if #'(lambda(vi) - (and (= (d::start-revision vi) revision-2) + (and (= (d::start-revision vi) rev-2) (= (d::end-revision vi) 0))) (d::versions assoc-1))) (is (= (length (union (list role-1 role-2) - (roles assoc-1))) 2)) + (roles assoc-1 :revision rev-0))) 2)) (is (= (length (union (list role-1) - (roles assoc-1 :revision revision-1))) 1)) - (is (eql (parent role-1) assoc-1)) - (is (eql (parent role-2 :revision revision-2) assoc-1)) - (is-false (parent role-2 :revision revision-1)) - (signals error (add-parent role-2 assoc-2 :revision revision-2)) - (delete-role assoc-1 role-1 :revision revision-3) + (roles assoc-1 :revision rev-1))) 1)) + (is (eql (parent role-1 :revision rev-0) assoc-1)) + (is (eql (parent role-2 :revision rev-2) assoc-1)) + (is-false (parent role-2 :revision rev-1)) + (signals error (add-parent role-2 assoc-2 :revision rev-2)) + (delete-role assoc-1 role-1 :revision rev-3) (is (= (length (d::versions assoc-1)) 3)) (is-true (find-if #'(lambda(vi) - (and (= (d::start-revision vi) revision-3) + (and (= (d::start-revision vi) rev-3) (= (d::end-revision vi) 0))) (d::versions assoc-1))) - (is-false (parent role-1)) + (is-false (parent role-1 :revision rev-0)) (is (= (length (union (list role-2) - (roles assoc-1))) 1)) - (delete-parent role-2 assoc-1 :revision revision-3) - (is-false (parent role-2)) - (is (eql assoc-1 (parent role-2 :revision revision-2))) - (is-false (roles assoc-1)) - (add-role assoc-2 role-1 :revision revision-3) - (add-parent role-2 assoc-2 :revision revision-3) - (is (eql (parent role-2) assoc-2)) + (roles assoc-1 :revision rev-0))) 1)) + (delete-parent role-2 assoc-1 :revision rev-3) + (is-false (parent role-2 :revision rev-0)) + (is (eql assoc-1 (parent role-2 :revision rev-2))) + (is-false (roles assoc-1 :revision rev-0)) + (add-role assoc-2 role-1 :revision rev-3) + (add-parent role-2 assoc-2 :revision rev-3) + (is (eql (parent role-2 :revision rev-0) assoc-2)) (is (= (length (union (list role-1 role-2) (roles assoc-2))) 2)) - (add-role assoc-2 role-1 :revision revision-3) - (add-parent role-2 assoc-2 :revision revision-3) - (is (eql (parent role-2) assoc-2)) + (add-role assoc-2 role-1 :revision rev-3) + (add-parent role-2 assoc-2 :revision rev-3) + (is (eql (parent role-2 :revision rev-0) assoc-2)) (is (= (length (union (list role-1 role-2) - (roles assoc-2))) 2)) + (roles assoc-2 :revision rev-0))) 2)) (is (= (length (slot-value assoc-1 'roles)) 2)) (is (= (length (slot-value assoc-2 'roles)) 2)) (is (= (length (slot-value role-1 'parent)) 2)) (is (= (length (slot-value role-2 'parent)) 2)) - (delete-parent role-1 assoc-2 :revision revision-4) + (delete-parent role-1 assoc-2 :revision rev-4) (is (= (length (d::versions assoc-2)) 2)) (is-true (find-if #'(lambda(vi) - (and (= (d::start-revision vi) revision-4) + (and (= (d::start-revision vi) rev-4) (= (d::end-revision vi) 0))) (d::versions assoc-2)))))) @@ -1005,35 +1026,36 @@ (role-2 (make-instance 'RoleC)) (top-1 (make-instance 'TopicC)) (top-2 (make-instance 'TopicC)) + (revision-0 0) (revision-0-5 50) (revision-1 100) (revision-2 200) (revision-3 300)) (setf *TM-REVISION* revision-1) - (is-false (player role-1)) + (is-false (player role-1 :revision revision-0)) (add-player role-1 top-1) - (is (eql top-1 (player role-1))) + (is (eql top-1 (player role-1 :revision revision-0))) (is-false (player role-1 :revision revision-0-5)) (is (eql top-1 (player role-1 :revision revision-2))) (add-player role-1 top-1) - (is (eql top-1 (player role-1))) + (is (eql top-1 (player role-1 :revision revision-0))) (is-false (player role-1 :revision revision-0-5)) (is (eql top-1 (player role-1 :revision revision-2))) (signals error (add-player role-1 top-2)) (add-player role-2 top-1 :revision revision-2) (is (= (length (union (list role-1 role-2) - (player-in-roles top-1))) 2)) + (player-in-roles top-1 :revision revision-0))) 2)) (is (= (length (union (list role-1) (player-in-roles top-1 :revision revision-1))) 1)) (delete-player role-1 top-1 :revision revision-3) - (is-false (player role-1)) + (is-false (player role-1 :revision revision-0)) (is (= (length (union (list role-2) - (player-in-roles top-1))) 1)) + (player-in-roles top-1 :revision revision-0))) 1)) (add-player role-1 top-1 :revision revision-3) - (is (eql top-1 (player role-1))) + (is (eql top-1 (player role-1 :revision revision-0))) (is (= (length (union (list role-1 role-2) - (player-in-roles top-1))) 2)) + (player-in-roles top-1 :revision revision-0))) 2)) (is (= (length (slot-value top-1 'd::player-in-roles)) 2))))) @@ -1226,6 +1248,7 @@ (reifier-1 (make-instance 'TopicC)) (reifier-2 (make-instance 'TopicC)) (ii-1 (make-instance 'ItemIdentifierC :uri "ii-1")) + (revision-0 0) (revision-1 100) (revision-2 200)) (setf *TM-REVISION* revision-1) @@ -1253,7 +1276,7 @@ (is (= (length (elephant:get-instances-by-class 'd::ReifierAssociationC)) 1)) (is (= (length (union (list ii-1) (item-identifiers rc-2))) 1)) - (is (eql reifier-1 (reifier rc-2))) + (is (eql reifier-1 (reifier rc-2 :revision revision-0))) (delete-construct ii-1) (delete-construct reifier-1) (is (= (length (elephant:get-instances-by-class 'd::ReifiableConstructC))

1 0

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

22 Mar '10

Author: lgiessmann Date: Mon Mar 22 12:24:54 2010 New Revision: 245 Log: new-datamodel: added "add-to-version-history" to all "add-<item>" and "delete-<item>" that are defined for "VersionedConstructC" Modified: branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/unit_tests/datamodel_test.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Mon Mar 22 12:24:54 2010 @@ -171,8 +171,6 @@ ;;TODO: implement merge-construct -> ReifiableConstructC -> ... ;; the method should merge two constructs that are inherited from ;; ReifiableConstructC -;;TODO: implement find-item-by-revision for all classes that don't have their -;; one revision-infos --> PointerC, CharacteristicC, RoleC ;;; globals ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -747,6 +745,16 @@ ;;; generic definitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defgeneric delete-parent (construct parent-construct &key revision) + (:documentation "Sets the assoication-object between the passed + constructs as marded-as-deleted.")) + + +(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.")) + + (defgeneric find-item-by-revision (construct revision &optional parent-construct) (:documentation "Returns the given object if it exists in the passed @@ -1283,6 +1291,7 @@ return ti-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (add-to-version-history construct :start-revision revision) construct))) @@ -1338,6 +1347,7 @@ return psi-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (add-to-version-history construct :start-revision revision) construct))) @@ -1394,6 +1404,7 @@ return loc-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (add-to-version-history construct :start-revision revision) construct))) @@ -1452,6 +1463,7 @@ return name-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (add-to-version-history construct :start-revision revision) construct))) @@ -1501,6 +1513,7 @@ return occ-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (add-to-version-history construct :start-revision revision) construct))) @@ -1773,55 +1786,55 @@ (parent-construct (first valid-associations)))))) -(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.") - (: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 - (parent-construct parent-assoc)) - return parent-assoc))) - (add-to-version-history parent-assoc :start-revision revision))) - (same-parent-assoc - (add-to-version-history same-parent-assoc :start-revision revision)) - (t - (let ((association-type (cond ((typep construct 'OccurrenceC) - 'OccurrenceAssociationC) - ((typep construct 'NameC) - 'NameAssociationC) - (t - 'VariantAssociationC)))) - (make-construct association-type - :characteristic construct - :parent-construct parent-construct - :start-revision revision))))) - construct)) +(defmethod add-parent ((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 + (parent-construct parent-assoc)) + return parent-assoc))) + (add-to-version-history parent-assoc :start-revision revision))) + (same-parent-assoc + (add-to-version-history same-parent-assoc :start-revision revision)) + (t + (let ((association-type (cond ((typep construct 'OccurrenceC) + 'OccurrenceAssociationC) + ((typep construct 'NameC) + 'NameAssociationC) + (t + 'VariantAssociationC)))) + (make-construct association-type + :characteristic construct + :parent-construct parent-construct + :start-revision revision))))) + (when (typep parent-construct 'VersionedConstructC) + (add-to-version-history parent-construct :start-revision revision)) + construct) -(defgeneric delete-parent (construct parent-construct &key revision) - (:documentation "Sets the assoication-object between the passed - 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))) +(defmethod delete-parent ((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)) + (when (typep parent-construct 'VersionedConstructC) + (add-to-version-history parent-construct :start-revision revision)) + construct)) ;;; OccurrenceC @@ -2037,6 +2050,7 @@ return role-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (add-to-version-history construct :start-revision revision) construct))) @@ -2155,6 +2169,7 @@ return parent-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (add-to-version-history parent-construct :start-revision revision) construct)) @@ -2337,9 +2352,7 @@ :parent-construct construct :identifier item-identifier :start-revision revision))) - (when (or (typep merged-construct 'TopicC) - (typep merged-construct 'AssociationC) - (typep merged-construct 'TopicMapC)) + (when (typep construct 'VersionedConstructC) (add-to-version-history merged-construct :start-revision revision)) merged-construct)))) @@ -2354,6 +2367,8 @@ return ii-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (when (typep construct 'VersionedConstructC) + (add-to-version-history construct :start-revision revision)) construct))) @@ -2391,9 +2406,7 @@ :reifiable-construct construct :reifier-topic merged-reifier-topic :start-revision revision))) - (when (or (typep merged-construct 'TopicC) - (typep merged-construct 'AssociationC) - (typep merged-construct 'TopicMapC)) + (when (typep construct 'VersionedConstructC) (add-to-version-history merged-construct :start-revision revision)) merged-construct))))) @@ -2408,6 +2421,8 @@ return reifier-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (when (typep construct 'VersionedConstructC) + (add-to-version-history construct :start-revision revision)) construct))) @@ -2509,7 +2524,7 @@ :theme-topic theme-topic :scopable-construct construct :start-revision revision))) - (when (typep construct 'AssociationC) + (when (typep construct 'VersionedConstructC) (add-to-version-history construct :start-revision revision)) construct)) @@ -2524,6 +2539,8 @@ return theme-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (when (typep construct 'VersionedConstructC) + (add-to-version-history construct :start-revision revision)) construct))) @@ -2580,7 +2597,7 @@ :type-topic type-topic :typable-construct construct :start-revision revision)))) - (when (typep construct 'AssociationC) + (when (typep construct 'VersionedConstructC) (add-to-version-history construct :start-revision revision)) construct)) @@ -2596,6 +2613,8 @@ return type-assoc))) (when assoc-to-delete (mark-as-deleted assoc-to-delete :revision revision)) + (when (typep construct 'VersionedConstructC) + (add-to-version-history construct :start-revision revision)) construct))) Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/datamodel_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp Mon Mar 22 12:24:54 2010 @@ -62,8 +62,6 @@ :test-find-item-by-revision)) -;;TODO: complete all test of the form test-add-<whatever> -;; --> indirect call of add-to-version-history ;;TODO: test make-construct ;;TODO: test merge-constructs @@ -157,10 +155,20 @@ (signals error (make-instance 'ItemIdentifierC)) (is-false (item-identifiers topic-1)) (add-item-identifier topic-1 ii-1) + (is (= (length (d::versions topic-1)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-1) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (item-identifiers topic-1)) 1)) (is (eql (first (item-identifiers topic-1)) ii-1)) (is (eql (identified-construct ii-1) topic-1)) (add-item-identifier topic-1 ii-2 :revision revision-2) + (is (= (length (d::versions topic-1)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-2) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (item-identifiers topic-1 :revision revision-0)) 2)) (is (= (length (item-identifiers topic-1 :revision revision-1)) 1)) (is (eql (first (item-identifiers topic-1 :revision revision-1)) ii-1)) @@ -180,6 +188,11 @@ :revision revision-2))) 2)) (delete-item-identifier topic-1 ii-2 :revision revision-3) + (is (= (length (d::versions topic-1)) 3)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-3) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is-false (item-identifiers topic-1 :revision revision-3)) (add-item-identifier topic-1 ii-1 :revision revision-4) (is (= (length (union (list ii-1) @@ -208,10 +221,20 @@ (signals error (make-instance 'PersistentIdC)) (is-false (psis topic-1)) (add-psi topic-1 psi-1) + (is (= (length (d::versions topic-1)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-1) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (psis topic-1)) 1)) (is (eql (first (psis topic-1)) psi-1)) (is (eql (identified-construct psi-1) topic-1)) (add-psi topic-1 psi-2 :revision revision-2) + (is (= (length (d::versions topic-1)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-2) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (psis topic-1 :revision revision-0)) 2)) (is (= (length (psis topic-1 :revision revision-1)) 1)) (is (eql (first (psis topic-1 :revision revision-1)) psi-1)) @@ -229,6 +252,11 @@ (psis topic-1 :revision revision-2))) 2)) (delete-psi topic-1 psi-2 :revision revision-3) + (is (= (length (d::versions topic-1)) 3)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-3) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is-false (psis topic-1 :revision revision-3)) (add-psi topic-1 psi-1 :revision revision-4) (is (= (length (union (list psi-1) @@ -257,10 +285,20 @@ (signals error (make-instance 'SubjectLocatorC)) (is-false (locators topic-1)) (add-locator topic-1 sl-1) + (is (= (length (d::versions topic-1)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-1) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (locators topic-1)) 1)) (is (eql (first (locators topic-1)) sl-1)) (is (eql (identified-construct sl-1) topic-1)) (add-locator topic-1 sl-2 :revision revision-2) + (is (= (length (d::versions topic-1)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-2) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (locators topic-1 :revision revision-0)) 2)) (is (= (length (locators topic-1 :revision revision-1)) 1)) (is (eql (first (locators topic-1 :revision revision-1)) sl-1)) @@ -271,6 +309,11 @@ (locators topic-1 :revision revision-0))) 2)) (delete-locator topic-1 sl-1 :revision revision-3) + (is (= (length (d::versions topic-1)) 3)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-3) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (union (list sl-2) (locators topic-1 :revision revision-0))) 1)) @@ -311,10 +354,20 @@ :xtm-id "xtm-id-1")) (is-false (topic-identifiers topic-1)) (add-topic-identifier topic-1 ti-1) + (is (= (length (d::versions topic-1)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-1) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (topic-identifiers topic-1)) 1)) (is (eql (first (topic-identifiers topic-1)) ti-1)) (is (eql (identified-construct ti-1) topic-1)) (add-topic-identifier topic-1 ti-2 :revision revision-2) + (is (= (length (d::versions topic-1)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-2) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (topic-identifiers topic-1 :revision revision-0)) 2)) (is (= (length (topic-identifiers topic-1 :revision revision-1)) 1)) (is (eql (first (topic-identifiers topic-1 :revision revision-1)) ti-1)) @@ -325,6 +378,11 @@ (topic-identifiers topic-1 :revision revision-0))) 2)) (delete-topic-identifier topic-1 ti-1 :revision revision-3) + (is (= (length (d::versions topic-1)) 3)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-3) + (= (d::end-revision vi) 0))) + (d::versions topic-1))) (is (= (length (union (list ti-2) (topic-identifiers topic-1 :revision revision-0))) 1)) @@ -529,16 +587,31 @@ "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))) + (reified-rc (make-instance 'd::AssociationC)) + (version-0-5 50) + (version-1 100) + (version-2 200) + (version-3 300)) (is-false (reifier reified-rc)) (is-false (reified-construct reifier-top)) - (add-reifier reified-rc reifier-top :revision 100) + (add-reifier reified-rc reifier-top :revision version-1) + (is (= (length (d::versions reified-rc)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) version-1) + (= (d::end-revision vi) 0))) + (d::versions reified-rc))) (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))))) + (is (eql reifier-top (reifier reified-rc :revision version-2))) + (is (eql reified-rc (reified-construct reifier-top :revision version-2))) + (is-false (reifier reified-rc :revision version-0-5)) + (is-false (reified-construct reifier-top :revision version-0-5)) + (delete-reifier reified-rc reifier-top :revision version-3) + (is (= (length (d::versions reified-rc)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) version-3) + (= (d::end-revision vi) 0))) + (d::versions reified-rc)))))) (test test-OccurrenceC () @@ -560,9 +633,19 @@ (is-false (parent occ-1)) (is-false (occurrences top-1)) (add-occurrence top-1 occ-1 :revision revision-1) + (is (= (length (d::versions top-1)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-1) + (= (d::end-revision vi) 0))) + (d::versions top-1))) (is (= (length (union (list occ-1) (occurrences top-1))) 1)) (add-occurrence top-1 occ-2 :revision revision-2) + (is (= (length (d::versions top-1)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-2) + (= (d::end-revision vi) 0))) + (d::versions top-1))) (is (= (length (union (list occ-1 occ-2) (occurrences top-1))) 2)) (is (= (length (union (list occ-1) @@ -570,6 +653,11 @@ (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 (d::versions top-1)) 4)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-4) + (= (d::end-revision vi) 0))) + (d::versions top-1))) (is (= (length (union (list occ-2) (occurrences top-1 :revision revision-4))) 1)) (is (= (length (union (list occ-2) @@ -594,7 +682,17 @@ (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) + (is (= (length (d::versions top-2)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-7) + (= (d::end-revision vi) 0))) + (d::versions top-2))) (delete-parent occ-2 top-2 :revision revision-8) + (is (= (length (d::versions top-2)) 3)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-8) + (= (d::end-revision vi) 0))) + (d::versions top-2))) (is-false (parent occ-2)) (add-parent occ-2 top-1 :revision revision-8) (is (eql top-1 (parent occ-2)))))) @@ -678,9 +776,19 @@ (is-false (parent name-1)) (is-false (names top-1)) (add-name top-1 name-1 :revision revision-1) + (is (= (length (d::versions top-1)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-1) + (= (d::end-revision vi) 0))) + (d::versions top-1))) (is (= (length (union (list name-1) (names top-1))) 1)) (add-name top-1 name-2 :revision revision-2) + (is (= (length (d::versions top-1)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-2) + (= (d::end-revision vi) 0))) + (d::versions top-1))) (is (= (length (union (list name-1 name-2) (names top-1))) 2)) (is (= (length (union (list name-1) @@ -688,6 +796,11 @@ (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 (d::versions top-1)) 4)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-4) + (= (d::end-revision vi) 0))) + (d::versions top-1))) (is (= (length (union (list name-2) (names top-1 :revision revision-4))) 1)) (is (= (length (union (list name-2) @@ -712,7 +825,17 @@ (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) + (is (= (length (d::versions top-2)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-7) + (= (d::end-revision vi) 0))) + (d::versions top-2))) (delete-parent name-2 top-2 :revision revision-8) + (is (= (length (d::versions top-2)) 3)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-8) + (= (d::end-revision vi) 0))) + (d::versions top-2))) (is-false (parent name-2)) (add-parent name-2 top-1 :revision revision-8) (is (eql top-1 (parent name-2)))))) @@ -812,15 +935,26 @@ (assoc-2 (make-instance 'AssociationC)) (revision-1 100) (revision-2 200) - (revision-3 300)) + (revision-3 300) + (revision-4 400)) (setf *TM-REVISION* revision-1) (is-false (roles assoc-1)) (is-false (parent role-1)) (add-parent role-1 assoc-1) + (is (= (length (d::versions assoc-1)) 1)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-1) + (= (d::end-revision vi) 0))) + (d::versions assoc-1))) (is (eql (parent role-1 :revision revision-1) assoc-1)) (is (= (length (union (list role-1) (roles assoc-1))) 1)) (add-role assoc-1 role-2 :revision revision-2) + (is (= (length (d::versions assoc-1)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-2) + (= (d::end-revision vi) 0))) + (d::versions assoc-1))) (is (= (length (union (list role-1 role-2) (roles assoc-1))) 2)) (is (= (length (union (list role-1) @@ -830,6 +964,11 @@ (is-false (parent role-2 :revision revision-1)) (signals error (add-parent role-2 assoc-2 :revision revision-2)) (delete-role assoc-1 role-1 :revision revision-3) + (is (= (length (d::versions assoc-1)) 3)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-3) + (= (d::end-revision vi) 0))) + (d::versions assoc-1))) (is-false (parent role-1)) (is (= (length (union (list role-2) (roles assoc-1))) 1)) @@ -850,7 +989,13 @@ (is (= (length (slot-value assoc-1 'roles)) 2)) (is (= (length (slot-value assoc-2 'roles)) 2)) (is (= (length (slot-value role-1 'parent)) 2)) - (is (= (length (slot-value role-2 'parent)) 2))))) + (is (= (length (slot-value role-2 'parent)) 2)) + (delete-parent role-1 assoc-2 :revision revision-4) + (is (= (length (d::versions assoc-2)) 2)) + (is-true (find-if #'(lambda(vi) + (and (= (d::start-revision vi) revision-4) + (= (d::end-revision vi) 0))) + (d::versions assoc-2)))))) (test test-player ()

1 0