Author: lgiessmann Date: Sun Jun 13 10:42:34 2010 New Revision: 298 Log: new-datamodel: adpted all unit-test for the xtm-importer (xtm2.0); fixed two bug in make-pointerc; fixed a bug when importing topics, names, occurrences, variants and tm-identifiers; fixed a bug in add-to-tm; fixed a bug when mergin was caused by an item-identifier Modified: branches/new-datamodel/src/model/datamodel.lisp branches/new-datamodel/src/unit_tests/fixtures.lisp branches/new-datamodel/src/unit_tests/importer_test.lisp branches/new-datamodel/src/xml/xtm/importer.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 Sun Jun 13 10:42:34 2010 @@ -160,7 +160,6 @@ (in-package :datamodel) -;;TODO: adapt changes.lisp --> changed-p ;;TODO: implement a macro with-merge-constructs, that merges constructs ;; after all operations in the body were called @@ -1586,8 +1585,9 @@ (= essentially the OID). If xtm-id is explicitly given, returns one of the topic-ids in that TM (which must then exist).") - (:method ((construct TopicC) &optional (xtm-id nil) (revision *TM-REVISION*)) - (declare (type (or null string) xtm-id) (integer revision)) + (:method ((construct TopicC) &optional (revision *TM-REVISION*) (xtm-id nil)) + (declare (type (or string null) xtm-id) + (type (or integer null) revision)) (if xtm-id (let ((possible-identifiers (remove-if-not @@ -3127,6 +3127,12 @@ :revision revision))) (when (not (eql id-owner construct)) id-owner)))) + (when (and construct-to-be-merged + (not (eql (type-of construct-to-be-merged) + (type-of construct)))) + (error (make-not-mergable-condition (format nil "From add-item-identifier(): ~a and ~a can't be merged since the identified-constructs are not of the same type" + construct construct-to-be-merged) + construct construct-to-be-merged))) (let ((merged-construct construct)) (cond (construct-to-be-merged (setf merged-construct @@ -3485,11 +3491,13 @@ (defmethod add-to-tm ((construct TopicMapC) (construct-to-add TopicC)) - (add-association construct 'topics construct-to-add)) + (add-association construct 'topics construct-to-add) + construct-to-add) (defmethod add-to-tm ((construct TopicMapC) (construct-to-add AssociationC)) - (add-association construct 'associations construct-to-add)) + (add-association construct 'associations construct-to-add) + construct-to-add) (defmethod delete-from-tm ((construct TopicMapC) (construct-to-delete TopicC)) @@ -3806,11 +3814,12 @@ #'null (map 'list #'(lambda(existing-pointer) - (when (equivalent-construct existing-pointer uri - xtm-id) + (when (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 existing-pointer + (if existing-pointer + (first existing-pointer) (make-instance class-symbol :uri uri :xtm-id xtm-id))))) (when identified-construct (cond ((TopicIdentificationC-p class-symbol) 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 Sun Jun 13 10:42:34 2010 @@ -94,14 +94,14 @@ (tear-down-test-db)) (def-fixture initialized-test-db (&optional (xtm *NOTIFICATIONBASE-TM*)) - (let - ((revision (get-revision))) + (let ((revision (get-revision))) (declare (ignorable revision)) + (setf *TM-REVISION* revision) (setf *XTM-TM* xtm) (set-up-test-db revision) - (let - ((tm - (get-item-by-item-identifier "http://www.isidor.us/unittests/testtm" :revision (d:get-revision)))) + (let ((tm + (get-item-by-item-identifier "http://www.isidor.us/unittests/testtm" + :revision revision))) (declare (ignorable tm)) (&body) (tear-down-test-db)))) 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 Sun Jun 13 10:42:34 2010 @@ -22,7 +22,8 @@ xpath-select-location-path) (:import-from :exceptions missing-reference-error - duplicate-identifier-error) + duplicate-identifier-error + not-mergable-error ) (:export :importer-test :test-error-detection :run-importer-tests @@ -57,19 +58,19 @@ "Test the from-type-elem function of the importer" (with-fixture initialized-test-db() - (let - ((type-elems - (xpath-select-location-path - *XTM-TM* - '((*xtm2.0-ns* "topic") - (*xtm2.0-ns* "occurrence") - (*xtm2.0-ns* "type"))))) + (let ((type-elems + (xpath-select-location-path + *XTM-TM* + '((*xtm2.0-ns* "topic") + (*xtm2.0-ns* "occurrence") + (*xtm2.0-ns* "type")))) + (rev-1 *TM-REVISION*)) (loop for type-elem in type-elems do - (is (typep (from-type-elem type-elem) 'TopicC))) - (is-false (from-type-elem nil)) + (is (typep (from-type-elem type-elem rev-1) 'TopicC))) + (is-false (from-type-elem nil rev-1)) (let ((t100-occtype - (from-type-elem (first type-elems)))) + (from-type-elem (first type-elems) rev-1))) (format t "occtype: ~a~&" t100-occtype) (format t "occtype: ~a~&" (psis t100-occtype)) (is @@ -82,19 +83,19 @@ (declare (optimize (debug 3))) (with-fixture initialized-test-db() - (let - ((scope-elems - (xpath-select-location-path - *XTM-TM* - '((*xtm2.0-ns* "topic") - (*xtm2.0-ns* "name") - (*xtm2.0-ns* "scope"))))) + (let ((scope-elems + (xpath-select-location-path + *XTM-TM* + '((*xtm2.0-ns* "topic") + (*xtm2.0-ns* "name") + (*xtm2.0-ns* "scope")))) + (rev-1 *TM-REVISION*)) (loop for scope-elem in scope-elems do - (is (>= (length (from-scope-elem scope-elem)) 1))) - (is-false (from-scope-elem nil)) + (is (>= (length (from-scope-elem scope-elem rev-1)) 1))) + (is-false (from-scope-elem nil rev-1)) (let ((t101-themes - (from-scope-elem (first scope-elems)))) + (from-scope-elem (first scope-elems) rev-1))) (is (= 1 (length t101-themes))) (is (string= @@ -105,54 +106,51 @@ "Test the from-name-elem function of the importer" (with-fixture initialized-test-db() - (let - ((name-elems - (xpath-select-location-path - *XTM-TM* - '((*xtm2.0-ns* "topic") - (*xtm2.0-ns* "name")))) - (top (get-item-by-id "t1"))) ;an arbitrary topic + (let ((name-elems + (xpath-select-location-path + *XTM-TM* + '((*xtm2.0-ns* "topic") + (*xtm2.0-ns* "name")))) + (top (get-item-by-id "t1")) ;an arbitrary topic + (rev-1 *TM-REVISION*)) (loop for name-elem in name-elems do - (is (typep (from-name-elem name-elem top revision) 'NameC))) + (is (typep (from-name-elem name-elem top rev-1) 'NameC))) (let - ((t1-name (from-name-elem (first name-elems) top revision)) - (t1-name-copy (from-name-elem (first name-elems) top revision)) - (t101-longname (from-name-elem (nth 27 name-elems) top revision))) + ((t1-name (from-name-elem (first name-elems) top rev-1)) + (t1-name-copy (from-name-elem (first name-elems) top rev-1)) + (t101-longname (from-name-elem (nth 27 name-elems) top rev-1))) (is (string= (charvalue t1-name) "Topic Type")) - (is (string= - (charvalue t101-longname) - "ISO/IEC 13250:2002: Topic Maps")) - (is (= 1 (length (item-identifiers t101-longname)))) - - (is (string= - (uri (first (psis (instance-of t101-longname)))) - "http://psi.egovpt.org/types/long-name")) - (is (themes t101-longname)) + (is (string= (charvalue t101-longname) + "ISO/IEC 13250:2002: Topic Maps")) + (is (= 1 (length (item-identifiers t101-longname :revision rev-1)))) + (is (string= (uri (first (psis (instance-of t101-longname)))) + "http://psi.egovpt.org/types/long-name")) + (is (themes t101-longname :revision rev-1)) (is (string= - (topic-id (first (themes t101-longname)) *TEST-TM*) + (topic-id (first (themes t101-longname :revision rev-1)) + rev-1 *TEST-TM*) "t50a")) - (is (eq t1-name t1-name-copy)) ;must be merged - )))) + (is (eq t1-name t1-name-copy)))))) ;must be merged + (test test-from-occurrence-elem "Test the form-occurrence-elem function of the importer" (with-fixture initialized-test-db() - (let - ((occ-elems - (xpath-select-location-path - *XTM-TM* - '((*xtm2.0-ns* "topic") - (*xtm2.0-ns* "occurrence")))) - (top (get-item-by-id "t1"))) ;an abritrary topic - + (let ((occ-elems + (xpath-select-location-path + *XTM-TM* + '((*xtm2.0-ns* "topic") + (*xtm2.0-ns* "occurrence")))) + (top (get-item-by-id "t1")) ;an abritrary topic + (rev-1 *TM-REVISION*)) (loop for occ-elem in occ-elems do - (is (typep (from-occurrence-elem occ-elem top revision) - 'OccurrenceC))) + (is (typep (from-occurrence-elem occ-elem top rev-1) + 'OccurrenceC))) (is (= 1 (length (elephant:get-instances-by-value - 'ItemIdentifierC - 'uri - "http://psi.egovpt.org/itemIdentifiers#t100_o1")))) + 'ItemIdentifierC + 'uri + "http://psi.egovpt.org/itemIdentifiers#t100_o1")))) (let ((t100-occ1 (identified-construct @@ -166,9 +164,9 @@ 'ItemIdentifierC 'uri "http://psi.egovpt.org/itemIdentifiers#t100_o2")))) - (is (= 1 (length (item-identifiers t100-occ1))));just to double-check + (is (= 1 (length (item-identifiers t100-occ1 :revision rev-1)))) ;just to double-check (is (string= - (uri (first (item-identifiers t100-occ1))) + (uri (first (item-identifiers t100-occ1 :revision rev-1))) "http://psi.egovpt.org/itemIdentifiers#t100_o1")) (is (string= (charvalue t100-occ1) "http://www.budabe.de/")) (is (string= (datatype t100-occ1) "http://www.w3.org/2001/XMLSchema#anyURI")) @@ -179,40 +177,39 @@ "Test the merge-topic-elem function of the importer" (with-fixture initialized-test-db() - (let - ((topic-elems - (xpath-select-location-path - *XTM-TM* - '((*xtm2.0-ns* "topic"))))) - + (let ((topic-elems + (xpath-select-location-path + *XTM-TM* + '((*xtm2.0-ns* "topic")))) + (rev-1 *TM-REVISION*)) (loop for topic-elem in topic-elems do (is (typep - (merge-topic-elem topic-elem revision :tm fixtures::tm) + (merge-topic-elem topic-elem rev-1 :tm fixtures::tm) 'TopicC))) (let ((top-t1 (merge-topic-elem (first topic-elems) - revision :tm fixtures::tm)) + rev-1 :tm fixtures::tm)) (top-t57 (get-item-by-id "t57")) (top-t101 (get-item-by-id "t101")) (top-t301 (get-item-by-id "t301")) (top-t301a (get-item-by-id "t301a")) ;one of the core PSIs (top-sup-sub (get-item-by-id "supertype-subtype" :xtm-id "core.xtm"))) - (is (= (internal-id top-t301) - (internal-id top-t301a))) - (is (= (length (occurrences top-t1)) 0)) - (is (= (length (occurrences top-t101)) 4)) - (is (= (length (names top-t57)) 1)) - (is (string= (uri (first (item-identifiers top-t57))) + (is (= (elephant::oid top-t301) (elephant::oid top-t301a))) + (is-true top-t301a) + (is (= (length (occurrences top-t1 :revision rev-1)) 0)) + (is (= (length (occurrences top-t101 :revision rev-1)) 4)) + (is (= (length (names top-t57 :revision rev-1)) 1)) + (is (string= (uri (first (item-identifiers top-t57 :revision rev-1))) "http://psi.egovpt.org/itemIdentifiers#t57")) - (is (= 2 (length (names top-t101)))) - (is (= 2 (length (names top-t301)))) ;after merge - (is-true (item-identifiers (first (names top-t301)))) ;after merge - (is (= 2 (length (psis top-t301)))) ;after merge - (is (= 3 (length (occurrences top-t301)))) ;after merge + (is (= 2 (length (names top-t101 :revision rev-1)))) + (is (= 2 (length (names top-t301 :revision rev-1)))) ;after merge + (is-true (item-identifiers (first (names top-t301 :revision rev-1)) + :revision rev-1)) ;after merge + (is (= 2 (length (psis top-t301 :revision rev-1)))) ;after merge + (is (= 3 (length (occurrences top-t301 :revision rev-1)))) ;after merge (is (string= "http://www.topicmaps.org/xtm/1.0/core.xtm#supertype-subtype" - (uri (first (psis top-sup-sub))))))) - + (uri (first (psis top-sup-sub :revision rev-1))))))) ;34 topics in 35 topic elements in notificationbase.xtm and 13 ;core topics (is (= (+ 34 13) (length (elephant:get-instances-by-class 'TopicC)))))) @@ -226,7 +223,8 @@ (xpath-select-location-path *XTM-TM* '((*xtm2.0-ns* "association") - (*xtm2.0-ns* "role"))))) + (*xtm2.0-ns* "role")))) + (rev-1 *TM-REVISION*)) (loop for role-elem in role-elems do (is (typep (from-role-elem role-elem revision) 'list))) (let @@ -234,43 +232,40 @@ (from-role-elem (nth 11 role-elems) revision))) (is (string= "t101" (topic-id - (getf 12th-role :player) *TEST-TM*))) + (getf 12th-role :player) rev-1 *TEST-TM*))) (is (string= "t62" (topic-id - (getf 12th-role :instance-of) *TEST-TM*))))))) + (getf 12th-role :instance-of) rev-1 *TEST-TM*))))))) + (test test-from-association-elem "Test the form-association-elem function of the importer" (with-fixture initialized-test-db() - (let - ((assoc-elems - (xpath-select-location-path - *XTM-TM* - '((*xtm2.0-ns* "association"))))) + (let ((assoc-elems + (xpath-select-location-path + *XTM-TM* + '((*xtm2.0-ns* "association")))) + (rev-1 *TM-REVISION*)) (loop for assoc-elem in assoc-elems do (is - (typep (from-association-elem assoc-elem revision :tm fixtures::tm) + (typep (from-association-elem assoc-elem rev-1 :tm fixtures::tm) 'AssociationC))) - ;(trace datamodel:item-identifiers datamodel::filter-slot-value-by-revision) - (let - ((6th-assoc - (sixth (elephant:get-instances-by-class 'AssociationC))) - (last-assoc - (seventh (elephant:get-instances-by-class 'AssociationC)))) - (is (= 2 (length (roles last-assoc)))) - (is (= 1 (length (item-identifiers last-assoc)))) + (let ((6th-assoc + (sixth (elephant:get-instances-by-class 'AssociationC))) + (last-assoc + (seventh (elephant:get-instances-by-class 'AssociationC)))) + (is (= 2 (length (roles last-assoc :revision rev-1)))) + (is (= 1 (length (item-identifiers last-assoc :revision rev-1)))) (is (string= "t300" - (topic-id (player (first (roles 6th-assoc))) *TEST-TM*))) + (topic-id (player (first (roles 6th-assoc :revision rev-1)) + :revision rev-1) rev-1 *TEST-TM*))) (is (string= "t63" - (topic-id (instance-of (first (roles 6th-assoc))) - *TEST-TM*))) + (topic-id (instance-of (first (roles 6th-assoc :revision rev-1)) + :revision rev-1) rev-1 *TEST-TM*))) (is (string= "t301" - (topic-id (player (first (roles last-assoc))) - *TEST-TM*)))) - ;(untrace datamodel:item-identifiers datamodel::filter-slot-value-by-revision)) - ) - ;(map 'list (lambda (a) (format t "~a" (exporter:to-string a))) (elephant:get-instances-by-class 'AssociationC)) + (topic-id (player (first (roles last-assoc :revision rev-1)) + :revision rev-1) rev-1 *TEST-TM*))))) (is (= 7 (length (elephant:get-instances-by-class 'AssociationC)))))) @@ -280,60 +275,56 @@ (declare (optimize (debug 3))) (with-fixture initialized-test-db() - (let - ((topic-elems - (xpath-select-location-path - *XTM-TM* - '((*xtm2.0-ns* "topic"))))) + (let ((topic-elems + (xpath-select-location-path + *XTM-TM* + '((*xtm2.0-ns* "topic")))) + (rev-1 *TM-REVISION*)) (loop for topic-elem in topic-elems do - (let - ( - ;this already implicitly creates the instanceOf - ;associations as needed - (topic (merge-topic-elem topic-elem revision :tm fixtures::tm))) - ;(format t "instanceof-topicrefs: ~a~&" instanceof-topicrefs) - (dolist (io-role - (elephant:get-instances-by-value - 'RoleC - 'player topic)) - (let - ((io-assoc (parent io-role))) - ;(format t "(io-topicref: ~a, topic: ~a)~&" io-topicref topic) - (is - (typep io-assoc - 'AssociationC)) - (is (string= (topic-id topic) - (topic-id (player (second (roles io-assoc)))))))))) - - (let* - ((t101-top (get-item-by-id "t101")) + (let (;this already implicitly creates the instanceOf + ;associations as needed + (topic (merge-topic-elem topic-elem rev-1 :tm fixtures::tm))) + (dolist (io-role (map 'list #'d::parent-construct + (d::slot-p topic 'd::player-in-roles))) + (let ((io-assoc (parent io-role :revision rev-1))) + (is (typep io-assoc 'AssociationC)) + (is (string= (topic-id topic rev-1) + (topic-id (player (second + (roles io-assoc :revision rev-1)) + :revision rev-1) rev-1))))))) + (let* ((t101-top (get-item-by-id "t101" :revision rev-1)) ;get all the roles t101 is involved in - (roles-101 (elephant:get-instances-by-value 'RoleC 'player t101-top)) + (roles-101 (map 'list #'d::parent-construct + (d::slot-p t101-top 'd::player-in-roles))) ;and filter those whose roletype is "instance" ;(returning, of course, a list) - ;TODO: what we'd really need ;is a filter that works ;directly on the indices ;rather than instantiating ;many unnecessary role objects - (role-101 (remove-if-not - (lambda (role) - (string= (uri (first (psis (instance-of role)))) - "http://psi.topicmaps.org/iso13250/model/instance")) roles-101))) + (role-101 (remove-if-not + (lambda (role) + (string= (uri (first (psis + (instance-of role :revision rev-1) + :revision rev-1))) + "http://psi.topicmaps.org/iso13250/model/instance")) + roles-101))) ;Topic t101 (= Topic Maps 2002 ;standard) is subclass of ;topic t3a (semantic standard) - (is-true t101-top) (is (= 1 (length role-101))) - ;(is (= 1 (length (d::versions role-101)))) (is (string= "t3a" - (topic-id (player (first (roles (parent (first role-101))))) *TEST-TM*))) + (topic-id (player (first (roles (parent (first role-101)) + :revision rev-1)) + :revision rev-1) + rev-1 *TEST-TM*))) (is (string= "type-instance" (topic-id (instance-of - (parent (first role-101))) "core.xtm"))) - )))) + (parent (first role-101) :revision rev-1)) + rev-1 "core.xtm"))))))) + (test test-error-detection "Test for the detection of common errors such as dangling @@ -356,7 +347,7 @@ (importer xtm-dom :xtm-id "missing-reference-error-2" :tm-id "http://www.isidor.us/unittests/baretests")))) (with-fixture bare-test-db() - (signals duplicate-identifier-error + (signals not-mergable-error (let ((xtm-dom (dom:document-element @@ -373,45 +364,50 @@ (xml-importer:setup-repository *t100.xtm* dir :xtm-id *TEST-TM* :tm-id "http://www.isidor.us/unittests/topic-t100") (elephant:open-store (xml-importer:get-store-spec dir)) - (is (= 25 (length (elephant:get-instances-by-class 'TopicC)))) ;; are all topics in the db +std topics - (is-true (get-item-by-id "t100")) ;; main topic - (is-true (get-item-by-id "t3a")) ;; instanceOf - (is-true (get-item-by-id "t50a")) ;; scope - (is-true (get-item-by-id "t51")) ;; occurrence/type - (is-true (get-item-by-id "t52")) ;; occurrence/resourceRef - (is-true (get-item-by-id "t53")) ;; occurrence/type - (is-true (get-item-by-id "t54")) ;; occurrence/type - (is-true (get-item-by-id "t55")) ;; occurrence/type - (let ((t100 (get-item-by-id "t100"))) + (is-true (get-item-by-id "t100" :revision 0)) ;; main topic + (is-true (get-item-by-id "t3a" :revision 0)) ;; instanceOf + (is-true (get-item-by-id "t50a" :revision 0)) ;; scope + (is-true (get-item-by-id "t51" :revision 0)) ;; occurrence/type + (is-true (get-item-by-id "t52" :revision 0)) ;; occurrence/resourceRef + (is-true (get-item-by-id "t53" :revision 0)) ;; occurrence/type + (is-true (get-item-by-id "t54" :revision 0)) ;; occurrence/type + (is-true (get-item-by-id "t55" :revision 0)) ;; occurrence/type + (let ((t100 (get-item-by-id "t100" :revision 0))) ;; checks instanceOf - (is (= 1 (length (player-in-roles t100)))) - (let* - ((role-t100 (first (player-in-roles t100))) - (assoc (parent role-t100)) - (role-t3a (first (roles assoc)))) - (is (= 1 (length (psis (instance-of role-t100))))) - (is (string= (uri (first (psis (instance-of role-t100)))) "http://psi.topicmaps.org/iso13250/model/instance")) - (is (= 1 (length (psis (instance-of role-t3a))))) - (is (string= (uri (first (psis (instance-of role-t3a)))) "http://psi.topicmaps.org/iso13250/model/type"))) - + (is (= 1 (length (player-in-roles t100 :revision 0)))) + (let* ((role-t100 (first (player-in-roles t100 :revision 0))) + (assoc (parent role-t100 :revision 0)) + (role-t3a (first (roles assoc :revision 0)))) + (is (= 1 (length (psis (instance-of role-t100 :revision 0) :revision 0)))) + (is (string= (uri (first (psis (instance-of role-t100 :revision 0) + :revision 0))) + "http://psi.topicmaps.org/iso13250/model/instance")) + (is (= 1 (length (psis (instance-of role-t3a :revision 0) :revision 0)))) + (is (string= (uri (first (psis (instance-of role-t3a :revision 0) + :revision 0))) + "http://psi.topicmaps.org/iso13250/model/type"))) ;; checks subjectIdentifier - (is (= 1 (length (psis t100)))) + (is (= 1 (length (psis t100 :revision 0)))) (is (string= "http://psi.egovpt.org/standard/ISO+19115%3A+Geographic+Information+-+Metadat..." - (uri (first (psis t100))))) - (is (equal (identified-construct (first (psis t100))) t100)) ;;other association part - + (uri (first (psis t100 :revision 0))))) + (is (equal (identified-construct (first (psis t100 :revision 0)) + :revision 0) t100)) ;;other association part ;; checks names - (is (= 2 (length (names t100)))) - (loop for item in (names t100) + (is (= 2 (length (names t100 :revision 0)))) + (loop for item in (names t100 :revision 0) do (is (or (string= (charvalue item) "ISO 19115") (and (string= (charvalue item) "ISO 19115:2003 Geographic Information - Metadata") - (= (length (themes item)) 1) - (= (length (psis (first (themes item))))) - (string= (uri (first (psis (first (themes item))))) "http://psi.egovpt.org/types/long-name"))))) - (is-true (used-as-theme (get-item-by-id "t50a"))) ;checks the other part of the association -> fails - + (= (length (themes item :revision 0)) 1) + (= (length (psis (first (themes item :revision 0)) + :revision 0))) + (string= (uri (first (psis (first (themes item :revision 0)) + :revision 0))) + "http://psi.egovpt.org/types/long-name"))))) + (is-true (used-as-theme (get-item-by-id "t50a" :revision 0) + :revision 0)) ;checks the other part of the association -> fails ;; checks occurrences + (setf *TM-REVISION* 0) (is (= 4 (length (occurrences (get-item-by-id "t100"))))) (loop for item in (occurrences t100) ;;(elephant:associatedp (get-item-by-id "t51") 'datamodel::used-as-type item) @@ -433,12 +429,7 @@ when (elephant:associatedp (get-item-by-id "t55") 'datamodel::used-as-type item) do (progn (is (string= (charvalue item) "http://www.editeur.org/standards/ISO19115.pdf")) - (is (string= (uri (first (psis (instance-of item)))) "http://psi.egovpt.org/types/links"))) - when (and (not (elephant:associatedp (get-item-by-id "t51") 'datamodel::used-as-type item)) - (not (elephant:associatedp (get-item-by-id "t53") 'datamodel::used-as-type item)) - (not (elephant:associatedp (get-item-by-id "t54") 'datamodel::used-as-type item)) - (not (elephant:associatedp (get-item-by-id "t55") 'datamodel::used-as-type item))) - do (is-true nil)))))) + (is (string= (uri (first (psis (instance-of item)))) "http://psi.egovpt.org/types/links")))))))) (test test-setup-repository-xtm1.0 @@ -450,7 +441,7 @@ *sample_objects.xtm* dir :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)) (is (= 36 (length (elephant:get-instances-by-class 'TopicC)))) ;13 + (23 core topics) (is (= 13 (length (elephant:get-instances-by-class 'AssociationC)))) ;2 + (11 instanceOf) @@ -507,14 +498,13 @@ do (is-true (format t "bad role found in association: ~A" (topic-identifiers (player role))))))))) - (test test-variants (let ((dir "data_base")) (with-fixture initialize-destination-db (dir) (xml-importer:setup-repository *notificationbase.xtm* dir :xtm-id *TEST-TM*) - + (setf *TM-REVISION* 0) (elephant:open-store (xml-importer:get-store-spec dir)) (let ((variants (elephant:get-instances-by-class 'VariantC))) (is (= (length variants) 4)) @@ -523,7 +513,7 @@ (d-type (datatype variant)) (string-type "http://www.w3.org/2001/XMLSchema#string") (itemIdentities (map 'list #'uri (item-identifiers variant))) - (parent-name-value (charvalue (name variant))) + (parent-name-value (charvalue (parent variant))) (scopes (map 'list #'uri (map 'list #'(lambda(x) (first (psis x))) ;these topics have only one psi @@ -534,8 +524,8 @@ (cond ((string= resourceData "Long-Version") (is (string= parent-name-value "long version of a name")) - (is (= (length (variants (name variant))) 1)) - (is (eql variant (first (variants (name variant))))) + (is (= (length (variants (parent variant))) 1)) + (is (eql variant (first (variants (parent variant))))) (check-for-duplicate-identifiers variant) (is-false itemIdentities) (is (= (length scopes) 1)) @@ -543,9 +533,9 @@ (is (string= d-type string-type))) ((string= resourceData "Geographic Information - Metadata") (is (string= parent-name-value "ISO 19115")) - (is (= (length (variants (name variant))) 2)) - (is (or (eql variant (first (variants (name variant)))) - (eql variant (second (variants (name variant)))))) + (is (= (length (variants (parent variant))) 2)) + (is (or (eql variant (first (variants (parent variant)))) + (eql variant (second (variants (parent variant)))))) (check-for-duplicate-identifiers variant) (is (= (length scopes) 1)) (is (string= (first scopes) display-psi)) @@ -561,8 +551,8 @@ (is (string= d-type string-type))) ((string= resourceData "ISO/IEC-13250:2002") (is (string= parent-name-value "ISO/IEC 13250:2002: Topic Maps")) - (is (= (length (variants (name variant))) 1)) - (is (eql variant (first (variants (name variant))))) + (is (= (length (variants (parent variant))) 1)) + (is (eql variant (first (variants (parent variant))))) (check-for-duplicate-identifiers variant) (check-for-duplicate-identifiers variant) (is (= (length scopes) 2)) @@ -654,7 +644,7 @@ '("http://www.isidor.us/unittests/testtm" "http://www.topicmaps.org/xtm/1.0/core.xtm") (mapcan (lambda (tm) - (mapcar #'uri (item-identifiers tm))) + (mapcar #'uri (item-identifiers tm :revision 0))) tms) :test #'string=))))) Modified: branches/new-datamodel/src/xml/xtm/importer.lisp ============================================================================== --- branches/new-datamodel/src/xml/xtm/importer.lisp (original) +++ branches/new-datamodel/src/xml/xtm/importer.lisp Sun Jun 13 10:42:34 2010 @@ -196,5 +196,9 @@ :themes nil :start-revision start-revision :instance-of associationtype - :roles (list (list :instance-of roletype1 :player player1) - (list :instance-of roletype2 :player player2-obj)))))) + :roles (list (list :start-revision start-revision + :instance-of roletype1 + :player player1) + (list :start-revision start-revision + :instance-of roletype2 + :player player2-obj)))))) 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 Sun Jun 13 10:42:34 2010 @@ -34,7 +34,7 @@ (declare (dom:element elem)) (declare (integer start-revision)) (let - ((id (make-instance classsymbol + ((id (make-construct classsymbol :uri (get-attribute elem "href") :start-revision start-revision))) id)) @@ -130,7 +130,7 @@ (error "A name must have exactly one namevalue")) (let ((name (make-construct 'NameC :start-revision start-revision - :topic top + :parent top :charvalue namevalue :instance-of instance-of :item-identifiers item-identifiers @@ -200,7 +200,7 @@ :charvalue (getf variant-value :data) :datatype (getf variant-value :type) :reifier reifier-topic - :name name))) + :parent name))) (defun from-occurrence-elem (occ-elem top start-revision &key (xtm-id *current-xtm*)) @@ -226,7 +226,7 @@ (error "OccurrenceC: one of resourceRef and resourceData must be set")) (make-construct 'OccurrenceC :start-revision start-revision - :topic top + :parent top :themes themes :item-identifiers item-identifiers :instance-of instance-of @@ -252,13 +252,17 @@ (subjectidentifiers (make-identifiers 'PersistentIdC topic-elem "subjectIdentifier" start-revision)) (subjectlocators - (make-identifiers 'SubjectLocatorC topic-elem "subjectLocator" start-revision))) + (make-identifiers 'SubjectLocatorC topic-elem "subjectLocator" start-revision)) + (topic-ids (when (get-attribute topic-elem "id") + (list (make-construct 'TopicIdentificationC + :uri (get-attribute topic-elem "id") + :xtm-id xtm-id))))) (make-construct 'TopicC :start-revision start-revision :item-identifiers itemidentifiers :locators subjectlocators :psis subjectidentifiers - :topicid (get-attribute topic-elem "id") + :topic-identifiers topic-ids :xtm-id xtm-id)))) @@ -283,7 +287,8 @@ '((*xtm2.0-ns* "instanceOf") (*xtm2.0-ns* "topicRef")))))) (unless top - (error "topic ~a could not be found" (get-attribute topic-elem "id"))) + (error "topic ~a could not be found (xtm-id: ~a, revision: ~a)" + (get-attribute topic-elem "id") xtm-id start-revision)) (map 'list (lambda (name-elem) @@ -335,7 +340,8 @@ role-elem *xtm2.0-ns* "topicRef")))) - (list :reifier reifier-topic + (list :start-revision start-revision + :reifier reifier-topic :instance-of instance-of :player player :item-identifiers item-identifiers))))