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

[isidorus-cvs] r324 - branches/new-datamodel/src/unit_tests
by Lukas Giessmann 10 Oct '10

10 Oct '10

Author: lgiessmann Date: Sun Oct 10 04:40:18 2010 New Revision: 324 Log: new-datamodel: fixed a bug in the datamodel-unit-test for "get-item-by-psi" Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp Modified: branches/new-datamodel/src/unit_tests/datamodel_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/datamodel_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/datamodel_test.lisp Sun Oct 10 04:40:18 2010 @@ -598,27 +598,29 @@ (setf d:*TM-REVISION* rev-1) (is-false (get-item-by-id "any-psi-id")) (signals object-not-found-error - (get-item-by-locator "any-psi-id" :error-if-nil t :revision rev-0)) + (get-item-by-psi "any-psi-id" :error-if-nil t :revision rev-0)) (signals object-not-found-error - (get-item-by-locator "any-psi-id" :error-if-nil t :revision rev-0)) - (is-false (get-item-by-locator "any-psi-id")) + (get-item-by-psi "any-psi-id" :error-if-nil t :revision rev-0)) + (is-false (get-item-by-psi "any-psi-id")) (add-psi top-1 psi-3-1 :revision rev-1) (add-psi top-1 psi-3-2 :revision rev-1) + (is-false (get-item-by-locator "psi-3" :revision rev-1)) + (is-false (get-item-by-item-identifier "psi-3" :revision rev-1)) (signals duplicate-identifier-error - (get-item-by-locator "psi-3" :revision rev-1)) + (get-item-by-psi "psi-3" :revision rev-1)) (add-psi top-2 psi-1) (add-psi top-2 psi-2 :revision rev-2) - (is (eql top-2 (get-item-by-locator "psi-1" :revision rev-0))) - (is (eql top-2 (get-item-by-locator "psi-2" :revision rev-0))) - (is (eql top-2 (get-item-by-locator "psi-1" :revision 500))) - (is-false (get-item-by-locator "psi-2" :revision rev-1)) + (is (eql top-2 (get-item-by-psi "psi-1" :revision rev-0))) + (is (eql top-2 (get-item-by-psi "psi-2" :revision rev-0))) + (is (eql top-2 (get-item-by-psi "psi-1" :revision 500))) + (is-false (get-item-by-psi "psi-2" :revision rev-1)) (delete-psi top-2 psi-1 :revision rev-2) - (is-false (get-item-by-locator "psi-1" :revision rev-0)) - (is (eql top-2 (get-item-by-locator "psi-1" :revision rev-1))) + (is-false (get-item-by-psi "psi-1" :revision rev-0)) + (is (eql top-2 (get-item-by-psi "psi-1" :revision rev-1))) (add-psi top-3 psi-1 :revision rev-2) - (is (eql top-2 (get-item-by-locator "psi-1" :revision rev-1))) + (is (eql top-2 (get-item-by-psi "psi-1" :revision rev-1))) (d::add-to-version-history top-3 :start-revision rev-2) - (is (eql top-3 (get-item-by-locator "psi-1" :revision rev-0)))))) + (is (eql top-3 (get-item-by-psi "psi-1" :revision rev-0)))))) (test test-ReifiableConstructC ()

1 0

[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

[isidorus-cvs] r317 - in branches/new-datamodel/src: model unit_tests xml/xtm
by Lukas Giessmann 30 Sep '10

30 Sep '10

Author: lgiessmann Date: Thu Sep 30 06:44:59 2010 New Revision: 317 Log: new-datamodel: adapted the threading+importer unit-tests to the latest elephant+sbcl version; adapted the exporter-unit-tests to the new datamodel and sbcl+elephant version; fixed a bug when importing scopes of namevariants; adapted the reification uint-tests for the xtm-importer ot the latest elephant+sbcl version and the new-datamodel Modified: branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/unit_tests/exporter_xtm1.0_test.lisp branches/new-datamodel/src/unit_tests/reification_test.lisp branches/new-datamodel/src/xml/xtm/importer_xtm1.0.lisp branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Thu Sep 30 06:44:59 2010 @@ -4083,7 +4083,7 @@ (merge-all-constructs (append all-equivalent (list construct)) :revision revision)))))) (merge-changed-associations older-topic :revision revision)) - + (defun merge-changed-associations (older-topic &key (revision *TM-REVISION*)) "Merges all associations that became TMDM-equal since two referenced topics Modified: branches/new-datamodel/src/unit_tests/exporter_xtm1.0_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/exporter_xtm1.0_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/exporter_xtm1.0_test.lisp Thu Sep 30 06:44:59 2010 @@ -1002,8 +1002,7 @@ (xpath-child-elems-by-qname name *xtm1.0-ns* "variant"))) (is (= (length variant-nodes) 1)) (elt variant-nodes 0)))) - (check-variant-xtm1.0 document variant-node (list t50a-psi core-sort-psi) - t101-variant-name nil))))) + (check-variant-xtm1.0 document variant-node (list t50a-psi core-sort-psi) t101-variant-name nil))))) (check-single-instanceOf document topic t3a-psi :xtm-format '1.0) (loop for occurrence across (xpath-child-elems-by-qname topic *xtm1.0-ns* "occurrence") do (let ((instanceOf @@ -1131,7 +1130,7 @@ (let ((document (dom:document-element (cxml:parse-file *out-xtm1.0-file* (cxml-dom:make-dom-builder))))) - (check-document-structure document 9 1 :ns-uri *xtm1.0-ns*) + (check-document-structure document 6 0 :ns-uri *xtm1.0-ns*) (loop for topic across (xpath-child-elems-by-qname document *xtm1.0-ns* "topic") do (loop for subjectIndicatorRef across (xpath-child-elems-by-qname (xpath-single-child-elem-by-qname @@ -1144,12 +1143,6 @@ (check-topic-id topic)) ((string= href core-display-psi) (check-topic-id topic)) - ((string= href constants:*type-instance-psi*) - (check-topic-id topic)) - ((string= href constants:*type-psi*) - (check-topic-id topic)) - ((string= href constants:*instance-psi*) - (check-topic-id topic)) ((string= href t50a-psi) (check-topic-id topic)) ((string= href t3-psi) Modified: branches/new-datamodel/src/unit_tests/reification_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/reification_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/reification_test.lisp Thu Sep 30 06:44:59 2010 @@ -58,7 +58,7 @@ (test test-merge-reifier-topics - "Tests the function merge-reifier-topics." + "Tests the function merge-constructs." (let ((db-dir "data_base") (revision-1 100) (revision-2 200)) @@ -147,7 +147,7 @@ :start-revision revision-1))) (let ((name-1-1 (make-construct 'NameC :item-identifiers nil - :topic topic-1 + :parent topic-1 :themes (list scope-1) :instance-of name-type :charvalue "name-1-1" @@ -156,7 +156,7 @@ :item-identifiers (list (make-instance 'ItemIdentifierC :uri "name-2-1-ii-1" :start-revision revision-1)) - :topic topic-2 + :parent topic-2 :themes (list scope-2) :instance-of nil :charvalue "name-2-1" @@ -165,7 +165,7 @@ :item-identifiers (list (make-instance 'ItemIdentifierC :uri "occurrence-1-1-ii-1" :start-revision revision-1)) - :topic topic-2 + :parent topic-2 :themes (list scope-1 scope-2) :instance-of occurrence-type :charvalue "occurrence-2-1" @@ -173,7 +173,7 @@ :start-revision revision-2)) (occurrence-2-2 (make-construct 'OccurrenceC :item-identifiers nil - :topic topic-2 + :parent topic-2 :themes nil :instance-of occurrence-type :charvalue "occurrence-2-2" @@ -181,7 +181,7 @@ :start-revision revision-2)) (test-name (make-construct 'NameC :item-identifiers nil - :topic scope-2 + :parent scope-2 :themes (list scope-1 topic-2) :instance-of topic-2 :charvalue "test-name" @@ -194,19 +194,21 @@ (list (list :instance-of role-type :player topic-1 + :start-revision revision-2 :item-identifiers (list (make-instance 'ItemIdentifierC :uri "role-1" - :start-revision revision-1))) + :start-revision revision-2))) (list :instance-of role-type :player topic-2 + :start-revision revision-2 :item-identifiers (list (make-instance 'ItemIdentifierC :uri "role-2" - :start-revision revision-1)))) - :start-revision revision-1))) + :start-revision revision-2)))) + :start-revision revision-2))) (is (= (length (elephant:get-instances-by-class 'TopicC)) 8)) - (datamodel::merge-reifier-topics topic-1 topic-2) + (d::merge-constructs topic-1 topic-2 :revision revision-2) (is (= (length (elephant:get-instances-by-class 'TopicC)) 7)) (is (= (length (union (list ii-1-1 ii-1-2 ii-2-1 ii-2-2) (item-identifiers topic-1))) @@ -220,7 +222,7 @@ (is (= (length (union (names topic-1) (list name-1-1 name-2-1))) (length (list name-1-1 name-2-1)))) - (is (= (length (union (occurrences topic-1) + (is (= (length (union (occurrences topic-1 :revision 0) (list occurrence-2-1 occurrence-2-2))) (length (list occurrence-2-1 occurrence-2-2)))) (is (= (length (union (d:used-as-type topic-1) @@ -229,9 +231,9 @@ (is (= (length (union (d:used-as-theme topic-1) (list test-name))) (length (list test-name)))) - (is (eql (player (first (roles assoc))) topic-1)) - (is (eql (player (second (roles assoc))) topic-1)) - ;;TODO: check all objects and their version-infos + (is (= (length (roles assoc :revision 0)) 1)) + (is (= (length (d::slot-p assoc 'd::roles)) 2)) + (is (eql (player (first (roles assoc :revision 0)) :revision 0) topic-1)) (elephant:close-store)))))) @@ -282,21 +284,21 @@ (is-true reifier-married-assoc) (is-true reifier-husband-role) (is (eql (reifier homer-occurrence) reifier-occurrence)) - (is (eql (reified reifier-occurrence) homer-occurrence)) + (is (eql (reified-construct reifier-occurrence) homer-occurrence)) (is (eql (reifier homer-name) reifier-name)) - (is (eql (reified reifier-name) homer-name)) + (is (eql (reified-construct reifier-name) homer-name)) (is (eql (reifier homer-variant) reifier-variant)) - (is (eql (reified reifier-variant) homer-variant)) + (is (eql (reified-construct reifier-variant) homer-variant)) (is (eql (reifier married-assoc) reifier-married-assoc)) - (is (eql (reified reifier-married-assoc) married-assoc)) + (is (eql (reified-construct reifier-married-assoc) married-assoc)) (is (eql (reifier husband-role) reifier-husband-role)) - (is (eql (reified reifier-husband-role) husband-role)) + (is (eql (reified-construct reifier-husband-role) husband-role)) (is-true (handler-case (progn (d::delete-construct homer-occurrence) t) (condition () nil))) (is-false (occurrences homer)) - (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 11)) + (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 12)) (elephant:close-store)))))) @@ -346,21 +348,21 @@ (is-true reifier-married-assoc) (is-true reifier-husband-role) (is (eql (reifier homer-occurrence) reifier-occurrence)) - (is (eql (reified reifier-occurrence) homer-occurrence)) + (is (eql (reified-construct reifier-occurrence) homer-occurrence)) (is (eql (reifier homer-name) reifier-name)) - (is (eql (reified reifier-name) homer-name)) + (is (eql (reified-construct reifier-name) homer-name)) (is (eql (reifier homer-variant) reifier-variant)) - (is (eql (reified reifier-variant) homer-variant)) + (is (eql (reified-construct reifier-variant) homer-variant)) (is (eql (reifier married-assoc) reifier-married-assoc)) - (is (eql (reified reifier-married-assoc) married-assoc)) + (is (eql (reified-construct reifier-married-assoc) married-assoc)) (is (eql (reifier husband-role) reifier-husband-role)) - (is (eql (reified reifier-husband-role) husband-role)) + (is (eql (reified-construct reifier-husband-role) husband-role)) (is-true (handler-case (progn (d::delete-construct homer-occurrence) t) (condition () nil))) (is-false (occurrences homer)) - (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 11)) + (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 12)) (elephant:close-store)))))) @@ -621,9 +623,9 @@ "http://test/arcs/arc4")) (is (= (length (d:used-as-type arc1)) 1)) (is (eql (reifier (first (d:used-as-type arc1))) reification-1)) - (is (eql (reified reification-1) (first (d:used-as-type arc1)))) + (is (eql (reified-construct reification-1) (first (d:used-as-type arc1)))) (is (eql (reifier (first (d:used-as-type arc3))) reification-2)) - (is (eql (reified reification-2) (first (d:used-as-type arc3)))))))) + (is (eql (reified-construct reification-2) (first (d:used-as-type arc3)))))))) (elephant:close-store)) @@ -647,13 +649,13 @@ (is-true married) (is (= (length (used-as-type married)) 1)) (is-true (reifier (first (used-as-type married)))) - (is-true (reified (reifier (first (used-as-type married))))) + (is-true (reified-construct (reifier (first (used-as-type married))))) (is (= (length (psis (reifier (first (used-as-type married))))) 1)) (is (string= (uri (first (psis (reifier (first (used-as-type married)))))) "http://test-tm#married-arc")) (is (= (length (occurrences bart)) 1)) (is-true (reifier (first (occurrences bart)))) - (is-true (reified (reifier (first (occurrences bart))))) + (is-true (reified-construct (reifier (first (occurrences bart))))) (is (string= (uri (first (psis (reifier (first (occurrences bart)))))) "http://test-tm#lastName-arc")))) (elephant:close-store)) @@ -680,17 +682,17 @@ (is (= (length (variants name)) 1)) (let ((variant (first (variants name)))) (is-true (reifier name)) - (is-true (reified (reifier name))) + (is-true (reified-construct (reifier name))) (is (= (length (psis (reifier name))) 1)) (is (string= (uri (first (psis (reifier name)))) (concatenate 'string tm-id "lisa-name"))) (is-true (reifier variant)) - (is-true (reified (reifier variant))) + (is-true (reified-construct (reifier variant))) (is (= (length (psis (reifier variant))) 1)) (is (string= (uri (first (psis (reifier variant)))) (concatenate 'string tm-id "lisa-name-variant"))) (is-true (reifier occurrence)) - (is-true (reified (reifier occurrence))) + (is-true (reified-construct (reifier occurrence))) (is (= (length (psis (reifier occurrence))) 1)) (is (string= (uri (first (psis (reifier occurrence)))) (concatenate 'string tm-id "lisa-occurrence"))))))) @@ -717,7 +719,7 @@ (is (typep (first (used-as-type friendship)) 'd:AssociationC)) (let ((friendship-association (first (used-as-type friendship)))) (is-true (reifier friendship-association)) - (is-true (reified (reifier friendship-association))) + (is-true (reified-construct (reifier friendship-association))) (is (= (length (psis (reifier friendship-association))) 1)) (is (string= (uri (first (psis (reifier friendship-association)))) (concatenate 'string tm-id "friendship-association"))) @@ -728,7 +730,7 @@ (roles friendship-association)))) (is-true carl-role) (is-true (reifier carl-role)) - (is-true (reified (reifier carl-role))) + (is-true (reified-construct (reifier carl-role))) (is (= (length (psis (reifier carl-role))) 1)) (is (string= (uri (first (psis (reifier carl-role)))) (concatenate 'string tm-id "friend-role"))))))) Modified: branches/new-datamodel/src/xml/xtm/importer_xtm1.0.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/importer_xtm1.0.lisp (original) +++ branches/new-datamodel/src/xml/xtm/importer_xtm1.0.lisp Thu Sep 30 06:44:59 2010 @@ -75,7 +75,7 @@ (from-parameters-elem-xtm1.0 (xpath-single-child-elem-by-qname variant-elem *xtm1.0-ns* "parameters") start-revision :xtm-id xtm-id) - (themes parent-construct))))) + (themes parent-construct :revision start-revision))))) (variantName (from-resourceX-elem-xtm1.0 (xpath-single-child-elem-by-qname variant-elem *xtm1.0-ns* "variantName"))) (parent-name (cond Modified: branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp (original) +++ branches/new-datamodel/src/xml/xtm/importer_xtm2.0.lisp Thu Sep 30 06:44:59 2010 @@ -188,12 +188,11 @@ (themes (append (from-scope-elem (xpath-single-child-elem-by-qname variant-elem *xtm2.0-ns* "scope") start-revision :xtm-id xtm-id) - (themes name))) + (themes name :revision start-revision))) (variant-value (from-resourceX-elem variant-elem)) (reifier-topic (get-reifier-topic variant-elem start-revision))) (unless variant-value (error "VariantC: one of resourceRef and resourceData must be set")) - (make-construct 'VariantC :start-revision start-revision :item-identifiers item-identifiers

1 0

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

27 Sep '10

Author: lgiessmann Date: Mon Sep 27 16:26:49 2010 New Revision: 316 Log: new-datamodel: adapted the unit-test exporter-test:test-fragments-xtm1.0-versions to the new data model; fixed a bug when creating FragmentC objects-> topics referenced by variants of the main topic are also added as topic stubs Modified: branches/new-datamodel/src/model/changes.lisp branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/unit_tests/exporter_xtm1.0_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 Mon Sep 27 16:26:49 2010 @@ -72,6 +72,11 @@ (themes characteristic :revision revision) (when (instance-of characteristic :revision revision) (list (instance-of characteristic :revision revision))) + (when (and (typep characteristic 'NameC) + (variants characteristic :revision revision)) + (remove-if #'null + (loop for var in (variants characteristic :revision revision) + append (find-referenced-topics var :revision revision)))) (when (and (typep characteristic 'OccurrenceC) (> (length (charvalue characteristic)) 0) (eq #\# (elt (charvalue characteristic) 0))) Modified: branches/new-datamodel/src/model/datamodel.lisp ============================================================================== --- branches/new-datamodel/src/model/datamodel.lisp (original) +++ branches/new-datamodel/src/model/datamodel.lisp Mon Sep 27 16:26:49 2010 @@ -1140,15 +1140,16 @@ ((and current-version-info (= (end-revision current-version-info) 0)) (setf (end-revision current-version-info) start-revision) - (make-instance 'VersionInfoC - :start-revision start-revision - :end-revision end-revision - :versioned-construct construct)) + (let ((vi (make-instance 'VersionInfoC + :start-revision start-revision + :end-revision end-revision))) + (elephant:add-association vi 'versioned-construct construct))) (t - (make-instance 'VersionInfoC - :start-revision start-revision - :end-revision end-revision - :versioned-construct construct)))))))) + (let ((vi (make-instance 'VersionInfoC + :start-revision start-revision + :end-revision end-revision))) + (elephant:add-association vi 'versioned-construct construct))))))))) + (defmethod marked-as-deleted-p ((construct VersionedConstructC)) @@ -4222,7 +4223,7 @@ construct-1))) (move-referenced-constructs newer-tm older-tm :revision revision) (dolist (top-or-assoc (append (topics newer-tm) (associations newer-tm))) - (add-to-tm top-or-assoc top-or-assoc)) + (add-to-tm older-tm top-or-assoc)) (add-to-version-history older-tm :start-revision revision) (mark-as-deleted newer-tm :revision revision) (when (exist-in-version-history-p newer-tm) Modified: branches/new-datamodel/src/unit_tests/exporter_xtm1.0_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/exporter_xtm1.0_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/exporter_xtm1.0_test.lisp Mon Sep 27 16:26:49 2010 @@ -390,12 +390,10 @@ when (string= (uri item) psi) return (identified-construct item))) (t100-start-revision (d::start-revision (first (d::versions t100))))) - (d:get-fragments t100-start-revision) (let ((t100-fragment (loop for item in (elephant:get-instances-by-class 'FragmentC) when (eq (topic item) t100) return item))) - (with-open-file (stream *out-xtm1.0-file* :direction :output) (write-string (export-xtm-fragment t100-fragment :xtm-format '1.0) stream)))) @@ -443,7 +441,9 @@ (with-fixture merge-test-db () (handler-case (delete-file *out-xtm1.0-file*)(error () )) ;deletes file - if exist (export-xtm *out-xtm1.0-file* :revision fixtures::revision1 :xtm-format '1.0) - (let ((document (dom:document-element (cxml:parse-file *out-xtm1.0-file* (cxml-dom:make-dom-builder)))) + (let ((document + (dom:document-element + (cxml:parse-file *out-xtm1.0-file* (cxml-dom:make-dom-builder)))) (t100-occurrences-resourceData (list "The ISO 19115 standard ..." "2003-01-01"))) ;local value->no type (check-document-structure document 47 7 :ns-uri *xtm1.0-ns*) (loop for topic across (xpath-child-elems-by-qname document *xtm1.0-ns* "topic") @@ -1121,18 +1121,17 @@ (let ((new-t100 (loop for item in (elephant:get-instances-by-class 'd:PersistentIdC) when (string= (uri item) new-t100-psi) - return (identified-construct item)))) + return (identified-construct item :revision fixtures::revision3)))) (d:get-fragments fixtures::revision3) (let ((fragment (loop for item in (elephant:get-instances-by-class 'd:FragmentC) when (eq (topic item) new-t100) return item))) (with-open-file (stream *out-xtm1.0-file* :direction :output) (write-string (export-xtm-fragment fragment :xtm-format '1.0) stream)))) - (let ((document (dom:document-element (cxml:parse-file *out-xtm1.0-file* (cxml-dom:make-dom-builder))))) - (check-document-structure document 6 0 :ns-uri *xtm1.0-ns*) + (check-document-structure document 9 1 :ns-uri *xtm1.0-ns*) (loop for topic across (xpath-child-elems-by-qname document *xtm1.0-ns* "topic") do (loop for subjectIndicatorRef across (xpath-child-elems-by-qname (xpath-single-child-elem-by-qname @@ -1145,6 +1144,12 @@ (check-topic-id topic)) ((string= href core-display-psi) (check-topic-id topic)) + ((string= href constants:*type-instance-psi*) + (check-topic-id topic)) + ((string= href constants:*type-psi*) + (check-topic-id topic)) + ((string= href constants:*instance-psi*) + (check-topic-id topic)) ((string= href t50a-psi) (check-topic-id topic)) ((string= href t3-psi) @@ -1154,28 +1159,35 @@ ((string= href new-t100-psi) (check-topic-id topic) (check-single-instanceOf document topic t3-psi :xtm-format '1.0) - (loop for occurrence across (xpath-child-elems-by-qname topic *xtm1.0-ns* "occurrence") + (loop for occurrence across (xpath-child-elems-by-qname + topic *xtm1.0-ns* "occurrence") do (let ((resourceRef (let ((resourceRef-nodes - (xpath-child-elems-by-qname occurrence *xtm1.0-ns* "resourceRef"))) + (xpath-child-elems-by-qname + occurrence *xtm1.0-ns* "resourceRef"))) (is (= (length resourceRef-nodes) 1)) - (dom:get-attribute-ns (elt resourceRef-nodes 0) *xtm1.0-xlink* "href"))) + (dom:get-attribute-ns (elt resourceRef-nodes 0) + *xtm1.0-xlink* "href"))) (instanceOf (let ((instanceOf-nodes - (xpath-child-elems-by-qname occurrence *xtm1.0-ns* "instanceOf"))) + (xpath-child-elems-by-qname + occurrence *xtm1.0-ns* "instanceOf"))) (is (= (length instanceOf-nodes) 1)) (let ((topicRef-nodes (xpath-child-elems-by-qname - (elt instanceOf-nodes 0) *xtm1.0-ns* "topicRef"))) + (elt instanceOf-nodes 0) *xtm1.0-ns* + "topicRef"))) (is (= (length topicRef-nodes) 1)) (get-subjectIndicatorRef-by-ref document (dom:get-attribute-ns (elt topicRef-nodes 0) *xtm1.0-xlink* "href")))))) (cond - ((string= resourceRef (first new-t100-occurrence-resourceRef-merge-2)) + ((string= resourceRef + (first new-t100-occurrence-resourceRef-merge-2)) (is (string= instanceOf t55-psi))) - ((string= resourceRef (second new-t100-occurrence-resourceRef-merge-2)) + ((string= resourceRef + (second new-t100-occurrence-resourceRef-merge-2)) (is (string= instanceOf t55-psi))) (t (is-true

1 0

[isidorus-cvs] r315 - in branches/new-datamodel: playground src/ajax/javascripts src/rest_interface src/unit_tests
by Lukas Giessmann 07 Sep '10

07 Sep '10

Author: lgiessmann Date: Tue Sep 7 06:50:53 2010 New Revision: 315 Log: The ajax host prefix in constants.js is set automatically --> different mappings works for the same server now; the admin needn't set the host prefix manually Added: branches/new-datamodel/playground/url_test.html branches/new-datamodel/playground/url_test.js Modified: branches/new-datamodel/src/ajax/javascripts/constants.js branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp branches/new-datamodel/src/unit_tests/atom_test.lisp Added: branches/new-datamodel/playground/url_test.html ============================================================================== --- (empty file) +++ branches/new-datamodel/playground/url_test.html Tue Sep 7 06:50:53 2010 @@ -0,0 +1,48 @@ + + + + + + + + + + + + +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml"> + <head> + <title>isidorus</title> + <meta http-equiv="Content-Type" content="text/html; charset=utf-8"/> + +  + <script language="JavaScript" type="text/javascript">  + </script> + + +  + +  + <script language="JavaScript" type="text/javascript" src="url_test.js"></script> + </head> + + <body onload="entryPoint()"> + <div id="page"> + <h1>URL:<span id="content"></span></h1> + </div> + </body> +</html> Added: branches/new-datamodel/playground/url_test.js ============================================================================== --- (empty file) +++ branches/new-datamodel/playground/url_test.js Tue Sep 7 06:50:53 2010 @@ -0,0 +1,16 @@ +function entryPoint(){ + var elem = getElem(); + var url = window.location.href; + var urlFrags = url.split("/"); + var newUrl = ""; + for(var i = 0; i !== urlFrags.length; ++i){ + if (newUrl.length !== 0) newUrl += "/"; + newUrl += urlFrags[i]; + } + elem.innerHTML = " " + newUrl; +} + + +function getElem(){ + return document.getElementById("content"); +} \ No newline at end of file Modified: branches/new-datamodel/src/ajax/javascripts/constants.js ============================================================================== --- branches/new-datamodel/src/ajax/javascripts/constants.js (original) +++ branches/new-datamodel/src/ajax/javascripts/constants.js Tue Sep 7 06:50:53 2010 @@ -11,7 +11,7 @@ // --- Some constants fot the http connections via the XMLHttpRequest-Object -var HOST_PREF = "http://localhost:8000/"; // of the form "http://(.+)/" +var HOST_PREF = getHostPref(); var GET_PREFIX = HOST_PREF + "json/get/"; var GET_STUB_PREFIX = HOST_PREF + "json/topicstubs/"; var TMCL_TYPE_URL = HOST_PREF + "json/tmcl/type/"; @@ -90,4 +90,20 @@ "instances" : function(){ return "instances"; }, "subtypes" : function(){ return "subtypes"; }, "topicPsis" : function(){ return "topicPsis"; } - }; \ No newline at end of file + }; + + +// --- returns the current host prefix as string, so the user/admin needn't +// --- setting it manually +function getHostPref(){ + var splitter = "/"; + var splitterRate = 3; + var fullUrl = window.location.href; + var urlFragments = fullUrl.split("/"); + var hostPref = ""; + for(var i = 0; i !== splitterRate; ++i){ + hostPref += urlFragments[i]; + hostPref += "/"; + } + return hostPref; +} \ No newline at end of file Modified: branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp ============================================================================== --- branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp (original) +++ branches/new-datamodel/src/rest_interface/set-up-json-interface.lisp Tue Sep 7 06:50:53 2010 @@ -133,6 +133,7 @@ (setf (hunchentoot:content-type*) "text") (format nil "Condition: \"~a\"" err))))) + (defun return-all-tmcl-instances(&optional param) "Returns all topic-psis that are valid instances of any topic type. The validity is only oriented on the typing of topics, e.g. Modified: branches/new-datamodel/src/unit_tests/atom_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/atom_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/atom_test.lisp Tue Sep 7 06:50:53 2010 @@ -103,9 +103,13 @@ (find 'atom::snapshots-feed (atom:subfeeds worms-feed) :key #'type-of))) + + (format t "~a~%~%~a~%" fragments-feed (map 'list #'atom::psi (atom:entries fragments-feed))) (is (= 11 (length (atom:entries fragments-feed)))) - (is (string= "http://london.ztt.fh-worms.de:8000/feeds/worms/fragments" (link fragments-feed))) - (is (string= "http://london.ztt.fh-worms.de:8000/feeds/worms/snapshots" (link snapshots-feed))) + (is (string= "http://london.ztt.fh-worms.de:8000/feeds/worms/fragments" + (link fragments-feed))) + (is (string= "http://london.ztt.fh-worms.de:8000/feeds/worms/snapshots" + (link snapshots-feed))) (format t "~a" (cxml:with-xml-output (cxml:make-string-sink :canonical t)

1 0