October 2010 - isidorus-cvs@common-lisp.net

[isidorus-cvs] r323 - tags/textgrid-service
by Lukas Giessmann 08 Oct '10

08 Oct '10

Author: lgiessmann Date: Fri Oct 8 06:22:34 2010 New Revision: 323 Log: Tagging the isidorus-version which is used as registry service for the textGrid project Added: tags/textgrid-service/ - copied from r322, /trunk/

1 0

[isidorus-cvs] r322 - in branches/new-datamodel/src: unit_tests xml/rdf xml/xtm
by Lukas Giessmann 08 Oct '10

08 Oct '10

Author: lgiessmann Date: Fri Oct 8 06:12:59 2010 New Revision: 322 Log: new-datamodel: fixed ticket #72 -> http://trac.common-lisp.net/isidorus/ticket/72 Modified: branches/new-datamodel/src/unit_tests/exporter_xtm2.0_test.lisp branches/new-datamodel/src/unit_tests/fixtures.lisp branches/new-datamodel/src/unit_tests/importer_test.lisp branches/new-datamodel/src/unit_tests/json_test.lisp branches/new-datamodel/src/unit_tests/rdf_importer_test.lisp branches/new-datamodel/src/xml/rdf/importer.lisp branches/new-datamodel/src/xml/xtm/setup.lisp Modified: branches/new-datamodel/src/unit_tests/exporter_xtm2.0_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/exporter_xtm2.0_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/exporter_xtm2.0_test.lisp Fri Oct 8 06:12:59 2010 @@ -71,8 +71,8 @@ (handler-case (delete-file *out-xtm1.0-file*) (error () )) ;do nothing (setup-repository *sample_objects_2_0.xtm* "data_base" :xtm-id "test-tm" - :tm-id "http://isidorus.org/test-tm")) - ;(elephant:open-store (get-store-spec "data_base"))) + :tm-id "http://isidorus.org/test-tm") + (elephant:open-store (get-store-spec "data_base"))) (def-fixture refill-test-db () Modified: branches/new-datamodel/src/unit_tests/fixtures.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/fixtures.lisp (original) +++ branches/new-datamodel/src/unit_tests/fixtures.lisp Fri Oct 8 06:12:59 2010 @@ -190,8 +190,7 @@ (setf d:*current-xtm* document-id) (rdf-importer:setup-rdf-module *poems_light.rdf* db-dir :tm-id tm-id :document-id document-id) - - ;(elephant:open-store (xml-importer:get-store-spec db-dir)) + (elephant:open-store (xml-importer:get-store-spec db-dir)) (&body) (tear-down-test-db))) @@ -207,7 +206,7 @@ (setf d:*current-xtm* document-id) (setup-repository *poems_light.xtm* db-dir :tm-id tm-id :xtm-id document-id) - ;(elephant:open-store (xml-importer:get-store-spec db-dir)) + (elephant:open-store (xml-importer:get-store-spec db-dir)) (rdf-exporter:export-rdf exported-file-path :tm-id tm-id) (&body) (handler-case (delete-file exported-file-path) Modified: branches/new-datamodel/src/unit_tests/importer_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/importer_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/importer_test.lisp Fri Oct 8 06:12:59 2010 @@ -440,7 +440,7 @@ :tm-id "http://www.isidor.us/unittests/xtm1.0-tests" :xtm-id *TEST-TM* :xtm-format '1.0) (setf *TM-REVISION* 0) - ;(elephant:open-store (xml-importer:get-store-spec dir)) + (elephant:open-store (xml-importer:get-store-spec dir)) ;13 + (23 core topics) (is (= 36 (length (elephant:get-instances-by-class 'TopicC)))) ;2 + (11 instanceOf) @@ -603,7 +603,7 @@ (xml-importer:setup-repository *sample_objects.xtm* dir :xtm-id *TEST-TM* :xtm-format '1.0 :tm-id "http://isidorus.org/test-tm") - ;(elephant:open-store (xml-importer:get-store-spec dir)) + (elephant:open-store (xml-importer:get-store-spec dir)) (is (= (length (elephant:get-instances-by-class 'VariantC)) 5)) (let ((t-2526 (get-item-by-id "t-2526"))) (loop for baseName in (names t-2526) Modified: branches/new-datamodel/src/unit_tests/json_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/json_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/json_test.lisp Fri Oct 8 06:12:59 2010 @@ -64,8 +64,7 @@ (with-fixture initialize-destination-db (dir) (xml-importer:setup-repository *notificationbase.xtm* dir :tm-id "http://www.isidor.us/unittests/testtm" - :xtm-id *TEST-TM*) - + :xtm-id *TEST-TM*) (elephant:open-store (xml-importer:get-store-spec dir)) (let ((t50a (get-item-by-id "t50a" :xtm-id *TEST-TM* :revision rev-0))) (let ((t50a-string (to-json-string t50a :revision 0)) @@ -102,6 +101,7 @@ (xml-importer:setup-repository *notificationbase.xtm* dir :tm-id "http://www.isidor.us/unittests/testtm" :xtm-id *TEST-TM*) + (elephant:open-store (xml-importer:get-store-spec dir)) (let ((t57 (get-item-by-id "t57" :revision rev-0 :xtm-id *TEST-TM*)) (t59 (get-item-by-id "t59" :revision rev-0 :xtm-id *TEST-TM*)) (t202 (get-item-by-id "t202" :revision rev-0 :xtm-id *TEST-TM*)) @@ -165,6 +165,7 @@ (xml-importer:setup-repository *notificationbase.xtm* dir :tm-id "http://www.isidor.us/unittests/testtm" :xtm-id *TEST-TM*) + (elephant:open-store (xml-importer:get-store-spec dir)) (let ((frag-t100 (create-latest-fragment-of-topic "http://psi.egovpt.org/standard/ISO+19115%3A+Geographic+Information+-+Metada…")) @@ -189,6 +190,7 @@ (xml-importer:setup-repository *notificationbase.xtm* dir :tm-id "http://www.isidor.us/unittests/testtm" :xtm-id *TEST-TM*) + (elephant:open-store (xml-importer:get-store-spec dir)) (let ((json-fragment (let ((fragment-obj (create-latest-fragment-of-topic "http://psi.egovpt.org/standard/Topic+Maps+2002"))) @@ -222,6 +224,7 @@ (xml-importer:setup-repository *notificationbase.xtm* dir :tm-id "http://www.isidor.us/unittests/testtm" :xtm-id *TEST-TM*) + (elephant:open-store (xml-importer:get-store-spec dir)) (let ((json-fragment (let ((fragment-obj (create-latest-fragment-of-topic "http://psi.egovpt.org/standard/Topic+Maps+2002"))) @@ -287,6 +290,7 @@ (xml-importer:setup-repository *notificationbase.xtm* dir :tm-id "http://www.isidor.us/unittests/testtm" :xtm-id *TEST-TM*) + (elephant:open-store (xml-importer:get-store-spec dir)) (let ((json-fragment (let ((fragment-obj (create-latest-fragment-of-topic "http://psi.egovpt.org/standard/Topic+Maps+2002"))) @@ -348,6 +352,7 @@ (xml-importer:setup-repository *notificationbase.xtm* dir :tm-id "http://www.isidor.us/unittests/testtm" :xtm-id *TEST-TM*) + (elephant:open-store (xml-importer:get-store-spec dir)) (let ((json-fragment (let ((fragment-obj (create-latest-fragment-of-topic "http://psi.egovpt.org/standard/Topic+Maps+2002"))) @@ -453,6 +458,7 @@ (xml-importer:setup-repository *notificationbase.xtm* dir :tm-id "http://www.isidor.us/unittests/testtm" :xtm-id *TEST-TM*) + (elephant:open-store (xml-importer:get-store-spec dir)) (let ((json-fragment (let ((fragment-obj (create-latest-fragment-of-topic "http://psi.egovpt.org/standard/Topic+Maps+2002"))) @@ -1324,6 +1330,7 @@ (xml-importer:setup-repository *notificationbase.xtm* dir :tm-id "http://www.isidor.us/unittests/testtm" :xtm-id *TEST-TM*) + (elephant:open-store (xml-importer:get-store-spec dir)) (let ((json-psis (json:decode-json-from-string (get-all-topic-psis :revision rev-0)))) (is (= (length json-psis) Modified: branches/new-datamodel/src/unit_tests/rdf_importer_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/rdf_importer_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/rdf_importer_test.lisp Fri Oct 8 06:12:59 2010 @@ -2866,7 +2866,7 @@ (rdf-importer:rdf-importer rdf-file dir :tm-id tm-id :document-id document-id) - ;(elephant:open-store (xml-importer:get-store-spec dir)) + (elephant:open-store (xml-importer:get-store-spec dir)) (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 15)) (is (= (length (elephant:get-instances-by-class 'd:AssociationC)) 1)) (is (= (length (elephant:get-instances-by-class 'd:NameC)) 4)) Modified: branches/new-datamodel/src/xml/rdf/importer.lisp ============================================================================== --- branches/new-datamodel/src/xml/rdf/importer.lisp (original) +++ branches/new-datamodel/src/xml/rdf/importer.lisp Fri Oct 8 06:12:59 2010 @@ -20,9 +20,9 @@ (xml-importer:init-isidorus) (init-rdf-module) (rdf-importer rdf-xml-path repository-path :tm-id tm-id - :document-id document-id)) -; (when elephant:*store-controller* -; (elephant:close-store))) + :document-id document-id) + (when elephant:*store-controller* + (elephant:close-store))) (defun rdf-importer (rdf-xml-path repository-path @@ -46,7 +46,7 @@ (format t "#Objects in the store: Topics: ~a, Associations: ~a~%" (length (elephant:get-instances-by-class 'TopicC)) (length (elephant:get-instances-by-class 'AssociationC))) -; (elephant:close-store) + (elephant:close-store) (setf *_n-map* nil))) Modified: branches/new-datamodel/src/xml/xtm/setup.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/setup.lisp (original) +++ branches/new-datamodel/src/xml/xtm/setup.lisp Fri Oct 8 06:12:59 2010 @@ -50,6 +50,6 @@ (elephant:open-store (get-store-spec repository-path))) (init-isidorus) - (import-xtm xtm-path repository-path :tm-id tm-id :xtm-id xtm-id :xtm-format xtm-format)) -; (when elephant:*store-controller* -; (elephant:close-store))) \ No newline at end of file + (import-xtm xtm-path repository-path :tm-id tm-id :xtm-id xtm-id :xtm-format xtm-format) + (when elephant:*store-controller* + (elephant:close-store))) \ No newline at end of file

