[isidorus-cvs] r299 - in branches/new-datamodel/src: unit_tests xml/xtm
Lukas Giessmann
lgiessmann at common-lisp.net
Mon Jun 14 08:24:35 UTC 2010
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
More information about the Isidorus-cvs
mailing list