Author: lgiessmann Date: Mon Jun 14 04:24:35 2010 New Revision: 299

Log: new-datamodel: adpted all unittests for the xml-importer in version xtm1.0; fixed a bug when setting default role-types;

Modified: branches/new-datamodel/src/unit_tests/importer_test.lisp branches/new-datamodel/src/xml/xtm/importer.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/unit_tests/importer_test.lisp ============================================================================== --- branches/new-datamodel/src/unit_tests/importer_test.lisp (original) +++ branches/new-datamodel/src/unit_tests/importer_test.lisp Mon Jun 14 04:24:35 2010 @@ -99,7 +99,7 @@ (is (= 1 (length t101-themes))) (is (string= - (topic-id (first t101-themes) *TEST-TM*) + (topic-id (first t101-themes) rev-1 *TEST-TM*) "t50a"))))))

(test test-from-name-elem @@ -410,8 +410,6 @@ (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) - ;; fails with all 4 occurrences because the association is missing in the topics when (elephant:associatedp (get-item-by-id "t51") 'datamodel::used-as-type item) do (progn (is (string= (charvalue item) "#t52")) @@ -442,30 +440,46 @@ :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) - (is (= 26 (length (elephant:get-instances-by-class 'RoleC)))) ;4 + (22 instanceOf-associations) - (is (= 36 (length (elephant:get-instances-by-class 'PersistentIdC)))) ;23 + (13 core topics) + ;(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) + (is (= 13 (length (elephant:get-instances-by-class 'AssociationC)))) + ;4 + (22 instanceOf-associations) + (is (= 26 (length (elephant:get-instances-by-class 'RoleC)))) + ;23 + (13 core topics) + (is (= 36 (length (elephant:get-instances-by-class 'PersistentIdC)))) (is (= 0 (length (elephant:get-instances-by-class 'SubjectLocatorC)))) - (is (= 2 (length (elephant:get-instances-by-class 'OccurrenceC)))) ;2 + (0 core topics) - (is (= 18 (length (elephant:get-instances-by-class 'NameC)))) ;18 + (0 core topics) + ;2 + (0 core topics) + (is (= 2 (length (elephant:get-instances-by-class 'OccurrenceC)))) + ;18 + (0 core topics) + (is (= 18 (length (elephant:get-instances-by-class 'NameC)))) (let ((t-2526 (get-item-by-id "t-2526")) (t-2656 (get-item-by-id "t-2656")) (assoc (first (used-as-type (get-item-by-id "t89671052499"))))) (is (= (length (player-in-roles t-2526)) 1)) (is (= (length (psis t-2526)) 1)) - (is (string= (uri (first (psis t-2526))) "http://psi.egovpt.org/types/serviceUsesTechnology")) + (is (string= (uri (first (psis t-2526))) + "http://psi.egovpt.org/types/serviceUsesTechnology")) (is (= (length (names t-2526)) 3)) - (is (or (string= (charvalue (first (names t-2526))) "service uses technology") - (string= (charvalue (second (names t-2526))) "service uses technology") - (string= (charvalue (third (names t-2526))) "service uses technology"))) - (is (or (string= (charvalue (first (names t-2526))) "uses technology") - (string= (charvalue (second (names t-2526))) "uses technology") - (string= (charvalue (third (names t-2526))) "uses technology"))) - (is (or (string= (charvalue (first (names t-2526))) "used by service") - (string= (charvalue (second (names t-2526))) "used by service") - (string= (charvalue (third (names t-2526))) "used by service"))) + (is (or (string= (charvalue (first (names t-2526))) + "service uses technology") + (string= (charvalue (second (names t-2526))) + "service uses technology") + (string= (charvalue (third (names t-2526))) + "service uses technology"))) + (is (or (string= (charvalue (first (names t-2526))) + "uses technology") + (string= (charvalue (second (names t-2526))) + "uses technology") + (string= (charvalue (third (names t-2526))) + "uses technology"))) + (is (or (string= (charvalue (first (names t-2526))) + "used by service") + (string= (charvalue (second (names t-2526))) + "used by service") + (string= (charvalue (third (names t-2526))) + "used by service"))) (loop for name in (names t-2526) when (string= (charvalue name) "uses technology") do (is (= (length (themes name)) 1)) @@ -475,15 +489,18 @@ (is (eq (first (themes name)) (get-item-by-id "t-2593")))) (is (= (length (player-in-roles t-2656)) 2)) ;association + instanceOf (is (= (length (psis t-2656)) 1)) - (is (string= (uri (first (psis t-2656))) "http://psi.egovpt.org/types/DO-NOT-SIGNAL-no-identifier-error")) + (is (string= (uri (first (psis t-2656))) + "http://psi.egovpt.org/types/DO-NOT-SIGNAL-no-identifier-error")) (is (= (length (occurrences t-2656)) 2)) (loop for occ in (occurrences t-2656) when (eq (instance-of occ) (get-item-by-id "t-2625")) do (is (string= (charvalue occ) "0")) - (is (string= (datatype occ) "http://www.w3.org/2001/XMLSchema#string")) + (is (string= (datatype occ) + "http://www.w3.org/2001/XMLSchema#string")) when (eq (instance-of occ) (get-item-by-id "t-2626")) do (is (string= (charvalue occ) "unbounded")) - (is (string= (datatype occ) "http://www.w3.org/2001/XMLSchema#string")) + (is (string= (datatype occ) + "http://www.w3.org/2001/XMLSchema#string")) when (not (or (eq (instance-of occ) (get-item-by-id "t-2625")) (eq (instance-of occ) (get-item-by-id "t-2626")))) do (is-true (format t "bad occurrence found in t-2526"))) @@ -495,7 +512,8 @@ do (is (eq (instance-of role) (get-item-by-id "narrower-term"))) when (not (or (eq (player role) (get-item-by-id "all-subjects")) (eq (player role) (get-item-by-id "t1106723946")))) - do (is-true (format t "bad role found in association: ~A" (topic-identifiers (player role))))))))) + do (is-true (format t "bad role found in association: ~A" + (topic-identifiers (player role)))))))))

(test test-variants @@ -540,12 +558,14 @@ (is (= (length scopes) 1)) (is (string= (first scopes) display-psi)) (is (= (length itemIdentities) 1)) - (is (string= (first itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t100_n1_v1")) + (is (string= (first itemIdentities) + "http://psi.egovpt.org/itemIdentifiers#t100_n1_v1")) (is (string= d-type string-type))) ((string= resourceData "ISO-19115") (check-for-duplicate-identifiers variant) (is (= (length itemIdentities) 1)) - (is (string= (first itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t100_n1_v2")) + (is (string= (first itemIdentities) + "http://psi.egovpt.org/itemIdentifiers#t100_n1_v2")) (is (= (length scopes) 1)) (is (string= (first scopes) sort-psi)) (is (string= d-type string-type))) @@ -561,10 +581,14 @@ (is (or (string= (second scopes) t50a-psi) (string= (second scopes) sort-psi))) (is (= (length itemIdentities) 2)) - (is (or (string= (first itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t101_n2_v1") - (string= (first itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t101_n2_v2"))) - (is (or (string= (second itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t101_n2_v1") - (string= (second itemIdentities) "http://psi.egovpt.org/itemIdentifiers#t101_n2_v2"))) + (is (or (string= (first itemIdentities) + "http://psi.egovpt.org/itemIdentifiers#t101_n2_v1") + (string= (first itemIdentities) + "http://psi.egovpt.org/itemIdentifiers#t101_n2_v2"))) + (is (or (string= (second itemIdentities) + "http://psi.egovpt.org/itemIdentifiers#t101_n2_v1") + (string= (second itemIdentities) + "http://psi.egovpt.org/itemIdentifiers#t101_n2_v2"))) (is (string= d-type string-type))) (t (is-true (format t "found bad resourceData in variant object: ~A~%" resourceData)))))))))) @@ -573,61 +597,70 @@

(test test-variants-xtm1.0 "tests the importer-xtm1.0 -> variants" - (let - ((dir "data_base")) + (let ((dir "data_base")) (with-fixture initialize-destination-db (dir) (xml-importer:setup-repository *sample_objects.xtm* dir :xtm-id *TEST-TM* :xtm-format '1.0) - - (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) do (let ((baseNameString (charvalue baseName)) (name-variants (variants baseName))) (loop for variant in name-variants - do (is (string= (datatype variant) "http://www.w3.org/2001/XMLSchema#string"))) + do (is (string= (datatype variant) + "http://www.w3.org/2001/XMLSchema#string"))) (cond ((string= baseNameString "service uses technology") (is (= (length name-variants) 2)) (loop for variant in name-variants - do (is (eql baseName (name variant))) + do (is (eql baseName (parent variant))) (let ((variantName (charvalue variant))) (cond ((string= variantName "service-uses-technology") (is (= (length (themes variant)) 1)) - (is (eql (first (themes variant)) (get-item-by-id "sort")))) + (is (eql (first (themes variant)) + (get-item-by-id "sort")))) ((string= variantName "service uses technology") (is (= (length (themes variant)) 1)) - (is (eql (first (themes variant)) (get-item-by-id "display")))) + (is (eql (first (themes variant)) + (get-item-by-id "display")))) (t (is-true (format t "basevariantName found in t-2526: ~A~%" variantName))))))) ((string= baseNameString "uses technology") (is (= (length name-variants) 2)) (loop for variant in name-variants - do (is (eql baseName (name variant))) + do (is (eql baseName (parent variant))) (let ((variantName (charvalue variant))) (cond ((string= variantName "uses technology") (is (= (length (themes variant)) 2)) - (is-true (find (get-item-by-id "t-2555") (themes variant) :test #'eql)) - (is-true (find (get-item-by-id "display") (themes variant) :test #'eql))) + (is-true (find (get-item-by-id "t-2555") + (themes variant) :test #'eql)) + (is-true (find (get-item-by-id "display") + (themes variant) :test #'eql))) ((string= variantName "uses-technology") (is (= (length (themes variant)) 3)) - (is-true (find (get-item-by-id "t-2555") (themes variant) :test #'eql)) - (is-true (find (get-item-by-id "display") (themes variant) :test #'eql)) - (is-true (find (get-item-by-id "sort") (themes variant) :test #'eql))) + (is-true (find (get-item-by-id "t-2555") + (themes variant) :test #'eql)) + (is-true (find (get-item-by-id "display") + (themes variant) :test #'eql)) + (is-true (find (get-item-by-id "sort") + (themes variant) :test #'eql))) (t (is-true (format t "bad variantName found in t-2526: ~A~%" variantName))))))) ((string= baseNameString "used by service") (is (= (length name-variants) 1)) (loop for variant in name-variants - do (is (eql baseName (name variant))) + do (is (eql baseName (parent variant))) (is (string= (charvalue variant) "used-by-service")) (is (= (length (themes variant)) 3)) - (is-true (find (get-item-by-id "t-2593") (themes variant) :test #'eql)) - (is-true (find (get-item-by-id "display") (themes variant) :test #'eql)) - (is-true (find (get-item-by-id "sort") (themes variant) :test #'eql)))) + (is-true (find (get-item-by-id "t-2593") + (themes variant) :test #'eql)) + (is-true (find (get-item-by-id "display") + (themes variant) :test #'eql)) + (is-true (find (get-item-by-id "sort") + (themes variant) :test #'eql)))) (t (is-true (format t "bad baseNameString found in names of t-2526: ~A~%" baseNameString))))))))))

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 Mon Jun 14 04:24:35 2010 @@ -23,7 +23,9 @@ *instance-psi* *XTM2.0-NS* *XTM1.0-NS* - *XTM1.0-XLINK*) + *XTM1.0-XLINK* + *XML-STRING* + *XML-URI*) (:import-from :xml-constants *core_psis.xtm*) (:import-from :xml-tools

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 Mon Jun 14 04:24:35 2010 @@ -56,8 +56,8 @@ (let ((data-elem (xpath-single-child-elem-by-qname parent-elem *xtm1.0-ns* "resourceData"))) (declare (dom:element parent-elem)) (if data-elem - "http://www.w3.org/2001/XMLSchema#string" - "http://www.w3.org/2001/XMLSchema#anyURI")))) + *XML-STRING* + *XML-URI*)))) (unless data (error "from-resourceX-elem-xtm1.0: one of resourceRef or resourceData must be set")) (list :data data :type type)))) @@ -68,7 +68,6 @@ variant = element variant { parameters, variantName?, variant* }" (declare (dom:element variant-elem)) (declare (CharacteristicC parent-construct)) ;;parent name or parent variant object - (declare (optimize (debug 3))) (let ((parameters (remove-duplicates (remove-if #'null @@ -95,7 +94,7 @@ :charvalue (getf variantName :data) :datatype (getf variantName :type) :reifier reifier-topic - :name parent-name))) + :parent parent-name))) (let ((inner-variants (map 'list #'(lambda(x) (from-variant-elem-xtm1.0 x variant start-revision :xtm-id xtm-id)) @@ -110,15 +109,18 @@ (let ((parameters (let ((topicRefs (map 'list #'from-topicRef-elem-xtm1.0 - (xpath-child-elems-by-qname parameters-elem *xtm1.0-ns* "topicRef"))) + (xpath-child-elems-by-qname parameters-elem *xtm1.0-ns* + "topicRef"))) (subjectIndicatorRefs (map 'list #'(lambda(x) (get-xlink-attribute x "href")) - (xpath-child-elems-by-qname parameters-elem *xtm1.0-ns* "subjectIndicatorRef")))) + (xpath-child-elems-by-qname parameters-elem *xtm1.0-ns* + "subjectIndicatorRef")))) (let ((topic-list (append (map 'list #'(lambda(x) - (get-item-by-id x :xtm-id xtm-id :revision start-revision)) + (get-item-by-id x :xtm-id xtm-id + :revision start-revision)) topicRefs) (map 'list #'(lambda(x) (get-item-by-psi x :revision start-revision)) @@ -154,7 +156,7 @@ (error "A baseName must have exactly one baseNameString")) (let ((name (make-construct 'NameC :start-revision start-revision - :topic top + :parent top :charvalue baseNameString :reifier reifier-topic :themes themes))) @@ -181,41 +183,61 @@ (when parent-elem (let ((instanceOf-elems (xpath-child-elems-by-qname parent-elem *xtm1.0-ns* "instanceOf"))) (when (> (length instanceOf-elems) 0) - (let ((topicRefs (map 'list #'(lambda(x) - (when (xpath-single-child-elem-by-qname x *xtm1.0-ns* "topicRef") - (from-topicRef-elem-xtm1.0 - (xpath-single-child-elem-by-qname x *xtm1.0-ns* "topicRef")))) + (let ((topicRefs + (map 'list #'(lambda(x) + (when (xpath-single-child-elem-by-qname + x *xtm1.0-ns* "topicRef") + (from-topicRef-elem-xtm1.0 + (xpath-single-child-elem-by-qname x *xtm1.0-ns* + "topicRef")))) instanceOf-elems)) - (subjectIndicatorRefs (map 'list #'(lambda(x) - (when (xpath-single-child-elem-by-qname - x *xtm1.0-ns* "subjectIndicatorRef") - (get-xlink-attribute - (xpath-single-child-elem-by-qname - x *xtm1.0-ns* "subjectIndicatorRef") "href"))) - instanceOf-elems))) - (let ((ids (remove-if #'null(append - (map 'list #'(lambda(x) - (get-topicid-by-psi x :xtm-id xtm-id)) - subjectIndicatorRefs) - topicRefs)))) + (subjectIndicatorRefs + (map 'list #'(lambda(x) + (when (xpath-single-child-elem-by-qname + x *xtm1.0-ns* "subjectIndicatorRef") + (get-xlink-attribute + (xpath-single-child-elem-by-qname + x *xtm1.0-ns* "subjectIndicatorRef") "href"))) + instanceOf-elems))) + (let ((ids + (remove-if #'null + (append + (map 'list #'(lambda(x) + (get-topicid-by-psi x :xtm-id xtm-id)) + subjectIndicatorRefs) + topicRefs)))) (declare (dom:element parent-elem)) ids))))))

-(defun from-roleSpec-elem-xtm1.0 (roleSpec-elem &key (xtm-id *current-xtm*)) +(defun from-roleSpec-elem-xtm1.0 (roleSpec-elem start-revision + &key (xtm-id *current-xtm*)) "returns the referenced topic of the roleSpec's topicRef and subjectIndicatorRef element." (when roleSpec-elem - (let ((top-id (when (xpath-single-child-elem-by-qname roleSpec-elem *xtm1.0-ns* "topicRef") - (from-topicRef-elem-xtm1.0 - (xpath-single-child-elem-by-qname roleSpec-elem *xtm1.0-ns* "topicRef")))) - (sIRs (map 'list #'(lambda(uri)(get-topicid-by-psi uri :xtm-id xtm-id)) + (let ((top-id + (when (xpath-single-child-elem-by-qname roleSpec-elem *xtm1.0-ns* + "topicRef") + (from-topicRef-elem-xtm1.0 + (xpath-single-child-elem-by-qname roleSpec-elem *xtm1.0-ns* + "topicRef")))) + (sIRs (map 'list #'(lambda(uri) + (get-topicid-by-psi uri :xtm-id xtm-id + :revision start-revision)) (map 'list #'(lambda(x) (dom:get-attribute-ns x *xtm1.0-xlink* "href")) - (xpath-child-elems-by-qname roleSpec-elem *xtm1.0-ns* "subjectIndicatorRef"))))) - (let ((ref-topic (first (remove-if #'null - (append - (list (get-item-by-id top-id :xtm-id xtm-id)) - (map 'list #'(lambda(id)(get-item-by-id id :xtm-id xtm-id)) sIRs)))))) + (xpath-child-elems-by-qname roleSpec-elem *xtm1.0-ns* + "subjectIndicatorRef"))))) + (let ((ref-topic + (first (remove-if #'null + (append + (when top-id + (list (get-item-by-id top-id :xtm-id xtm-id + :revision start-revision))) + (map 'list #'(lambda(id) + (get-item-by-id + id :xtm-id xtm-id + :revision start-revision)) + sIRs)))))) (declare (dom:element roleSpec-elem)) (unless ref-topic (error (make-condition 'missing-reference-error @@ -230,14 +252,19 @@ (when (xpath-child-elems-by-qname scope-elem *xtm1.0-ns* "topicRef") (let ((refs (append (map 'list #'from-topicRef-elem-xtm1.0 - (xpath-child-elems-by-qname scope-elem *xtm1.0-ns* "topicRef")) + (xpath-child-elems-by-qname scope-elem *xtm1.0-ns* + "topicRef")) (map 'list #'(lambda(uri)(get-topicid-by-psi uri :xtm-id xtm-id)) (map 'list #'(lambda(x) - (dom:get-attribute-ns x *xtm1.0-xlink* "href")) - (xpath-child-elems-by-qname scope-elem *xtm1.0-ns* "subjectIndicatorRef")))))) + (dom:get-attribute-ns x *xtm1.0-xlink* + "href")) + (xpath-child-elems-by-qname scope-elem *xtm1.0-ns* + "subjectIndicatorRef")))))) (let ((ref-topics (map 'list #'(lambda(x) - (let ((ref-topic (get-item-by-id x :xtm-id xtm-id :revision start-revision))) + (let ((ref-topic + (get-item-by-id x :xtm-id xtm-id + :revision start-revision))) (if ref-topic ref-topic (error (make-condition 'missing-reference-error @@ -257,7 +284,10 @@ (declare (integer start-revision)) (let* ((instanceOf (when (get-instanceOf-refs-xtm1.0 occ-elem :xtm-id xtm-id) - (get-item-by-id (first (get-instanceOf-refs-xtm1.0 occ-elem :xtm-id xtm-id)) :xtm-id xtm-id))) + (get-item-by-id + (first (get-instanceOf-refs-xtm1.0 occ-elem + :xtm-id xtm-id)) + :xtm-id xtm-id :revision start-revision))) (themes (from-scope-elem-xtm1.0 (xpath-single-child-elem-by-qname occ-elem *xtm1.0-ns* "scope") start-revision :xtm-id xtm-id)) @@ -267,11 +297,13 @@ (unless occurrence-value (error "from-occurrence-elem-xtm1.0: one of resourceRef and resourceData must be set")) (unless instanceOf - (format t "from-occurrence-elem-xtm1.0: type is missing -> http://psi.topicmaps.org/iso13250/model/type-instance~%") - (setf instanceOf (get-item-by-id "type-instance" :xtm-id "core.xtm"))) + (format t "from-occurrence-elem-xtm1.0: type is missing -> ~a~%" + *type-instance-psi*) + (setf instanceOf (get-item-by-psi *type-instance-psi* + :revision start-revision))) (make-construct 'OccurrenceC :start-revision start-revision - :topic top + :parent top :themes themes :instance-of instanceOf :charvalue (getf occurrence-value :data) @@ -282,58 +314,75 @@ (defun from-subjectIdentity-elem-xtm1.0 (subjectIdentity-elem start-revision) "creates PersistentIdC's from the element subjectIdentity" (when subjectIdentity-elem - (let ((psi-refs (map 'list #'(lambda(x) - (get-xlink-attribute x "href")) - (xpath-child-elems-by-qname subjectIdentity-elem *xtm1.0-ns* "subjectIndicatorRef"))) - (locator-refs (map 'list #'(lambda(x) - (get-xlink-attribute x "href")) - (xpath-child-elems-by-qname subjectIdentity-elem *xtm1.0-ns* "resourceRef")))) - - (let ((psis (map 'list #'(lambda(uri) - (let ((id (make-instance 'PersistentIdC - :uri uri - :start-revision start-revision))) - id)) - psi-refs)) - (locators (map 'list #'(lambda(uri) - (let ((loc (make-instance 'SubjectLocatorC - :uri uri - :start-revision start-revision))) - loc)) + (let ((psi-refs + (map 'list #'(lambda(x) + (get-xlink-attribute x "href")) + (xpath-child-elems-by-qname subjectIdentity-elem *xtm1.0-ns* + "subjectIndicatorRef"))) + (locator-refs + (map 'list #'(lambda(x) + (get-xlink-attribute x "href")) + (xpath-child-elems-by-qname subjectIdentity-elem *xtm1.0-ns* + "resourceRef")))) + (let ((psis + (map 'list #'(lambda(uri) + (let ((id + (make-construct 'PersistentIdC + :uri uri + :start-revision start-revision))) + id)) + psi-refs)) + (locators (map 'list + #'(lambda(uri) + (let ((loc + (make-construct 'SubjectLocatorC + :uri uri + :start-revision start-revision))) + loc)) locator-refs))) (declare (dom:element subjectIdentity-elem)) (declare (integer start-revision)) (list :psis psis :locators locators)))))

-(defun from-member-elem-xtm1.0 (member-elem start-revision &key (xtm-id *current-xtm*)) +(defun from-member-elem-xtm1.0 (member-elem start-revision + &key (xtm-id *current-xtm*)) "returns a list with the role- type, player and itemIdentities" (when member-elem (elephant:ensure-transaction (:txn-nosync t) - (let - ((type (from-rolespec-elem-xtm1.0 (xpath-single-child-elem-by-qname member-elem *xtm1.0-ns* "roleSpec") :xtm-id xtm-id)) - (player (remove-if #'null - (append - (list (get-item-by-id (from-topicRef-elem-xtm1.0 - (xpath-single-child-elem-by-qname - member-elem - *xtm1.0-ns* - "topicRef")) - :xtm-id xtm-id)) - (map 'list #'(lambda(topicid) - (get-item-by-id topicid :xtm-id xtm-id)) - (map 'list #'(lambda(uri)(get-topicid-by-psi uri :xtm-id xtm-id)) - (map 'list #'(lambda(x) - (get-xlink-attribute x "href")) - (xpath-child-elems-by-qname - member-elem - *xtm1.0-ns* - "subjectIndicatorRef"))))))) - (reifier-topic (get-reifier-topic-xtm1.0 member-elem start-revision))) + (let ((type (from-roleSpec-elem-xtm1.0 + (xpath-single-child-elem-by-qname member-elem *xtm1.0-ns* + "roleSpec") + start-revision :xtm-id xtm-id)) + (player + (let ((topicRef + (from-topicRef-elem-xtm1.0 (xpath-single-child-elem-by-qname + member-elem *xtm1.0-ns* "topicRef"))) + (sIRs (xpath-child-elems-by-qname + member-elem *xtm1.0-ns* "subjectIndicatorRef"))) + (remove-if + #'null + (append + (when topicRef + (list (get-item-by-id topicRef + :xtm-id xtm-id + :revision start-revision))) + (map 'list #'(lambda(topicid) + (get-item-by-id + topicid + :xtm-id xtm-id + :revision start-revision)) + (map 'list #'(lambda(uri) + (get-topicid-by-psi uri :xtm-id xtm-id)) + (map 'list #'(lambda(x) + (get-xlink-attribute x "href")) + sIRs))))))) + (reifier-topic (get-reifier-topic-xtm1.0 member-elem start-revision))) (declare (dom:element member-elem)) (unless player ; if no type is given a standard type will be assigend later in from-assoc... (error "from-member-elem-xtm1.0: missing player in role")) - (list :instance-of type + (list :start-revision start-revision + :instance-of type :player (first player) :item-identifiers nil :reifier reifier-topic))))) @@ -346,16 +395,20 @@ (declare (dom:element topic-elem)) (declare (integer start-revision)) (elephant:ensure-transaction (:txn-nosync t) - (let ((identifiers (from-subjectIdentity-elem-xtm1.0 (xpath-single-child-elem-by-qname - topic-elem - *xtm1.0-ns* - "subjectIdentity") - start-revision))) + (let ((identifiers (from-subjectIdentity-elem-xtm1.0 + (xpath-single-child-elem-by-qname + topic-elem + *xtm1.0-ns* + "subjectIdentity") + start-revision)) + (topic-identifiers + (list (make-construct 'TopicIdentificationC + :uri (get-topic-id-xtm1.0 topic-elem) + :xtm-id xtm-id)))) (make-construct 'TopicC :start-revision start-revision :psis (getf identifiers :psis) :locators (getf identifiers :locators) - :topicid (get-topic-id-xtm1.0 topic-elem) - :xtm-id xtm-id)))) + :topic-identifiers topic-identifiers))))

(defun merge-topic-elem-xtm1.0 (topic-elem start-revision @@ -368,16 +421,20 @@ (declare (integer start-revision)) (declare (TopicMapC tm)) (elephant:ensure-transaction (:txn-nosync t) - (let - ((top - (get-item-by-id - (get-topic-id-xtm1.0 topic-elem) - :xtm-id xtm-id :revision start-revision)) - (instanceOf-topicRefs (remove-if #'null (get-instanceOf-refs-xtm1.0 topic-elem :xtm-id xtm-id))) - (baseName-elems (xpath-child-elems-by-qname topic-elem *xtm1.0-ns* "baseName")) - (occ-elems (xpath-child-elems-by-qname topic-elem *xtm1.0-ns* "occurrence"))) + (let ((top + (get-item-by-id + (get-topic-id-xtm1.0 topic-elem) + :xtm-id xtm-id :revision start-revision)) + (instanceOf-topicRefs + (remove-if #'null (get-instanceOf-refs-xtm1.0 topic-elem + :xtm-id xtm-id))) + (baseName-elems + (xpath-child-elems-by-qname topic-elem *xtm1.0-ns* "baseName")) + (occ-elems (xpath-child-elems-by-qname topic-elem *xtm1.0-ns* "occurrence"))) (unless top - (error "topic ~a could not be found" (get-attribute topic-elem "id"))) + (error (make-condition 'missing-reference-error + :message (format nil "topic ~a could not be found" + (get-attribute topic-elem "id"))))) ;;names (map 'list #'(lambda(x) (from-baseName-elem-xtm1.0 x top start-revision :xtm-id xtm-id)) @@ -388,18 +445,22 @@ occ-elems) ;;instanceOf (dolist (instanceOf-topicRef instanceOf-topicRefs) - (create-instanceof-association instanceOf-topicRef top start-revision :xtm-id xtm-id - :tm tm)) + (create-instanceof-association instanceOf-topicRef top start-revision + :xtm-id xtm-id :tm tm)) (add-to-tm tm top))))

-(defun from-association-elem-xtm1.0 (assoc-elem start-revision &key tm (xtm-id *current-xtm*)) +(defun from-association-elem-xtm1.0 (assoc-elem start-revision + &key tm (xtm-id *current-xtm*)) (declare (dom:element assoc-elem)) (declare (integer start-revision)) (declare (TopicMapC tm)) (elephant:ensure-transaction (:txn-nosync t) (let ((type (when (get-instanceOf-refs-xtm1.0 assoc-elem :xtm-id xtm-id) - (get-item-by-id (first (get-instanceOf-refs-xtm1.0 assoc-elem :xtm-id xtm-id)) :xtm-id xtm-id))) + (get-item-by-id (first (get-instanceOf-refs-xtm1.0 assoc-elem + :xtm-id xtm-id)) + :xtm-id xtm-id + :revision start-revision))) (themes (from-scope-elem-xtm1.0 (xpath-single-child-elem-by-qname assoc-elem *xtm1.0-ns* "scope") @@ -412,20 +473,21 @@ (reifier-topic (get-reifier-topic-xtm1.0 assoc-elem start-revision))) (unless roles (error "from-association-elem-xtm1.0: roles are missing in association")) - (setf roles (set-standard-role-types roles)) + (setf roles (set-standard-role-types roles start-revision)) (unless type (format t "from-association-elem-xtm1.0: type is missing -> http://www.topicmaps.org/xtm/1.0/core.xtm#association~%") - (setf type (get-item-by-id "association" :xtm-id "core.xtm"))) + (setf type (get-item-by-id "association" :xtm-id "core.xtm" + :revision start-revision))) (add-to-tm tm - (make-construct 'AssociationC - :start-revision start-revision - :instance-of type - :themes themes - :reifier reifier-topic - :roles roles))))) + (make-construct 'AssociationC + :start-revision start-revision + :instance-of type + :themes themes + :reifier reifier-topic + :roles roles)))))

-(defun set-standard-role-types (roles) +(defun set-standard-role-types (roles start-revision) "sets the missing role types of the passed roles to the default types." (when roles (let ((empty-roles (loop for role in roles @@ -435,22 +497,25 @@ (let ((is-type (loop for role in roles when (and (getf role :instance-of) (loop for psi in (psis (getf role :instance-of)) - when (string= (uri psi) - "http://psi.topicmaps.org/iso13250/model/type") + when (string= (uri psi) *type-psi*) return t)) return t))) (declare (list roles)) (when (not is-type) (loop for role in roles when (not (getf role :instance-of)) - do (setf (getf role :instance-of) (get-item-by-id "type" :xtm-id "core.xtm")) - (format t "set-standard-role-types: role type is missing -> http://psi.topicmaps.org/iso13250/model/type~%") + do (setf (getf role :instance-of) + (get-item-by-psi *type-psi* :revision start-revision)) + (format t "set-standard-role-types: role type is missing -> ~a~%" + *type-psi*) (return t))) (when (or (> (length empty-roles) 1) (and empty-roles (not is-type))) (loop for role in roles when (not (getf role :instance-of)) - do (setf (getf role :instance-of) (get-item-by-id "instance" :xtm-id "core.xtm")) - (format t "set-standard-role-types: role type is missing -> http://psi.topicmaps.org/iso13250/model/instance~%")))))) + do (setf (getf role :instance-of) + (get-item-by-psi *instance-psi* :revision start-revision)) + (format t "set-standard-role-types: role type is missing -> ~a~%" + *instance-psi*)))))) roles))

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 Mon Jun 14 04:24:35 2010 @@ -89,7 +89,8 @@ (lambda (topicid) (let ((top - (get-item-by-id topicid :xtm-id xtm-id :revision start-revision))) + (get-item-by-id topicid :xtm-id xtm-id + :revision start-revision))) (if top top (error (make-condition 'missing-reference-error @@ -244,7 +245,6 @@ applicable" (declare (dom:element topic-elem)) (declare (integer start-revision)) - ;(declare (optimize (debug 3))) (elephant:ensure-transaction (:txn-nosync t) (let ((itemidentifiers @@ -262,8 +262,7 @@ :item-identifiers itemidentifiers :locators subjectlocators :psis subjectidentifiers - :topic-identifiers topic-ids - :xtm-id xtm-id)))) + :topic-identifiers topic-ids))))

(defun merge-topic-elem (topic-elem start-revision @@ -378,7 +377,7 @@ assoc-elem *xtm2.0-ns* "role"))) (reifier-topic (get-reifier-topic assoc-elem start-revision))) - (setf roles (set-standard-role-types roles)); sets standard role types if there are missing some of them + (setf roles (set-standard-role-types roles start-revision)); sets standard role types if there are missing some of them (add-to-tm tm (make-construct 'AssociationC