1 0

[isidorus-cvs] r321 - in branches/new-datamodel/src: unit_tests xml/rdf
by Lukas Giessmann 07 Oct '10

07 Oct '10

Author: lgiessmann Date: Thu Oct 7 17:01:08 2010 New Revision: 321 Log: new-datamodel: adapted the rdf-exporter to the new datamodel; adapted the rdf-exporter-unit-tests to the new datamodel Modified: branches/new-datamodel/src/unit_tests/fixtures.lisp branches/new-datamodel/src/unit_tests/rdf_exporter_test.lisp branches/new-datamodel/src/xml/rdf/exporter.lisp Modified: branches/new-datamodel/src/unit_tests/fixtures.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/fixtures.lisp (original) +++ branches/new-datamodel/src/unit_tests/fixtures.lisp Thu Oct 7 17:01:08 2010 @@ -207,7 +207,7 @@ (setf d:*current-xtm* document-id) (setup-repository *poems_light.xtm* db-dir :tm-id tm-id :xtm-id document-id) - (elephant:open-store (xml-importer:get-store-spec db-dir)) + ;(elephant:open-store (xml-importer:get-store-spec db-dir)) (rdf-exporter:export-rdf exported-file-path :tm-id tm-id) (&body) (handler-case (delete-file exported-file-path) Modified: branches/new-datamodel/src/unit_tests/rdf_exporter_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/rdf_exporter_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/rdf_exporter_test.lisp Thu Oct 7 17:01:08 2010 @@ -349,14 +349,14 @@ 'string "id_" (write-to-string (elephant::oid - (d:topic + (d:parent (elephant:get-instance-by-value 'd:OccurrenceC 'd:charvalue "28.08.1749")))))) (died-id (concatenate 'string "id_" (write-to-string (elephant::oid - (d:topic + (d:parent (elephant:get-instance-by-value 'd:OccurrenceC 'd:charvalue "22.03.1832"))))))) (is-true (property-p me *sw-arc* "born" :nodeID born-id)) @@ -395,7 +395,7 @@ 'string "id_" (write-to-string (elephant::oid - (d:topic + (d:parent (elephant:get-instance-by-value 'd:OccurrenceC 'd:charvalue "31.12.1782"))))))) (is-true (property-p me *sw-arc* "dateRange" @@ -423,7 +423,7 @@ 'string "id_" (write-to-string (elephant::oid - (d:topic + (d:parent (elephant:get-instance-by-value 'd:OccurrenceC 'd:charvalue "01.01.1772"))))))) (is-true (property-p me *sw-arc* "dateRange" @@ -431,7 +431,7 @@ (test test-zauberlehrling - "Tests the resoruce zauberlehrling." + "Tests the resource zauberlehrling." (with-fixture rdf-exporter-test-db () (let ((zauberlehrlings (get-resources-by-uri "http://some.where/poem/Der_Zauberlehrling"))) @@ -465,7 +465,7 @@ 'string "id_" (write-to-string (elephant::oid - (d:topic + (d:parent (elephant:get-instance-by-value 'd:OccurrenceC 'd:charvalue "01.01.1797"))))))) (is-true (property-p me *sw-arc* "dateRange" @@ -600,7 +600,7 @@ 'string "id_" (write-to-string (elephant::oid - (d:topic + (d:parent (elephant:get-instance-by-value 'd:OccurrenceC 'd:charvalue "28.08.1749"))))))) @@ -627,7 +627,7 @@ 'string "id_" (write-to-string (elephant::oid - (d:topic + (d:parent (elephant:get-instance-by-value 'd:OccurrenceC 'd:charvalue "22.03.1832"))))))) @@ -654,7 +654,7 @@ 'string "id_" (write-to-string (elephant::oid - (d:topic + (d:parent (elephant:get-instance-by-value 'd:OccurrenceC 'd:charvalue "01.01.1797"))))))) @@ -675,7 +675,7 @@ 'string "id_" (write-to-string (elephant::oid - (d:topic + (d:parent (elephant:get-instance-by-value 'd:OccurrenceC 'd:charvalue "01.01.1782"))))))) @@ -696,7 +696,7 @@ 'string "id_" (write-to-string (elephant::oid - (d:topic + (d:parent (elephant:get-instance-by-value 'd:OccurrenceC 'd:charvalue "01.01.1772"))))))) @@ -717,7 +717,7 @@ 'string "id_" (write-to-string (elephant::oid - (d:topic + (d:parent (elephant:get-instance-by-value 'd:OccurrenceC 'd:charvalue "http://de.wikipedia.org/wiki/Schiller"))))))) @@ -872,7 +872,7 @@ 'string "id_" (write-to-string (elephant::oid - (d:topic + (d:parent (elephant:get-instance-by-value 'd:OccurrenceC 'd:charvalue "http://de.wikipedia.org/wiki/Schiller"))))))) Modified: branches/new-datamodel/src/xml/rdf/exporter.lisp ============================================================================== --- branches/new-datamodel/src/xml/rdf/exporter.lisp (original) +++ branches/new-datamodel/src/xml/rdf/exporter.lisp Thu Oct 7 17:01:08 2010 @@ -75,8 +75,8 @@ (defmacro with-property (construct &body body) "Generates a property element with a corresponding namespace - and tag name before executing the body. This macro is for usin - in occurrences and association that are mapped to RDF properties." + and tag name before executing the body. This macro is for using + in occurrences and associations that are mapped to RDF properties." `(let ((ns-list (separate-uri (rdf-li-or-uri (uri (first (psis (instance-of ,construct)))))))) @@ -306,7 +306,7 @@ (make-isi-type *tm2rdf-name-type-uri*) (export-reifier-as-mapping construct) (map 'list #'to-rdf-elem (item-identifiers construct)) - (when (slot-boundp construct 'instance-of) + (when (instance-of construct) (cxml:with-element "isi:nametype" (make-topic-reference (instance-of construct)))) (scopes-to-rdf-elems construct)

1 0

[isidorus-cvs] r320 - in branches/new-datamodel/src: model unit_tests xml/rdf
by Lukas Giessmann 06 Oct '10

06 Oct '10

Author: lgiessmann Date: Wed Oct 6 17:30:04 2010 New Revision: 320 Log: new-datamodel: adapted the rdf-importer unit-tests to the new datamodel; adapted the rdf-importer and the rdf-importer-mapping-tools to the new datamodel; fixed a bug in elephant where all subclasses of PointerC are returned when requesting one particular subctype Modified: branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/unit_tests/fixtures.lisp branches/new-datamodel/src/unit_tests/rdf_importer_test.lisp branches/new-datamodel/src/xml/rdf/importer.lisp branches/new-datamodel/src/xml/rdf/map_to_tm.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 Oct 6 17:30:04 2010 @@ -2056,14 +2056,15 @@ (let ((possible-top-ids (delete-if-not #'(lambda(top-id) - (and (string= (xtm-id top-id) xtm-id) + (and (typep top-id 'd:TopicIdentificationC) + ;fixes a bug in elephant -> all PointerCs are returned + (string= (xtm-id top-id) xtm-id) (string= (uri top-id) topic-id))) ;fixes a bug in get-instances-by-value that does a ;case-insensitive comparision (elephant:get-instances-by-value 'TopicIdentificationC - 'uri - topic-id)))) + 'uri topic-id)))) (when (and possible-top-ids (identified-construct (first possible-top-ids) :revision revision)) @@ -2074,7 +2075,7 @@ topic-id))) (identified-construct (first possible-top-ids) :revision revision) - ;no revision need not to be chaecked, since the revision + ;no revision need not to be checked, since the revision ;is implicitely checked by the function identified-construct )) (when (and (> (length topic-id) 0) @@ -2100,12 +2101,14 @@ (let ((possible-ids (delete-if-not #'(lambda(id) - (string= (uri id) uri)) + (and (typep id identifier-type-symbol) + (string= (uri id) uri))) (get-instances-by-value identifier-type-symbol 'uri uri)))) (when (and possible-ids (identified-construct (first possible-ids) :revision revision)) (unless (= (length possible-ids) 1) + (format t "==> ~a~%" possible-ids) (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))))) @@ -3039,12 +3042,19 @@ (declare (integer revision)) (dolist (id (get-all-identifiers-of-construct construct :revision revision)) (when (> - (length - (union - (elephant:get-instances-by-value 'ItemIdentifierC 'uri (uri id)) - (union - (elephant:get-instances-by-value 'PersistentIdC 'uri (uri id)) - (elephant:get-instances-by-value 'SubjectLocatorC 'uri (uri id))))) + (length + (delete-if-not #'(lambda(identifier) + (or (typep identifier 'PersistentIdC) + (typep identifier 'SubjectLocatorC) + (typep identifier 'ItemIdentifierC))) + (union + (elephant:get-instances-by-value + 'ItemIdentifierC 'uri (uri id)) + (union + (elephant:get-instances-by-value + 'PersistentIdC 'uri (uri id)) + (elephant:get-instances-by-value + 'SubjectLocatorC 'uri (uri id)))))) 1) (error (make-duplicate-identifier-condition (format nil "Duplicate Identifier ~a has been found" (uri id)) (uri id)))))) @@ -3829,8 +3839,10 @@ #'null (map 'list #'(lambda(existing-pointer) - (when (equivalent-construct existing-pointer :uri uri - :xtm-id xtm-id) + (when (and (typep existing-pointer class-symbol) + (equivalent-construct existing-pointer + :uri uri + :xtm-id xtm-id)) existing-pointer)) (elephant:get-instances-by-value class-symbol 'd::uri uri))))) (if existing-pointer Modified: branches/new-datamodel/src/unit_tests/fixtures.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/fixtures.lisp (original) +++ branches/new-datamodel/src/unit_tests/fixtures.lisp Wed Oct 6 17:30:04 2010 @@ -190,7 +190,8 @@ (setf d:*current-xtm* document-id) (rdf-importer:setup-rdf-module *poems_light.rdf* db-dir :tm-id tm-id :document-id document-id) - (elephant:open-store (xml-importer:get-store-spec db-dir)) + + ;(elephant:open-store (xml-importer:get-store-spec db-dir)) (&body) (tear-down-test-db))) Modified: branches/new-datamodel/src/unit_tests/rdf_importer_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/rdf_importer_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/rdf_importer_test.lisp Wed Oct 6 17:30:04 2010 @@ -1054,9 +1054,11 @@ :document-id document-id) (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 20)) (let ((first-node (get-item-by-id "http://test-tm/first-node" - :xtm-id document-id)) + :xtm-id document-id + :revision 0)) (first-type (get-item-by-id "http://test-tm/first-type" - :xtm-id document-id))) + :xtm-id document-id + :revision 0))) (is-true first-node) (is (= (length (d::versions first-node)) 1)) (is (= (d::start-revision (first (d::versions first-node))) @@ -1066,11 +1068,12 @@ (is (= (length (d:player-in-roles first-node)) 1)) (is (= (length (d:player-in-roles first-type)) 1)) (let ((instance-role - (first (d:player-in-roles first-node))) + (first (d:player-in-roles first-node :revision 0))) (type-role - (first (d:player-in-roles first-type))) + (first (d:player-in-roles first-type :revision 0))) (type-assoc - (d:parent (first (d:player-in-roles first-node))))) + (d:parent (first (d:player-in-roles first-node :revision 0)) + :revision 0))) (is (= (length (d::versions type-assoc)) 1)) (is (= (d::start-revision (first (d::versions type-assoc))) revision-2)) @@ -1080,7 +1083,7 @@ (d:get-item-by-psi *type-psi*))) (is (eql (d:instance-of type-assoc) (d:get-item-by-psi *type-instance-psi*))) - (is (= (length (d:roles type-assoc)) 2)) + (is (= (length (d:roles type-assoc :revision 0)) 2)) (is (= (length (d:psis first-node)) 1)) (is (= (length (d:psis first-type)) 1)) (is (string= (d:uri (first (d:psis first-node))) @@ -1095,19 +1098,24 @@ tm-id revision-3 :document-id document-id)) (let ((first-node (get-item-by-id "http://test-tm/first-node" - :xtm-id document-id)) + :xtm-id document-id + :revision 0)) (first-type (get-item-by-id "http://test-tm/first-type" - :xtm-id document-id)) + :xtm-id document-id + :revision 0)) (second-node (get-item-by-id "second-node" - :xtm-id document-id)) + :xtm-id document-id + :revision 0)) (second-type (get-item-by-id "http://test-tm/second-type" - :xtm-id document-id)) + :xtm-id document-id + :revision 0)) (third-node (get-item-by-id "http://test-tm#third-node" - :xtm-id document-id))) + :xtm-id document-id + :revision 0))) (is-true second-node) - (is-false (d:psis second-node)) - (is-false (d:occurrences second-node)) - (is-false (d:names second-node)) + (is-false (d:psis second-node :revision 0)) + (is-false (d:occurrences second-node :revision 0)) + (is-false (d:names second-node :revision 0)) (is-true first-node) (is (= (length (d::versions first-node)) 2)) (is-true (find-if #'(lambda(x) @@ -1119,18 +1127,22 @@ (= (d::end-revision x) 0))) (d::versions first-node))) (let ((instance-role - (first (d:player-in-roles first-node))) + (first (d:player-in-roles first-node :revision 0))) (type-role - (first (d:player-in-roles first-type))) + (first (d:player-in-roles first-type :revision 0))) (type-assoc - (d:parent (first (d:player-in-roles first-node)))) - (type-topic (get-item-by-psi *type-psi*)) - (instance-topic (get-item-by-psi *instance-psi*)) - (type-instance-topic (get-item-by-psi *type-instance-psi*)) - (supertype-topic (get-item-by-psi *supertype-psi*)) - (subtype-topic (get-item-by-psi *subtype-psi*)) + (d:parent (first (d:player-in-roles first-node + :revision 0)))) + (type-topic (get-item-by-psi *type-psi* :revision 0)) + (instance-topic (get-item-by-psi *instance-psi* :revision 0)) + (type-instance-topic (get-item-by-psi *type-instance-psi* + :revision 0)) + (supertype-topic (get-item-by-psi *supertype-psi* + :revision 0)) + (subtype-topic (get-item-by-psi *subtype-psi* + :revision 0)) (supertype-subtype-topic - (get-item-by-psi *supertype-subtype-psi*)) + (get-item-by-psi *supertype-subtype-psi* :revision 0)) (arc2-occurrence (elephant:get-instance-by-value 'd:OccurrenceC 'd:charvalue "arc-2")) (arc3-occurrence @@ -1138,18 +1150,19 @@ 'd:OccurrenceC 'd:charvalue "<root><content type=\"anyContent\">content</content></root>")) (fifth-node (d:get-item-by-id "http://test-tm#fifth-node" - :xtm-id document-id))) - (is (eql (d:instance-of instance-role) - (d:get-item-by-psi *instance-psi*))) - (is (eql (d:instance-of type-role) - (d:get-item-by-psi *type-psi*))) - (is (eql (d:instance-of type-assoc) - (d:get-item-by-psi *type-instance-psi*))) - (is (= (length (d:roles type-assoc)) 2)) - (is (= (length (d:psis first-node)) 1)) - (is (= (length (d:psis first-type)) 1)) - (is (= (length (d::versions type-assoc)) 1)) - (is (= (length (d:player-in-roles second-node)) 2)) + :xtm-id document-id + :revision 0))) + (is (eql (d:instance-of instance-role :revision 0) + (d:get-item-by-psi *instance-psi* :revision 0))) + (is (eql (d:instance-of type-role :revision 0) + (d:get-item-by-psi *type-psi* :revision 0))) + (is (eql (d:instance-of type-assoc :revision 0) + (d:get-item-by-psi *type-instance-psi* :revision 0))) + (is (= (length (d:roles type-assoc :revision 0)) 2)) + (is (= (length (d:psis first-node :revision 0)) 1)) + (is (= (length (d:psis first-type :revision 0)) 1)) + (is (= (length (d::versions type-assoc)) 2)) + (is (= (length (d:player-in-roles second-node :revision 0)) 2)) (is-true (find-if #'(lambda(x) (and (eql (d:instance-of x) instance-topic) @@ -1176,16 +1189,16 @@ (d:player-in-roles third-node))) (is-true arc2-occurrence) (is (string= (d:datatype arc2-occurrence) "http://test-tm/dt")) - (is-false (d:psis (d:topic arc2-occurrence))) - (is (= (length (d::versions (d:topic arc2-occurrence))) 1)) + (is-false (d:psis (d:parent arc2-occurrence))) + (is (= (length (d::versions (d:parent arc2-occurrence))) 1)) (is (= (d::start-revision - (first (d::versions (d:topic arc2-occurrence)))) + (first (d::versions (d:parent arc2-occurrence)))) revision-3)) (is (= (d::end-revision - (first (d::versions (d:topic arc2-occurrence)))) 0)) + (first (d::versions (d:parent arc2-occurrence)))) 0)) (is-true arc3-occurrence) - (is (= (length (d:psis (d:topic arc3-occurrence))))) - (is (string= (d:uri (first (d:psis (d:topic arc3-occurrence)))) + (is (= (length (d:psis (d:parent arc3-occurrence))))) + (is (string= (d:uri (first (d:psis (d:parent arc3-occurrence)))) "http://test-tm/fourth-node")) (is (string= (d:datatype arc3-occurrence) *xml-string*)) @@ -1592,8 +1605,8 @@ (concatenate 'string arcs "firstName")) (string= *xml-string* (d:datatype x)) (= (length (d:themes x)) 0) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) goethe))) occs) 1)) @@ -1604,8 +1617,8 @@ (concatenate 'string arcs "lastName")) (string= *xml-string* (d:datatype x)) (= (length (d:themes x)) 0) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) goethe))) occs) 1)) @@ -1616,8 +1629,8 @@ (concatenate 'string arcs "fullName")) (string= *xml-string* (d:datatype x)) (= (length (d:themes x)) 0) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) weimar))) occs) 1)) @@ -1628,8 +1641,8 @@ (concatenate 'string arcs "fullName")) (string= *xml-string* (d:datatype x)) (= (length (d:themes x)) 0) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) frankfurt))) occs) 1)) @@ -1641,8 +1654,8 @@ (string= *xml-string* (d:datatype x)) (= 1 (length (d:themes x))) (eql (first (d:themes x)) de) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) germany))) occs) 1)) @@ -1655,8 +1668,8 @@ (string= (d:charvalue x) "Der Zauberlehrling") (= 1 (length (d:themes x))) (eql (first (d:themes x)) de) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) zauberlehrling))) occs) 1)) @@ -1668,8 +1681,8 @@ (= 0 (length (d:themes x))) (string= (d:charvalue x) "Prometheus") (string= *xml-string* (d:datatype x)) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) prometheus))) occs) 1)) @@ -1682,8 +1695,8 @@ (string= (d:charvalue x) "Der Erlkönig") (= 1 (length (d:themes x))) (eql (first (d:themes x)) de) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) erlkoenig))) occs) 1)) @@ -1696,8 +1709,8 @@ (string= (d:charvalue x) "Hat der alte Hexenmeister ...") (= 1 (length (d:themes x))) (eql (first (d:themes x)) de) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) zauberlehrling))) occs) 1)) @@ -1711,8 +1724,8 @@ " Bedecke deinen Himmel, Zeus, ... ") (= 1 (length (d:themes x))) (eql (first (d:themes x)) de) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) prometheus))) occs) 1)) @@ -1726,8 +1739,8 @@ "Wer reitet so spät durch Nacht und Wind? ...") (= 1 (length (d:themes x))) (eql (first (d:themes x)) de) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) erlkoenig))) occs) 1)) @@ -1738,8 +1751,8 @@ (concatenate 'string arcs "population")) (string= long (d:datatype x)) (= 0 (length (d:themes x))) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) weimar))) occs) 1)) @@ -1750,8 +1763,8 @@ (concatenate 'string arcs "population")) (string= long (d:datatype x)) (= 0 (length (d:themes x))) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) frankfurt))) occs) 1)) @@ -1762,8 +1775,8 @@ (concatenate 'string arcs "population")) (string= long (d:datatype x)) (= 0 (length (d:themes x))) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) berlin))) occs) 1)) @@ -1774,8 +1787,8 @@ (concatenate 'string arcs "population")) (string= long (d:datatype x)) (= 0 (length (d:themes x))) - (= (length (d:psis (d:topic x))) 1) - (string= (d:uri (first (d:psis (d:topic x)))) + (= (length (d:psis (d:parent x))) 1) + (string= (d:uri (first (d:psis (d:parent x)))) germany))) occs) 1)) @@ -1786,7 +1799,7 @@ (concatenate 'string arcs "date")) (string= date (d:datatype x)) (= 0 (length (d:themes x))) - (= (length (d:psis (d:topic x))) 0))) + (= (length (d:psis (d:parent x))) 0))) occs) 2)) (is (= (count-if @@ -1797,7 +1810,7 @@ (string= date (d:datatype x)) (= 1 (length (d:themes x))) (eql (first (d:themes x)) de) - (= (length (d:psis (d:topic x))) 0))) + (= (length (d:psis (d:parent x))) 0))) occs) 1)) @@ -1808,7 +1821,7 @@ (concatenate 'string arcs "start")) (string= date (d:datatype x)) (= 0 (length (d:themes x))) - (= (length (d:psis (d:topic x))) 0))) + (= (length (d:psis (d:parent x))) 0))) occs) 2)) @@ -1820,7 +1833,7 @@ (string= date (d:datatype x)) (= 1 (length (d:themes x))) (eql (first (d:themes x)) de) - (= (length (d:psis (d:topic x))) 0))) + (= (length (d:psis (d:parent x))) 0))) occs) 1)) (is (= (count-if @@ -1830,7 +1843,7 @@ (concatenate 'string arcs "end")) (string= date (d:datatype x)) (= 0 (length (d:themes x))) - (= (length (d:psis (d:topic x))) 0))) + (= (length (d:psis (d:parent x))) 0))) occs) 2))))) @@ -2853,7 +2866,7 @@ (rdf-importer:rdf-importer rdf-file dir :tm-id tm-id :document-id document-id) - (elephant:open-store (xml-importer:get-store-spec dir)) + ;(elephant:open-store (xml-importer:get-store-spec dir)) (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 15)) (is (= (length (elephant:get-instances-by-class 'd:AssociationC)) 1)) (is (= (length (elephant:get-instances-by-class 'd:NameC)) 4)) @@ -2937,16 +2950,18 @@ (is-true marge-ln) (is (string= (d:charvalue marge-fn) "Marjorie")) (is (string= (d:charvalue marge-ln) "Simpson")) - (is (= (length (d:variants marge-fn)) 1)) - (is (= (length (d:themes (first (d:variants marge-fn)))) 1)) - (is (eql (first (d:themes (first (d:variants marge-fn)))) display)) - (is (string= (d:charvalue (first (d:variants marge-fn))) "Marge")) - (is (string= (d:datatype (first (d:variants marge-fn))) *xml-string*)) + (is (= (length (d:variants marge-fn :revision 0)) 1)) + (is (= (length (d:themes (first (d:variants marge-fn :revision 0)) + :revision 0)) 1)) + (is (eql (first (d:themes (first (d:variants marge-fn :revision 0)) + :revision 0)) display)) + (is (string= (d:charvalue (first (d:variants marge-fn :revision 0))) "Marge")) + (is (string= (d:datatype (first (d:variants marge-fn :revision 0))) *xml-string*)) (is-true marge-occ) (is (string= (d:charvalue marge-occ) "Housewife")) (is (string= (d:datatype marge-occ) *xml-string*)) - (is (= (length (d:themes marge-occ)) 0)) - (is (= (length (d:psis marge)) 2)))))) + (is (= (length (d:themes marge-occ :revision 0)) 0)) + (is (= (length (d:psis marge :revision 0)) 2)))))) (test test-full-mapping-homer Modified: branches/new-datamodel/src/xml/rdf/importer.lisp ============================================================================== --- branches/new-datamodel/src/xml/rdf/importer.lisp (original) +++ branches/new-datamodel/src/xml/rdf/importer.lisp Wed Oct 6 17:30:04 2010 @@ -72,7 +72,7 @@ (defun import-dom (rdf-dom start-revision &key (tm-id nil) (document-id *document-id*)) - "Imports the entire dom of a rdf-xml-file." + "Imports the entire dom of an rdf-xml-file." (setf *_n-map* nil) ;in case of an failed last call (tm-id-p tm-id "import-dom") (let ((xml-base (get-xml-base rdf-dom)) @@ -137,7 +137,7 @@ (defun import-arc (elem tm-id start-revision &key (document-id *document-id*) (parent-xml-base nil) (parent-xml-lang nil)) - "Imports a property that is an blank_node and continues the recursion + "Imports a property that is a blank_node and continues the recursion on this element." (declare (dom:element elem)) (let ((xml-lang (get-xml-lang elem :old-lang parent-xml-lang)) @@ -351,9 +351,11 @@ (error "~aone of the role types ~a ~a is missing!" err-pref *supertype-psi* *subtype-psi*)) (let ((a-roles (list (list :instance-of role-type-1 - :player super-top) + :player super-top + :start-revision start-revision) (list :instance-of role-type-2 - :player sub-top)))) + :player sub-top + :start-revision start-revision)))) (let ((assoc (add-to-tm tm @@ -392,9 +394,11 @@ (error "~aone of the role types ~a ~a is missing!" err-pref *type-psi* *instance-psi*)) (let ((a-roles (list (list :instance-of roletype-1 - :player type-top) + :player type-top + :start-revision start-revision) (list :instance-of roletype-2 - :player instance-top)))) + :player instance-top + :start-revision start-revision)))) (let ((assoc (add-to-tm tm @@ -420,40 +424,35 @@ (ii-uri (unless (or about ID) (concatenate 'string *rdf2tm-blank-node-prefix* (or nodeID UUID))))) - (let ((top - ;seems like there is a bug in d:get-item-by-id: - ;this functions returns an emtpy topic although there is no one - ;with a corresponding topic id and/or version. - ;Thus the version is temporary checked manually. - (let ((inner-top - (get-item-by-id topic-id :xtm-id document-id - :revision start-revision))) - (when inner-top - (let ((versions (d::versions inner-top))) - (when (find-if #'(lambda(version) - (= start-revision - (d::start-revision version))) - versions) - inner-top)))))) + (let ((top (get-item-by-id topic-id :xtm-id document-id + :revision start-revision))) (if top - top + (progn + (d::add-to-version-history top :start-revision start-revision) + top) (elephant:ensure-transaction (:txn-nosync t) (let ((psis (when psi-uri (list - (make-instance 'PersistentIdC + (make-construct 'PersistentIdC :uri psi-uri :start-revision start-revision)))) (iis (when ii-uri (list - (make-instance 'ItemIdentifierC + (make-construct 'ItemIdentifierC :uri ii-uri - :start-revision start-revision))))) + :start-revision start-revision)))) + (topic-ids (when topic-id + (list + (make-construct 'TopicIdentificationC + :uri topic-id + :xtm-id document-id + :start-revision start-revision))))) (handler-case (let ((top (add-to-tm tm (make-construct - 'TopicC - :topicid topic-id + 'TopicC + :topic-identifiers topic-ids :psis psis :item-identifiers iis :xtm-id document-id @@ -498,9 +497,11 @@ (type-top (make-topic-stub type nil nil nil start-revision tm :document-id document-id))) (let ((roles (list (list :instance-of role-type-1 - :player player-1) + :player player-1 + :start-revision start-revision) (list :instance-of role-type-2 - :player top)))) + :player top + :start-revision start-revision)))) (let ((assoc (add-to-tm tm (make-construct 'AssociationC :start-revision start-revision @@ -527,9 +528,11 @@ (make-topic-stub *rdf2tm-object* nil nil nil start-revision tm :document-id document-id))) (let ((roles (list (list :instance-of role-type-1 - :player subject-topic) + :player subject-topic + :start-revision start-revision) (list :instance-of role-type-2 - :player object-topic)))) + :player object-topic + :start-revision start-revision)))) (let ((assoc (add-to-tm tm (make-construct 'AssociationC @@ -541,13 +544,14 @@ -(defun make-reification(reifier-id reifiable-construct start-revision tm &key (document-id *document-id*)) +(defun make-reification(reifier-id reifiable-construct start-revision tm &key + (document-id *document-id*)) (declare (string reifier-id)) (declare (ReifiableConstructC reifiable-construct)) (declare (TopicMapC tm)) (let ((reifier-topic (make-topic-stub reifier-id nil nil nil start-revision tm :document-id document-id))) - (add-reifier reifiable-construct reifier-topic))) + (add-reifier reifiable-construct reifier-topic :revision start-revision))) (defun make-occurrence (top literal start-revision tm-id @@ -572,7 +576,7 @@ (let ((occurrence (make-construct 'OccurrenceC :start-revision start-revision - :topic top + :parent top :themes (when lang-top (list lang-top)) :instance-of type-top Modified: branches/new-datamodel/src/xml/rdf/map_to_tm.lisp ============================================================================== --- branches/new-datamodel/src/xml/rdf/map_to_tm.lisp (original) +++ branches/new-datamodel/src/xml/rdf/map_to_tm.lisp Wed Oct 6 17:30:04 2010 @@ -57,42 +57,51 @@ (let ((type-topic (get-item-by-psi type-psi :revision start-revision))) (when type-topic - (when (and (not (player-in-roles type-topic)) - (not (used-as-type type-topic)) - (not (used-as-theme type-topic))) + (when (and (not (player-in-roles type-topic :revision start-revision)) + (not (used-as-type type-topic :revision start-revision)) + (not (used-as-theme type-topic :revision start-revision))) (d::delete-construct type-topic))))) -(defun delete-instance-of-association(instance-topic type-topic) +(defun delete-instance-of-association(instance-topic type-topic start-revision) "Deletes a type-instance associaiton that corresponds with the passed parameters." (when (and instance-topic type-topic) - (let ((instance (get-item-by-psi *instance-psi*)) - (type-instance (get-item-by-psi *type-instance-psi*)) - (type (get-item-by-psi *type-psi*))) - (declare (TopicC instance-topic type-topic)) + (let ((instance (get-item-by-psi *instance-psi* :revision start-revision)) + (type-instance (get-item-by-psi *type-instance-psi* + :revision start-revision)) + (type (get-item-by-psi *type-psi* :revision start-revision))) + (declare (TopicC instance-topic type-topic) + (integer start-revision)) (let ((assocs (remove-if #'null (map 'list #'(lambda(role) - (when (and (eql (instance-of role) instance) - (eql (instance-of (parent role)) - type-instance)) - (parent role))) - (player-in-roles instance-topic))))) + (when (and + (eql (instance-of role :revision start-revision) + instance) + (eql (instance-of + (parent role :revision start-revision) + :revision start-revision) + type-instance)) + (parent role :revision start-revision))) + (player-in-roles instance-topic :revision start-revision))))) (map 'list #'(lambda(assoc) - (when (find-if #'(lambda(role) - (and (eql (instance-of role) type) - (eql (player role) type-topic))) - (roles assoc)) + (when (find-if + #'(lambda(role) + (and (eql (instance-of role :revision start-revision) + type) + (eql (player role :revision start-revision) + type-topic))) + (roles assoc :revision start-revision)) (d::delete-construct assoc))) assocs) nil)))) -(defun delete-related-associations (top) +(defun delete-related-associations (top start-revision) "Deletes all associaitons related to the passed topic." - (dolist (assoc-role (player-in-roles top)) + (dolist (assoc-role (player-in-roles top :revision start-revision)) (d::delete-construct (parent assoc-role))) top) @@ -141,11 +150,12 @@ (when (= 0 (length role-players)) (error "~aexpect one player but found: ~a" err-pref (length role-players))) - (delete-related-associations role-top) + (delete-related-associations role-top start-revision) (d::delete-construct role-top) (list :instance-of (first types) :player (first role-players) :item-identifiers ids + :start-revision start-revision :reifiers reifiers))))) @@ -185,7 +195,7 @@ (when (= 0 (length assoc-roles)) (error "~aexpect at least one role but found: ~a" err-pref (length assoc-roles))) - (delete-related-associations assoc-top) + (delete-related-associations assoc-top start-revision) (d::delete-construct assoc-top) (with-tm (start-revision document-id tm-id) (add-to-tm @@ -208,10 +218,11 @@ assoc-roles))) (when found-item (dolist (reifier-topic (getf found-item :reifiers)) - (add-reifier association-role reifier-topic))))) - (roles association)) + (add-reifier association-role reifier-topic + :revision start-revision))))) + (roles association :revision start-revision)) (dolist (reifier-topic reifier-topics) - (add-reifier association reifier-topic)) + (add-reifier association reifier-topic :revision start-revision)) association))))))) @@ -267,7 +278,7 @@ variant-top start-revision *tm2rdf-scope-property* *rdf2tm-subject*)) (value-type-topic - (get-item-by-psi *tm2rdf-value-property*))) + (get-item-by-psi *tm2rdf-value-property* :revision start-revision))) (let ((scopes (get-players-by-role-type scope-assocs start-revision *rdf2tm-object*)) (value-and-datatype @@ -283,7 +294,7 @@ (reifiers (get-isi-reifiers variant-top start-revision))) (elephant:ensure-transaction (:txn-nosync t) (map 'list #'d::delete-construct scope-assocs) - (delete-related-associations variant-top) + (delete-related-associations variant-top start-revision) (d::delete-construct variant-top) (let ((variant (make-construct 'VariantC @@ -292,9 +303,9 @@ :themes scopes :charvalue (getf value-and-datatype :value) :datatype (getf value-and-datatype :datatype) - :name name))) + :parent name))) (dolist (reifier-topic reifiers) - (add-reifier variant reifier-topic)) + (add-reifier variant reifier-topic :revision start-revision)) variant))))) @@ -312,7 +323,7 @@ name-top start-revision *tm2rdf-scope-property* *rdf2tm-subject*)) (value-type-topic - (get-item-by-psi *tm2rdf-value-property*)) + (get-item-by-psi *tm2rdf-value-property* :revision start-revision)) (variant-topics (get-isi-variants name-top start-revision))) (let ((type (let ((fn-types (get-players-by-role-type @@ -335,7 +346,7 @@ (map 'list #'d::delete-construct scope-assocs) (let ((name (make-construct 'NameC :start-revision start-revision - :topic top + :parent top :charvalue value :instance-of type :item-identifiers ids @@ -344,10 +355,10 @@ (map-isi-variant name variant-topic start-revision)) variant-topics) - (delete-related-associations name-top) + (delete-related-associations name-top start-revision) (d::delete-construct name-top) (dolist (reifier-topic reifiers) - (add-reifier name reifier-topic)) + (add-reifier name reifier-topic :revision start-revision)) name))))) @@ -403,19 +414,19 @@ (when (/= 1 (length types)) (error "~aexpect one type topic but found: ~a" err-pref (length types))) - (delete-related-associations occ-top) + (delete-related-associations occ-top start-revision) (d::delete-construct occ-top) (let ((occurrence (make-construct 'OccurrenceC :start-revision start-revision - :topic top + :parent top :themes scopes :item-identifiers ids :instance-of (first types) :charvalue (getf value-and-datatype :value) :datatype (getf value-and-datatype :datatype)))) (dolist (reifier-topic reifiers) - (add-reifier occurrence reifier-topic)) + (add-reifier occurrence reifier-topic :revision start-revision)) occurrence))))) @@ -448,12 +459,15 @@ (let ((topics-in-tm (with-tm (start-revision document-id tm-id) (intersection isi-topics (topics xml-importer::tm))))) - (map 'list #'(lambda(top) - (map 'list - #'(lambda(role) - (when (find (parent role) assocs) - (d::delete-construct (parent role)))) - (player-in-roles top))) + (map 'list + #'(lambda(top) + (map 'list + #'(lambda(role) + (when (find (parent role :revision start-revision) + assocs) + (d::delete-construct + (parent role :revision start-revision)))) + (player-in-roles top :revision start-revision))) topics-in-tm) topics-in-tm)))))) @@ -497,11 +511,13 @@ (map 'list #'(lambda(assoc) (let ((role - (find-if #'(lambda(role) - (eql role-type (instance-of role))) - (roles assoc)))) + (find-if + #'(lambda(role) + (eql role-type (instance-of role + :revision start-revision))) + (roles assoc :revision start-revision)))) (when role - (player role)))) + (player role :revision start-revision)))) associations)))) players))) @@ -517,16 +533,18 @@ (remove-if #'null (map 'list #'(lambda(occurrence) - (let ((type (instance-of occurrence))) + (let ((type + (instance-of occurrence + :revision start-revision))) (let ((type-psi (find-if #'(lambda(psi) (string= occurrence-type-uri (uri psi))) - (psis type)))) + (psis type :revision start-revision)))) (when type-psi occurrence)))) - (occurrences top))))) + (occurrences top :revision start-revision))))) identifier-occs))) @@ -566,11 +584,11 @@ (dolist (id identifiers) (declare (ItemIdentifierC id)) (if (find-if #'(lambda(ii) - (string= (uri ii) (uri id))) - (item-identifiers construct)) + (and (string= (uri ii) (uri id)) + (not (eql ii id)))) + (item-identifiers construct :revision start-revision)) (d::delete-construct id) - (add-item-identifier (identified-construct id :revision start-revision) - construct :revision start-revision))) + (add-item-identifier construct id :revision start-revision))) construct) @@ -580,11 +598,11 @@ (dolist (id identifiers) (declare (PersistentIdC id)) (if (find-if #'(lambda(psi) - (string= (uri psi) (uri id))) - (psis top)) + (and (string= (uri psi) (uri id)) + (not (eql psi id)))) + (psis top :revision start-revision)) (d::delete-construct id) - (add-psi (identified-construct id :revision start-revision) - top :revision start-revision))) + (add-psi top id :revision start-revision))) top) @@ -594,11 +612,11 @@ (dolist (id locators) (declare (SubjectLocatorC id)) (if (find-if #'(lambda(locator) - (string= (uri locator) (uri id))) - (locators top)) + (and (string= (uri locator) (uri id)) + (not (eql locator id)))) + (locators top :revision start-revision)) (d::delete-construct id) - (add-locator (identified-construct id :revision start-revision) - top :revision start-revision))) + (add-locator top id :revision start-revision))) top)

1 0

[isidorus-cvs] r319 - in branches/new-datamodel/src: model unit_tests xml/rdf
by Lukas Giessmann 02 Oct '10

02 Oct '10

Author: lgiessmann Date: Sat Oct 2 05:20:25 2010 New Revision: 319 Log: new-datamodel: changed "changed-p", so a ReifiableConstructC also changed when an ItemIdentifierC or a reifier was marked-as-deleted one revision ago; a NameC changed also when a variant was marked-as-deleted one revsion ago; a TopicC changed when any identifier or CharacteristicC was marked-as-deleted one revision ago; an AssociationC changed also when a RoleC was marked-as-deleted one revision ago Modified: branches/new-datamodel/src/model/changes.lisp branches/new-datamodel/src/unit_tests/versions_test.lisp branches/new-datamodel/src/xml/rdf/exporter.lisp Modified: branches/new-datamodel/src/model/changes.lisp ============================================================================== --- branches/new-datamodel/src/model/changes.lisp (original) +++ branches/new-datamodel/src/model/changes.lisp Sat Oct 2 05:20:25 2010 @@ -151,6 +151,7 @@ (:documentation "Has the topic map construct changed in a given revision? 'Changed' can mean: * newly created + * deletion of an element * 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 @@ -210,15 +211,36 @@ (initial-version-p version-info))))) +(defgeneric end-revision-p (construct revision) + (:documentation "A helper function for changed-p. It returns the latest + version-info if the passed versioned-construct was + marked-as-deleted in the version that is given.") + (:method ((construct VersionedConstructC) (revision integer)) + (let ((version-info (find revision (versions construct) + :key #'end-revision :test #'=))) + (when (and version-info + (not + (find-if + #'(lambda(vi) + (or (> (end-revision vi) (end-revision version-info)) + (= (end-revision vi) 0))) + (versions construct)))) + 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)))))) + (or (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))))) + (some #'(lambda(vc) + (end-revision-p vc revision)) + (union (slot-p construct 'item-identifiers) + (slot-p construct 'reifier))))) (defmethod changed-p ((construct NameC) (revision integer)) @@ -227,7 +249,10 @@ (or (call-next-method) (some #'(lambda(var) (changed-p var revision)) - (variants construct :revision revision)))) + (variants construct :revision revision)) + (some #'(lambda(vc) + (end-revision-p vc revision)) + (slot-p construct 'variants)))) (defmethod changed-p ((construct TopicC) (revision integer)) @@ -254,7 +279,15 @@ (let ((ra (find-if #'(lambda(reifier-assoc) (eql (reifiable-construct reifier-assoc) rc)) (slot-p construct 'reified-construct)))) - (changed-p ra revision)))))) + (changed-p ra revision)))) + (some #'(lambda(vc) + (end-revision-p vc revision)) + (union (union (union (slot-p construct 'psis) + (slot-p construct 'locators)) + (union (slot-p construct 'names) + (slot-p construct 'occurrences))) + (slot-p construct 'reified-construct))))) + (defmethod changed-p ((construct AssociationC) (revision integer)) @@ -263,7 +296,10 @@ (or (call-next-method) (some #'(lambda(role) (changed-p role revision)) - (roles construct :revision revision)))) + (roles construct :revision revision)) + (some #'(lambda(vc) + (end-revision-p vc revision)) + (slot-p construct 'roles)))) (defpclass FragmentC () 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 Sat Oct 2 05:20:25 2010 @@ -331,8 +331,9 @@ (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))))) + (is-true (changed-p norwegian-curriculum-assoc fixtures::revision3)) + (delete-name service-topic service-name :revision fixtures::revision3) + (is-true (changed-p service-topic fixtures::revision3))))) (test test-mark-as-deleted () Modified: branches/new-datamodel/src/xml/rdf/exporter.lisp ============================================================================== --- branches/new-datamodel/src/xml/rdf/exporter.lisp (original) +++ branches/new-datamodel/src/xml/rdf/exporter.lisp Sat Oct 2 05:20:25 2010 @@ -60,7 +60,7 @@ (defun init-*ns-map* () - "Initializes the variable *ns-map* woith some prefixes and corresponding + "Initializes the variable *ns-map* with some prefixes and corresponding namepsaces. So the predifend namespaces are not contain ed twice." (setf *ns-map* (list (list :prefix "isi"

1 0

[isidorus-cvs] r318 - in branches/new-datamodel/src: model unit_tests
by Lukas Giessmann 01 Oct '10

01 Oct '10

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+-+Metadata -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+-+Metada… + 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)))))))

1 0