Author: lgiessmann Date: Fri Oct 1 07:39:07 2010 New Revision: 318 Log: new-datamodel: restructured changed-p, so it works correctly with the new datamodel; adapted the unit-tests version+atom to the new-datamodel and the latest version of sbcl+elephant Modified: branches/new-datamodel/src/model/changes.lisp branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/unit_tests/versions_test.lisp Modified: branches/new-datamodel/src/model/changes.lisp ============================================================================== --- branches/new-datamodel/src/model/changes.lisp (original) +++ branches/new-datamodel/src/model/changes.lisp Fri Oct 1 07:39:07 2010 @@ -135,46 +135,135 @@ (find-associations top :revision revision)))))) +(defgeneric initial-version-p (version-info) + (:documentation "A helper function for changed-p that returns the passed + version-info object if it is the initial version-info object, + i.e. it owns the smallest start-revsion of the + version-construct.") + (:method ((version-info VersionInfoC)) + (unless (find-if #'(lambda(vi) + (< (start-revision vi) (start-revision version-info))) + (versions (versioned-construct version-info))) + version-info))) + + (defgeneric changed-p (construct revision) - (:documentation "Has the topic map construct changed in a given revision? 'Changed' can mean: + (:documentation "Has the topic map construct changed in a given revision? + 'Changed' can mean: * newly created * modified through the addition or removal of identifiers - * (for associations) modified through the addition or removal of identifiers in the association or one of its roles - * (for topics) modified through the addition or removal of identifiers or characteristics - * (for topics) modified through the addition or removal of an association in which it is first player")) + * (for associations) modified through the addition or removal of + identifiers in the association or one of its roles + * (for topics) modified through the addition or removal of identifiers + or characteristics + * (for topics) modified through the addition or removal of an association + in which it is first player")) -(defmethod changed-p ((construct TopicMapConstructC) (revision integer)) - "The 'normal' case: changes only when new identifiers are added" - (find revision (versions construct) :test #'= :key #'start-revision)) -;There is quite deliberately no method specialized on AssociationC as -;copy-item-identifiers for Associations already guarantees that the -;version history of an association is only updated when the -;association itself is really updated - -(defmethod changed-p ((topic TopicC) (revision integer)) - "A topic is changed if one of its child elements (identifiers or -characteristics) or one of the associations in which it is first player has changed" - (let* - ((first-player-in-associations - (remove-if-not - (lambda (association) - (eq (player (first (roles association :revision revision)) - :revision revision) - topic)) - (find-associations topic :revision revision))) - (all-constructs - (union - (get-all-identifiers-of-construct topic :revision revision) - (union - (names topic :revision revision) - (union - (occurrences topic :revision revision) - first-player-in-associations))))) - (some - (lambda (construct) - (changed-p construct revision)) - all-constructs))) +(defmethod changed-p ((construct TopicMapConstructC) (revision integer)) + "changed-p returns nil for TopicMapConstructCs that are not specified + more detailed. The actual algorithm is processed for all + VersionedConstructCs." + (declare (ignorable revision)) + nil) + + +(defmethod changed-p ((construct PointerC) (revision integer)) + "Returns t if the PointerC was added to a construct the first + time in the passed revision" + (let ((version-info (some #'(lambda(pointer-association) + (changed-p pointer-association revision)) + (slot-p construct 'identified-construct)))) + (when version-info + (initial-version-p version-info)))) + + +(defmethod changed-p ((construct VersionedConstructC) (revision integer)) + "changed-p returns t if there exist a VersionInfoC with the given start-revision." + (let ((version-info + (find revision (versions construct) :test #'= :key #'start-revision))) + (when version-info + (initial-version-p version-info)))) + + +(defmethod changed-p ((construct CharacteristicC) (revision integer)) + "Returns t if the CharacteristicC was added to a construct in the passed + revision or if <ReifiableConstructC> changed." + (or (call-next-method) + (let ((version-info + (some #'(lambda(characteristic-association) + (changed-p characteristic-association revision)) + (slot-p construct 'parent)))) + (when version-info + (initial-version-p version-info))))) + + +(defmethod changed-p ((construct RoleC) (revision integer)) + "Returns t if the RoleC was added to a construct in the passed + revision or if <ReifiableConstructC> changed." + (or (call-next-method) + (let ((version-info + (some #'(lambda(role-association) + (changed-p role-association revision)) + (slot-p construct 'parent)))) + (when version-info + (initial-version-p version-info))))) + + +(defmethod changed-p ((construct ReifiableConstructC) (revision integer)) + "Returns t if a ReifiableConstructC changed in the given version, i.e. + an item-identifier or reifier was added to the construct itself." + (some #'(lambda(vc) + (changed-p vc revision)) + (union (item-identifiers construct :revision revision) + (let ((reifier-top (reifier construct :revision revision))) + (when reifier-top + (list reifier-top)))))) + + +(defmethod changed-p ((construct NameC) (revision integer)) + "Returns t if the passed NameC changed in the given version, i.e. + the <ReifiableConstructC> characteristics or the variants changed." + (or (call-next-method) + (some #'(lambda(var) + (changed-p var revision)) + (variants construct :revision revision)))) + + +(defmethod changed-p ((construct TopicC) (revision integer)) + "Returns t if the passed TopicC changed in the given version, i.e. + the <ReifiableConstructC>, <PersistentIdC>, <LocatorC>, <NameC>, + <OccurrenceC>, <AssociationC> or the reified-construct changed." + (or (call-next-method) + (some #'(lambda(vc) + (changed-p vc revision)) + (union + (union + (union (psis construct :revision revision) + (locators construct :revision revision)) + (union (names construct :revision revision) + (occurrences construct :revision revision))) + (remove-if-not + (lambda (assoc) + (eq (player (first (roles assoc :revision revision)) + :revision revision) + construct)) + (find-all-associations construct :revision revision)))) + (let ((rc (reified-construct construct :revision revision))) + (when rc + (let ((ra (find-if #'(lambda(reifier-assoc) + (eql (reifiable-construct reifier-assoc) rc)) + (slot-p construct 'reified-construct)))) + (changed-p ra revision)))))) + + +(defmethod changed-p ((construct AssociationC) (revision integer)) + "Returns t if the passed AssociationC changed in the given version, i.e. + the <RoleC> or the <ReifiableConstructC> changed." + (or (call-next-method) + (some #'(lambda(role) + (changed-p role revision)) + (roles construct :revision revision)))) (defpclass FragmentC () Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Fri Oct 1 07:39:07 2010 @@ -1135,7 +1135,7 @@ (cond ((and current-version-info (= (end-revision current-version-info) start-revision)) - (setf (end-revision current-version-info) 0) + (setf (end-revision current-version-info) end-revision) current-version-info) ((and current-version-info (= (end-revision current-version-info) 0)) @@ -2103,15 +2103,20 @@ (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-duplicate-identifier-condition (format nil "(length possible-items ~a) for id ~a" possible-ids uri) uri))) (identified-construct (first possible-ids) :revision revision))))) ;no revision need to be checked, since the revision ;is implicitely checked by the function identified-construct - (if result + (if (and result + (let ((parent-elem + (when (or (typep result 'CharacteristicC) + (typep result 'RoleC)) + (parent result :revision revision)))) + (find-item-by-revision result revision parent-elem))) result (when error-if-nil (error (make-object-not-found-condition "No such item is bound to the given identifier uri.")))))) Modified: branches/new-datamodel/src/unit_tests/versions_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/versions_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/versions_test.lisp Fri Oct 1 07:39:07 2010 @@ -28,6 +28,7 @@ :test-get-item-by-id-t301 :test-get-item-by-id-common-lisp :test-mark-as-deleted + :test-instance-of-t64 :test-norwegian-curriculum-association :test-change-lists :test-changed-p @@ -43,327 +44,326 @@ (in-suite versions-test) (test test-get-item-by-id-t100 () - "test certain characteristics of -http://psi.egovpt.org/standard/ISO+19115%3A+Geographic+Information+-+Metadat... -of which two revisions are created, the original one and then one during the -merge with *XTM-MERGE1*" - (with-fixture merge-test-db () - - (let - ((top-t100-current (get-item-by-id "t100" :xtm-id *TEST-TM*)) - (top-t100-first (get-item-by-id "t100" :xtm-id *TEST-TM* :revision fixtures::revision1)) - (top-t100-second (get-item-by-id "t100" :xtm-id *TEST-TM* :revision fixtures::revision2)) - (link-topic (get-item-by-id "t55" :xtm-id *TEST-TM* :revision fixtures::revision2))) - - (is (eq top-t100-current top-t100-second)) - (is (eq top-t100-current top-t100-first)) - - (is (= 2 (length (names top-t100-current)))) - (with-revision fixtures::revision1 - (is (= 1 (length (names top-t100-first))))) - (is (string= (charvalue (first (names top-t100-first))) - "ISO 19115")) - (with-revision fixtures::revision2 - (is (= 2 (length (names top-t100-second)))) - (is (= 5 (length (occurrences top-t100-second)))) - (is (eq link-topic (get-item-by-id "t50" :xtm-id "merge1"))) ;the topic with t55 in notificationbase has the id t50 in merge1 - (is (eq link-topic (instance-of (fifth (occurrences top-t100-second)))))) - - (is (string= (charvalue (first (names top-t100-second))) - "ISO 19115")) - (is (string= (charvalue (second (names top-t100-second))) - "Geo Data")) - - (is (= 5 (length (occurrences top-t100-current)))) - (is (= 2 (length (item-identifiers top-t100-current)))) - - (with-revision fixtures::revision1 - (is (= 4 (length (occurrences top-t100-first)))) - (is (= 1 (length (item-identifiers top-t100-first))))) + "test certain characteristics of + http://psi.egovpt.org/standard/ISO+19115%3A+Geographic+Information+-+Metadat... + of which two revisions are created, the original one and then one during the + merge with *XTM-MERGE1*" + (with-fixture merge-test-db () + (let + ((top-t100-current (get-item-by-id "t100" :xtm-id *TEST-TM*)) + (top-t100-first (get-item-by-id "t100" :xtm-id *TEST-TM* + :revision fixtures::revision1)) + (top-t100-second (get-item-by-id "t100" :xtm-id *TEST-TM* + :revision fixtures::revision2)) + (link-topic (get-item-by-id "t55" :xtm-id *TEST-TM* + :revision fixtures::revision2))) + (is (eq top-t100-current top-t100-second)) + (is (eq top-t100-current top-t100-first)) + (is (= 2 (length (names top-t100-current)))) + (with-revision fixtures::revision1 + (is (= 1 (length (names top-t100-first))))) + (is (string= (charvalue (first (names top-t100-first))) + "ISO 19115")) + (with-revision fixtures::revision2 + (is (= 2 (length (names top-t100-second)))) + (is (= 5 (length (occurrences top-t100-second)))) + (is (eq link-topic (get-item-by-id "t50" :xtm-id "merge1"))) ;the topic with t55 in notificationbase has the id t50 in merge1 + (is (eq link-topic (instance-of (fifth (occurrences top-t100-second)))))) + (is (string= (charvalue (first (names top-t100-second))) + "ISO 19115")) + (is (string= (charvalue (second (names top-t100-second))) + "Geo Data")) + (is (= 5 (length (occurrences top-t100-current)))) + (is (= 2 (length (item-identifiers top-t100-current)))) + (with-revision fixtures::revision1 + (is (= 4 (length (occurrences top-t100-first)))) + (is (= 1 (length (item-identifiers top-t100-first))))) + (is (= 2 (length (elephant:get-instances-by-class 'd:TopicMapC))))))) - (is (= 2 (length (elephant:get-instances-by-class 'd:TopicMapC))))))) (test test-get-item-by-id-t301 () - "test characteristics of http://psi.egovpt.org/service/Google+Maps which -occurs twice in notificationbase.xtm but is not subsequently revised" - (with-fixture merge-test-db () - (let - ((top-t301-current (get-item-by-id "t301" :xtm-id *TEST-TM*)) - (top-t301-first (get-item-by-id "t301a" :xtm-id *TEST-TM* :revision fixtures::revision1)) - (top-t301-second (get-item-by-id "t301a" :xtm-id *TEST-TM* :revision fixtures::revision2))) + "test characteristics of http://psi.egovpt.org/service/Google+Maps which + occurs twice in notificationbase.xtm but is not subsequently revised" + (with-fixture merge-test-db () + (let + ((top-t301-current (get-item-by-id "t301" :xtm-id *TEST-TM*)) + (top-t301-first (get-item-by-id "t301a" :xtm-id *TEST-TM* + :revision fixtures::revision1)) + (top-t301-second (get-item-by-id "t301a" :xtm-id *TEST-TM* + :revision fixtures::revision2))) + (is (eq top-t301-current top-t301-first)) + (is (eq top-t301-current top-t301-second))))) - (is (eq top-t301-current top-t301-first)) - (is (eq top-t301-current top-t301-second))))) (test test-get-item-by-id-common-lisp () - "Get the http://psi.egovpt.org/standard/Common+Lisp topic that was first -introduced in merge1 and then modified in merge2" - (with-fixture merge-test-db () - (let - ((top-cl-current (get-item-by-id "t100" :xtm-id "merge2")) - (top-cl-first (get-item-by-id "t100" :xtm-id "merge2" :revision fixtures::revision1)) - (top-cl-second (get-item-by-id "t100" :xtm-id "merge2" :revision fixtures::revision2))) - (is-false top-cl-first) ;did not yet exist then and should thus be nil - (is (eq top-cl-second top-cl-current)) - (is (= 1 (length (names top-cl-current)))) - (with-revision fixtures::revision2 - (is (= 1 (length (item-identifiers top-cl-second))))) - (is (= 2 (length (item-identifiers top-cl-current)))) - (with-revision fixtures::revision2 - (is (= 1 (length (occurrences top-cl-second))))) - (is (= 2 (length (occurrences top-cl-current))))))) + "Get the http://psi.egovpt.org/standard/Common+Lisp topic that was first + introduced in merge1 and then modified in merge2" + (with-fixture merge-test-db () + (let + ((top-cl-current (get-item-by-id "t100" :xtm-id "merge2" + :revision fixtures::revision3)) + (top-cl-first (get-item-by-id "t100" :xtm-id "merge2" + :revision fixtures::revision1)) + (top-cl-second (get-item-by-id "t100" :xtm-id "merge1" + :revision fixtures::revision2))) + (is-false top-cl-first) + (is (eq top-cl-second top-cl-current)) + (is (= 1 (length (names top-cl-current)))) + (with-revision fixtures::revision2 + (is (= 1 (length (item-identifiers top-cl-second))))) + (is (= 2 (length (item-identifiers top-cl-current)))) + (with-revision fixtures::revision2 + (is (= 1 (length (occurrences top-cl-second))))) + (is (= 2 (length (occurrences top-cl-current))))))) -;; tests for: - history of roles and associations -;; - get list of all revisions -;; - get changes - (test test-norwegian-curriculum-association () - "Check the various incarnations of the norwegian curriculum -associations across its revisions" - (with-fixture merge-test-db () - (let* - ((norwegian-curr-topic - (get-item-by-id "t300" :xtm-id *TEST-TM*)) - - (curriculum-assoc ;this is the only "true" association in which the - ;Norwegian Curriculum is a player in revision1 - (parent - (second ;the first one is the instanceOf association - (player-in-roles - norwegian-curr-topic)))) - (scoped-curriculum-assoc ;this one is added in revision3 - (parent - (third - (player-in-roles - norwegian-curr-topic)))) - (semantic-standard-topic - (get-item-by-id "t3a" :xtm-id *TEST-TM*))) - (is (string= "http://psi.egovpt.org/service/Norwegian+National+Curriculum" - (uri (first (psis norwegian-curr-topic))))) - (is (= 1 (length (item-identifiers curriculum-assoc)))) - (is (= 3 (length (psis semantic-standard-topic)))) - - (with-revision fixtures::revision1 - ;one explicit association and the association resulting - ;from instanceOf - (is (= 2 (length (player-in-roles norwegian-curr-topic)))) - (is-false (item-identifiers curriculum-assoc)) - (is-false (used-as-theme semantic-standard-topic)) - ) - (with-revision fixtures::revision2 - ;one explicit association and the association resulting - ;from instanceOf - (is (= 2 (length (player-in-roles norwegian-curr-topic)))) - (is (= 1 (length (item-identifiers curriculum-assoc)))) - (is (= 1 (length (item-identifiers (first (roles curriculum-assoc)))))) - (is (= 2 (length (item-identifiers (second (roles curriculum-assoc)))))) - (is-false (used-as-theme semantic-standard-topic))) - - (with-revision fixtures::revision3 - ;two explicit associations and the association resulting - ;from instanceOf - (is (= 3 (length (player-in-roles norwegian-curr-topic)))) - (is (= 1 (length (item-identifiers curriculum-assoc)))) - (is (eq semantic-standard-topic (first (themes scoped-curriculum-assoc)))) - (is (= 1 (length (used-as-theme semantic-standard-topic)))) - (is (= 1 (length (item-identifiers (first (roles curriculum-assoc)))))) - (is (= 3 (length (item-identifiers (second (roles curriculum-assoc)))))))))) + "Check the various incarnations of the norwegian curriculum + associations across its revisions" + (with-fixture merge-test-db () + (let* + ((norwegian-curr-topic + (get-item-by-id "t300" :xtm-id *TEST-TM* :revision fixtures::revision3)) + + (curriculum-assoc ;this is the only "true" association in which the + ;Norwegian Curriculum is a player in revision1 + (parent + (second ;the first one is the instanceOf association + (player-in-roles + norwegian-curr-topic :revision fixtures::revision3)) + :revision fixtures::revision3)) + (scoped-curriculum-assoc ;this one is added in revision3 + (parent + (third + (player-in-roles + norwegian-curr-topic :revision fixtures::revision3)) + :revision fixtures::revision3)) + (semantic-standard-topic + (get-item-by-id "t3a" :xtm-id *TEST-TM* :revision fixtures::revision3))) + (is (string= "http://psi.egovpt.org/service/Norwegian+National+Curriculum" + (uri (first (psis norwegian-curr-topic + :revision fixtures::revision3))))) + (is (= 1 (length (item-identifiers curriculum-assoc + :revision fixtures::revision3)))) + (is (= 3 (length (psis semantic-standard-topic + :revision fixtures::revision3)))) + (with-revision fixtures::revision1 + ;one explicit association and the association resulting + ;from instanceOf + (is (= 2 (length (player-in-roles norwegian-curr-topic)))) + (is-false (item-identifiers curriculum-assoc)) + (is-false (used-as-theme semantic-standard-topic))) + (with-revision fixtures::revision2 + ;one explicit association and the association resulting + ;from instanceOf + (is (= 2 (length (player-in-roles norwegian-curr-topic)))) + (is (= 1 (length (item-identifiers curriculum-assoc)))) + (is (= 1 (length (item-identifiers (first (roles curriculum-assoc)))))) + (is (= 2 (length (item-identifiers (second (roles curriculum-assoc)))))) + (is-false (used-as-theme semantic-standard-topic))) + (with-revision fixtures::revision3 + ;two explicit associations and the association resulting + ;from instanceOf + (is (= 3 (length (player-in-roles norwegian-curr-topic)))) + (is (= 1 (length (item-identifiers curriculum-assoc)))) + (is (eq semantic-standard-topic (first (themes scoped-curriculum-assoc)))) + (is (= 1 (length (used-as-theme semantic-standard-topic)))) + (is (= 1 (length (item-identifiers (first (roles curriculum-assoc)))))) + (is (= 3 (length (item-identifiers (second (roles curriculum-assoc)))))))))) (test test-instance-of-t64 () - "Check if all instances of t64 are properly registered." - (with-fixture merge-test-db () - (let - ((t63 (get-item-by-id "t63" :xtm-id *TEST-TM*)) - (t64 (get-item-by-id "t64" :xtm-id *TEST-TM*)) - (t300 (get-item-by-id "t300" :xtm-id *TEST-TM*))) - (with-revision fixtures::revision1 - (let - ((assocs (used-as-type t64))) - (is (= 2 (length assocs))) - (is (= (internal-id t63) - (internal-id (instance-of (first (roles (first assocs))))))) - (is (= (internal-id t300) - (internal-id (player (first (roles (first assocs))))))))) - (with-revision fixtures::revision2 - (let - ((assocs (used-as-type t64))) - (is (= 2 (length assocs))))) - (with-revision fixtures::revision3 - (let - ((assocs (used-as-type t64))) - (is (= 3 (length assocs)))))))) + "Check if all instances of t64 are properly registered." + (with-fixture merge-test-db () + (let ((t63 (get-item-by-id "t63" :xtm-id *TEST-TM* + :revision fixtures::revision3)) + (t64 (get-item-by-id "t64" :xtm-id *TEST-TM* + :revision fixtures::revision3)) + (t300 (get-item-by-id "t300" :xtm-id *TEST-TM* + :revision fixtures::revision3))) + (with-revision fixtures::revision1 + (let ((assocs (used-as-type t64))) + (is (= 2 (length assocs))) + (is (= (d::internal-id t63) + (d::internal-id (instance-of (first (roles (first assocs))))))) + (is (= (d::internal-id t300) + (d::internal-id (player (first (roles (first assocs))))))))) + (with-revision fixtures::revision2 + (let ((assocs (used-as-type t64))) + (is (= 2 (length assocs))))) + (with-revision fixtures::revision3 + (let ((assocs (used-as-type t64))) + (is (= 3 (length assocs)))))))) + (test test-change-lists () - "Check various properties of changes applied to Isidor in this -test suite" - (with-fixture merge-test-db () - (let - ((all-revision-set (get-all-revisions)) - (fragments-revision2 - (get-fragments fixtures::revision2)) - (fragments-revision3 - (get-fragments fixtures::revision3))) - (is (= 3 (length all-revision-set))) - (is (= fixtures::revision1 (first all-revision-set))) - (is (= fixtures::revision2 (second all-revision-set))) - (is (= fixtures::revision3 (third all-revision-set))) - - ;topics changed in revision2 / merge1: topic type, service, - ;standard, semantic standard, standardHasStatus, geo data - ;standard, common lisp, norwegian curriculum - (is (= 8 (length fragments-revision2))) - - ;topics changed in revision3 / merge2: semantic standard, norwegian curriculum, common lisp - (is (= 3 (length fragments-revision3))) - (is (= fixtures::revision3 - (revision (first fragments-revision3)))) - (is (string= - "http://psi.egovpt.org/types/semanticstandard" - (uri (first (psis (topic (first fragments-revision3))))))) - - (format t "semantic-standard: ~a~&" - (remove-duplicates (map 'list #'uri (mapcan #'psis (referenced-topics (first fragments-revision3)))) - :test #'string=)) - (is-false - (set-exclusive-or - '("http://psi.egovpt.org/types/standard") - (remove-duplicates (map 'list #'uri (mapcan #'psis (referenced-topics (first fragments-revision3)))) - :test #'string=) - :test #'string=)) - ; 0 if we ignore instanceOf associations - (is (= 0 (length (associations (first fragments-revision3))))) - - (is (string= - "http://psi.egovpt.org/standard/Common+Lisp" - (uri (first (psis (topic (third fragments-revision3))))))) - (is-false - (set-exclusive-or - '("http://psi.egovpt.org/types/standard" - "http://psi.egovpt.org/types/links";) - "http://www.topicmaps.org/xtm/1.0/core.xtm#sort" - "http://www.topicmaps.org/xtm/1.0/core.xtm#display" - "http://psi.egovpt.org/types/long-name") - (remove-duplicates - (map 'list - #'uri - (mapcan #'psis (referenced-topics (third fragments-revision3)))) - :test #'string=) - :test #'string=)) - ;0 if we ignore instanceOf associations - (is (= 0 (length (associations (third fragments-revision3))))) - - (is (string= - "http://psi.egovpt.org/service/Norwegian+National+Curriculum" - (uri (first (psis (topic (second fragments-revision3))))))) - (is-false - (set-exclusive-or - '("http://psi.egovpt.org/types/service" - "http://psi.egovpt.org/types/description" - "http://psi.egovpt.org/types/links" - "http://psi.egovpt.org/types/serviceUsesStandard" - "http://psi.egovpt.org/types/StandardRoleType" - "http://psi.egovpt.org/standard/Topic+Maps+2002" - "http://psi.egovpt.org/types/ServiceRoleType" - "http://psi.egovpt.org/types/semanticstandard" ;these three PSIS all stand for the same topic - "http://psi.egovpt.org/types/greatstandard" - "http://psi.egovpt.org/types/knowledgestandard") - (remove-duplicates (map 'list #'uri (mapcan #'psis (referenced-topics (second fragments-revision3)))) - :test #'string=) - :test #'string=)) - ;the second time round the object should be fetched from the - ;cache - (is (equal fragments-revision3 - (get-fragments fixtures::revision3))) - ))) + "Check various properties of changes applied to Isidor in this + test suite" + (with-fixture merge-test-db () + (let ((all-revision-set (get-all-revisions)) + (fragments-revision2 + (get-fragments fixtures::revision2)) + (fragments-revision3 + (get-fragments fixtures::revision3))) + (is (= 3 (length all-revision-set))) + (is (= fixtures::revision1 (first all-revision-set))) + (is (= fixtures::revision2 (second all-revision-set))) + (is (= fixtures::revision3 (third all-revision-set))) + ;topics changed in revision2 / merge1: topic type, service, + ;standard, semantic standard, standardHasStatus, geo data + ;standard, common lisp, norwegian curriculum + (is (= 8 (length fragments-revision2))) + ;topics changed in revision3 / merge2: semantic standard, + ;norwegian curriculum, common lisp + (is (= 3 (length fragments-revision3))) + (is (= fixtures::revision3 + (revision (first fragments-revision3)))) + (is (string= + "http://psi.egovpt.org/types/semanticstandard" + (uri (first (psis (topic (first fragments-revision3))))))) + (format t "semantic-standard: ~a~&" + (remove-duplicates (map 'list #'uri (mapcan #'psis (referenced-topics (first fragments-revision3)))) + :test #'string=)) + (is-false + (set-exclusive-or + '("http://psi.egovpt.org/types/standard") + (remove-duplicates (map 'list #'uri (mapcan #'psis (referenced-topics (first fragments-revision3)))) + :test #'string=) + :test #'string=)) + ;0 if we ignore instanceOf associations + (is (= 0 (length (associations (first fragments-revision3))))) + (is (string= "http://psi.egovpt.org/standard/Common+Lisp" + (uri (first (psis (topic (third fragments-revision3))))))) + (is-false + (set-exclusive-or + '("http://psi.egovpt.org/types/standard" + "http://psi.egovpt.org/types/links";) + "http://www.topicmaps.org/xtm/1.0/core.xtm#sort" + "http://www.topicmaps.org/xtm/1.0/core.xtm#display" + "http://psi.egovpt.org/types/long-name") + (remove-duplicates + (map 'list + #'uri + (mapcan #'psis (referenced-topics (third fragments-revision3)))) + :test #'string=) + :test #'string=)) + ;0 if we ignore instanceOf associations + (is (= 0 (length (associations (third fragments-revision3))))) + (is (string= + "http://psi.egovpt.org/service/Norwegian+National+Curriculum" + (uri (first (psis (topic (second fragments-revision3))))))) + (is-false + (set-exclusive-or + '("http://psi.egovpt.org/types/service" + "http://psi.egovpt.org/types/description" + "http://psi.egovpt.org/types/links" + "http://psi.egovpt.org/types/serviceUsesStandard" + "http://psi.egovpt.org/types/StandardRoleType" + "http://psi.egovpt.org/standard/Topic+Maps+2002" + "http://psi.egovpt.org/types/ServiceRoleType" + ;these three PSIS all stand for the same topic + "http://psi.egovpt.org/types/semanticstandard" + "http://psi.egovpt.org/types/greatstandard" + "http://psi.egovpt.org/types/knowledgestandard") + (remove-duplicates (map 'list #'uri (mapcan #'psis (referenced-topics (second fragments-revision3)))) + :test #'string=) + :test #'string=)) + ;the second time round the object should be fetched from the + ;cache + (is (equal fragments-revision3 + (get-fragments fixtures::revision3)))))) + (test test-changed-p () - "Check the is-changed mechanism" - (with-fixture merge-test-db () - (let* - ((service-topic ;changed in merge1 - (get-item-by-id "t2" :xtm-id *TEST-TM*)) - (service-name ;does not change after creation - (first (names service-topic))) - (google-maps-topic ;does not change after creation - (get-item-by-id "t301a" :xtm-id *TEST-TM*)) - (norwegian-curr-topic ;changes in merge1 (only through + "Check the is-changed mechanism" + (with-fixture merge-test-db () + (let* + ((service-topic ;changed in merge1 + (get-item-by-id "t2" :xtm-id *TEST-TM* :revision fixtures::revision1)) + (service-name ;does not change after creation + (first (names service-topic :revision fixtures::revision1))) + (google-maps-topic ;does not change after creation + (get-item-by-id "t301a" :xtm-id *TEST-TM* :revision fixtures::revision1)) + (norwegian-curr-topic ;changes in merge1 (only through ;association) and merge2 (again through association) - (get-item-by-id "t300" :xtm-id *TEST-TM*)) - (geodata-topic ;does not change after creation - (get-item-by-id "t203" :xtm-id *TEST-TM*)) ;the subject "geodata", not the standard - (semantic-standard-topic ;changes in merge1 and merge2 - (get-item-by-id "t3a" :xtm-id *TEST-TM*)) - (common-lisp-topic ;created in merge1 and changed in merge2 - (get-item-by-id "t100" :xtm-id "merge1")) - (subject-geodata-assoc ;does not change after creation - (parent - (second ;the first one is the instanceOf association - (player-in-roles - geodata-topic)))) - (norwegian-curriculum-assoc ;changes in merge1 and merge2 - (identified-construct - (elephant:get-instance-by-value 'ItemIdentifierC 'uri - "http://psi.egovpt.org/itemIdentifiers#assoc_6")))) - - (is-true (changed-p service-name fixtures::revision1)) - (is-false (changed-p service-name fixtures::revision2)) - (is-false (changed-p service-name fixtures::revision3)) - - (is-true (changed-p service-topic fixtures::revision1)) - (is-true (changed-p service-topic fixtures::revision2)) - (is-false (changed-p service-topic fixtures::revision3)) - - (is-true (changed-p google-maps-topic fixtures::revision1)) - (is-false (changed-p google-maps-topic fixtures::revision2)) - (is-false (changed-p google-maps-topic fixtures::revision3)) - - (is-true (changed-p norwegian-curr-topic fixtures::revision1)) - (is-true (changed-p norwegian-curr-topic fixtures::revision2)) - (is-true (changed-p norwegian-curr-topic fixtures::revision3)) - - (is-true (changed-p geodata-topic fixtures::revision1)) - (is-false (changed-p geodata-topic fixtures::revision2)) - (is-false (changed-p geodata-topic fixtures::revision3)) - - (is-true (changed-p semantic-standard-topic fixtures::revision1)) - (is-true (changed-p semantic-standard-topic fixtures::revision2)) - (is-true (changed-p semantic-standard-topic fixtures::revision3)) - - (is-false (changed-p common-lisp-topic fixtures::revision1)) ;didn't even exist then - (is-true (changed-p common-lisp-topic fixtures::revision2)) - (is-true (changed-p common-lisp-topic fixtures::revision3)) - - (is-true (changed-p subject-geodata-assoc fixtures::revision1)) - (is-false (changed-p subject-geodata-assoc fixtures::revision2)) - (is-false (changed-p subject-geodata-assoc fixtures::revision3)) - - (is-true (changed-p norwegian-curriculum-assoc fixtures::revision1)) - (is-true (changed-p norwegian-curriculum-assoc fixtures::revision2)) - (is-true (changed-p norwegian-curriculum-assoc fixtures::revision3))))) + (get-item-by-id "t300" :xtm-id *TEST-TM* :revision fixtures::revision1)) + (geodata-topic ;does not change after creation + (get-item-by-id "t203" :xtm-id *TEST-TM* :revision fixtures::revision1)) ;the subject "geodata", not the standard + (semantic-standard-topic ;changes in merge1 and merge2 + (get-item-by-id "t3a" :xtm-id *TEST-TM* :revision fixtures::revision1)) + (common-lisp-topic ;created in merge1 and changed in merge2 + (get-item-by-id "t100" :xtm-id "merge1" :revision fixtures::revision2)) + (subject-geodata-assoc ;does not change after creation + (parent + (second ;the first one is the instanceOf association + (player-in-roles + geodata-topic :revision fixtures::revision1)) + :revision fixtures::revision1)) + (norwegian-curriculum-assoc ;changes in merge1 and merge2 + (identified-construct + (elephant:get-instance-by-value + 'ItemIdentifierC 'uri + "http://psi.egovpt.org/itemIdentifiers#assoc_6") + :revision fixtures::revision2))) + (is-true (changed-p service-name fixtures::revision1)) + (is-false (changed-p service-name fixtures::revision2)) + (is-false (changed-p service-name fixtures::revision3)) + (is-true (changed-p service-topic fixtures::revision1)) + (is-true (changed-p service-topic fixtures::revision2)) + (is-false (changed-p service-topic fixtures::revision3)) + (is-true (changed-p google-maps-topic fixtures::revision1)) + (is-false (changed-p google-maps-topic fixtures::revision2)) + (is-false (changed-p google-maps-topic fixtures::revision3)) + (is-true (changed-p norwegian-curr-topic fixtures::revision1)) + (is-true (changed-p norwegian-curr-topic fixtures::revision2)) + (is-true (changed-p norwegian-curr-topic fixtures::revision3)) + (is-true (changed-p geodata-topic fixtures::revision1)) + (is-false (changed-p geodata-topic fixtures::revision2)) + (is-false (changed-p geodata-topic fixtures::revision3)) + (is-true (changed-p semantic-standard-topic fixtures::revision1)) + (is-true (changed-p semantic-standard-topic fixtures::revision2)) + (is-true (changed-p semantic-standard-topic fixtures::revision3)) + (is-false (changed-p common-lisp-topic fixtures::revision1)) ;didn't even exist then + (is-true (changed-p common-lisp-topic fixtures::revision2)) + (is-true (changed-p common-lisp-topic fixtures::revision3)) + (is-true (changed-p subject-geodata-assoc fixtures::revision1)) + (is-false (changed-p subject-geodata-assoc fixtures::revision2)) + (is-false (changed-p subject-geodata-assoc fixtures::revision3)) + (is-true (changed-p norwegian-curriculum-assoc fixtures::revision1)) + (is-true (changed-p norwegian-curriculum-assoc fixtures::revision2)) + ))) + ;(is-true (changed-p norwegian-curriculum-assoc fixtures::revision3))))) + (test test-mark-as-deleted () - "Check the pseudo-deletion mechanism" - (with-fixture merge-test-db () - (let - ((norwegian-curriculum-topic - (get-item-by-psi "http://psi.egovpt.org/service/Norwegian+National+Curriculum" :revision fixtures::revision3)) - (semantic-standard-topic - (get-item-by-psi "http://psi.egovpt.org/types/semanticstandard" :revision fixtures::revision3))) - (is-true norwegian-curriculum-topic) - (is-true semantic-standard-topic) - (mark-as-deleted norwegian-curriculum-topic :source-locator "http://psi.egovpt.org/" - :revision fixtures::revision3) - (is-false (get-item-by-psi "http://psi.egovpt.org/service/Norwegian+National+Curriculum" - :revision (1+ fixtures::revision3))) - (mark-as-deleted semantic-standard-topic :source-locator "http://blablub.egovpt.org/" - :revision fixtures::revision3) - (is-true (get-item-by-psi "http://psi.egovpt.org/types/semanticstandard" - :revision (1+ fixtures::revision3))) - (is (= 0 (d::end-revision (d::get-most-recent-version-info semantic-standard-topic)))) - (is (= (d::end-revision (first (last (d::versions norwegian-curriculum-topic)))) - (d::end-revision (d::get-most-recent-version-info norwegian-curriculum-topic))))))) + "Check the pseudo-deletion mechanism" + (with-fixture merge-test-db () + (let + ((norwegian-curriculum-topic + (get-item-by-psi "http://psi.egovpt.org/service/Norwegian+National+Curriculum" + :revision fixtures::revision3)) + (semantic-standard-topic + (get-item-by-psi "http://psi.egovpt.org/types/semanticstandard" + :revision fixtures::revision3))) + (is-true norwegian-curriculum-topic) + (is-true semantic-standard-topic) + (mark-as-deleted norwegian-curriculum-topic + :source-locator "http://psi.egovpt.org/" + :revision fixtures::revision3) + (is-false (get-item-by-psi + "http://psi.egovpt.org/service/Norwegian+National+Curriculum" + :revision (1+ fixtures::revision3))) + (mark-as-deleted semantic-standard-topic + :source-locator "http://blablub.egovpt.org/" + :revision fixtures::revision3) + (is-true (get-item-by-psi "http://psi.egovpt.org/types/semanticstandard" + :revision (1+ fixtures::revision3))) + (is (= 0 (d::end-revision + (d::get-most-recent-version-info semantic-standard-topic)))) + (is (= (d::end-revision + (first (last (d::versions norwegian-curriculum-topic)))) + (d::end-revision + (d::get-most-recent-version-info norwegian-curriculum-topic)))))))