Author: lgiessmann Date: Wed Sep 2 10:15:46 2009 New Revision: 130 Log: rdf-importer: added the functionality of importing isidorus:Occurrence nodes; added also some unti tests Modified: trunk/src/unit_tests/rdf_importer_test.lisp trunk/src/xml/rdf/importer.lisp trunk/src/xml/rdf/isidorus_constructs_tools.lisp Modified: trunk/src/unit_tests/rdf_importer_test.lisp ============================================================================== --- trunk/src/unit_tests/rdf_importer_test.lisp (original) +++ trunk/src/unit_tests/rdf_importer_test.lisp Wed Sep 2 10:15:46 2009 @@ -72,7 +72,8 @@ :test-get-all-type-psis :test-isidorus-type-p :test-get-all-isidorus-nodes-by-id - :test-import-isidorus-name)) + :test-import-isidorus-name + :test-import-isidorus-occurrence)) (declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0))) @@ -3479,6 +3480,103 @@ *xml-string*)))))))) +(test test-import-isidorus-occurrence + "Tests all functions that are responsible to import a resource + representing isidorus:Occurrence." + (let ((revision-1 100) + (tm-id "http://test/tm-id") + (document-id "doc-id") + (db-dir "./data_base") + (doc-1 + (concatenate 'string "<rdf:RDF xmlns:rdf=\"" *rdf-ns* "\" " + " xmlns:sw=\"http://test/arcs/\"" + " xmlns:isi=\"" *tm2rdf-ns* "\">" + " <rdf:Description rdf:about=\"http://node-1\">" + " <sw:arc rdf:resource=\"http://resource-1\"/>" + " <isi:occurrence rdf:type=\"http://isidorus/tm2rdf_mapping/Occurrence\">" + " <isi:occurrencetype rdf:resource=\"http://occurrence-1\"/>" + " <isi:value rdf:datatype=\"dt-1\">value-1</isi:value>" + " </isi:occurrence>" + " <isi:occurrence rdf:nodeID=\"occurrence-2\"/>" + " <isi:occurrence>" + " <isi:Occurrence rdf:nodeID=\"occurrence-2\">" + " <isi:occurrencetype rdf:resource=\"http://occurrence-2\"/>" + " <isi:scope rdf:resource=\"http://scope-1\"/>" + " </isi:Occurrence>" + " </isi:occurrence>" + " <isi:occurrence rdf:parseType=\"Resource\">" + " <rdf:type rdf:resource=\"" *tm2rdf-occurrence-type-uri* "\"/>" + " <isi:occurrencetype rdf:resource=\"http://occurrence-3\"/>" + " <!-- should get the charvalue '' of type xml-string -->" + " </isi:occurrence>" + " </rdf:Description>" + + " <rdf:Description rdf:nodeID=\"occurrence-2\">" + " <isi:scope rdf:resource=\"http://scope-2\"/>" + " <isi:value>value-2</isi:value>" + " <isi:occurrencetype rdf:resource=\"http://occurrence-2\"/>" + " <isi:itemIdentity rdf:datatype=\"" *xml-uri* "\">http://itemIdentity-1</isi:itemIdentity>" + " <isi:itemIdentity rdf:datatype=\"" *xml-uri* "\">http://itemIdentity-2</isi:itemIdentity>" + " <isi:shouldBeIgnored>anyText</isi:shouldBeIgnored>" + " </rdf:Description>" + "</rdf:RDF>"))) + (let ((root (elt (dom:child-nodes (cxml:parse doc-1 + (cxml-dom:make-dom-builder))) + 0))) + (is (= (length (rdf-importer::child-nodes-or-text root)) 2)) + (rdf-init-db :db-dir db-dir :start-revision revision-1) + (rdf-importer::import-dom root revision-1 :tm-id tm-id + :document-id document-id) + (is (= (length (elephant:get-instances-by-class 'd:OccurrenceC)) 3)) + (is (= (length (elephant:get-instances-by-class 'd:NameC))) 0) + (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 26)) + (let ((node-1 (d:get-item-by-psi "http://node-1")) + (occurrence-1 (d:get-item-by-psi "http://occurrence-1")) + (occurrence-2 (d:get-item-by-psi "http://occurrence-2")) + (occurrence-3 (d:get-item-by-psi "http://occurrence-3")) + (scope-1 (d:get-item-by-psi "http://scope-1")) + (scope-2 (d:get-item-by-psi "http://scope-2"))) + (is-true node-1) + (is-true occurrence-1) + (is-true occurrence-2) + (is-true occurrence-3) + (is-true scope-1) + (is-true scope-2) + (let ((occ-1 (find-if #'(lambda(x) + (eql (d:instance-of x) occurrence-1)) + (d:occurrences node-1))) + (occ-2 (find-if #'(lambda(x) + (eql (d:instance-of x) occurrence-2)) + (d:occurrences node-1))) + (occ-3 (find-if #'(lambda(x) + (eql (d:instance-of x) occurrence-3)) + (d:occurrences node-1)))) + (is-true occ-1) + (is-true occ-2) + (is-true occ-3) + (is-false (d:item-identifiers occ-1)) + (is-false (d:themes occ-1)) + (is (string= (d:charvalue occ-1) "value-1")) + (is (string= (d:datatype occ-1) (concatenate 'string tm-id "/dt-1"))) + (is (= (length (intersection + (d:item-identifiers occ-2) + (list (elephant:get-instance-by-value + 'd:ItemIdentifierC 'd:uri + "http://itemIdentity-1") + (elephant:get-instance-by-value + 'd:ItemIdentifierC 'd:uri + "http://itemIdentity-2")))) + 2)) + (is (= (length (intersection (list scope-1 scope-2) + (d:themes occ-2))) + 2)) + (is (string= (d:charvalue occ-2) "value-2")) + (is (string= (d:datatype occ-2) *xml-string*)) + (is-false (d:item-identifiers occ-3)) + (is-false (d:themes occ-3)) + (is (string= (d:charvalue occ-3) "")) + (is (string= (d:datatype occ-3) *xml-string*))))))) + (defun run-rdf-importer-tests() "Runs all defined tests." @@ -3507,4 +3605,5 @@ (it.bese.fiveam:run! 'test-get-all-type-psis) (it.bese.fiveam:run! 'test-isidorus-type-p) (it.bese.fiveam:run! 'test-get-all-isidorus-nodes-by-id) - (it.bese.fiveam:run! 'test-import-isidorus-name)) \ No newline at end of file + (it.bese.fiveam:run! 'test-import-isidorus-name) + (it.bese.fiveam:run! 'test-import-isidorus-occurrence)) \ No newline at end of file Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Wed Sep 2 10:15:46 2009 @@ -104,7 +104,8 @@ (ID (get-absolute-attribute elem tm-id xml-base "ID")) (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*))) (parse-properties-of-node elem (or about nodeID ID UUID)) - ;TODO: create associaitons and roles + ;TODO: create associations and roles -> and iterate in import-dom + ; over those elements (let ((literals (append (get-literals-of-node elem fn-xml-lang) (get-literals-of-node-content elem tm-id xml-base fn-xml-lang))) @@ -126,8 +127,11 @@ :item-identifiers item-identifiers :subject-locators subject-locators))) (make-isidorus-names elem this tm-id start-revision - :owner-xml-base fn-xml-base) - ;TODO: create topic occurrences + :owner-xml-base fn-xml-base + :document-id document-id) + (make-isidorus-occurrences elem this tm-id start-revision + :owner-xml-base fn-xml-base + :document-id document-id) (make-literals this literals tm-id start-revision :document-id document-id) (make-associations this associations xml-importer::tm @@ -143,17 +147,70 @@ this)))))) +(defun make-isidorus-occurrences (owner-elem owner-topic tm-id start-revision + &key (owner-xml-base nil) + (document-id *document-id*)) + "Creates all occurrences of resource nodes that are in a + property isidorus:occurrence and have the type isidorus:Occurrence." + (declare (dom:element owner-elem)) + (declare (string tm-id)) + (declare (TopicC owner-topic)) + (let ((content (child-nodes-or-text owner-elem :trim t)) + (root (elt (dom:child-nodes (dom:owner-document owner-elem)) 0)) + (err-pref "From make-isidorus-occurrence(): ")) + (when (and (not (stringp content)) + (> (length content) 0)) + (loop for property across content + when (isidorus-type-p property tm-id 'occurrence + :parent-xml-base owner-xml-base) + collect + (let ((xml-base (get-xml-base property + :old-base owner-xml-base))) + (let ((nodes + (let ((nodeID (nodeID-of-property-or-child property))) + (if nodeID + (get-all-isidorus-nodes-by-id + nodeID root *tm2rdf-occurrence-type-uri*) + (list (self-or-child-node + property *tm2rdf-occurrence-type-uri* + :xml-base xml-base)))))) + (let ((item-identities + (remove-if #'null + (loop for node in nodes + append (make-isidorus-identifiers + (getf node :elem) start-revision)))) + (occurrence-type (make-x-type + nodes tm-id start-revision + *tm2rdf-occurrencetype-property* + :document-id document-id)) + (value-and-datatype (make-value nodes tm-id)) + (occurrence-scopes (make-scopes nodes tm-id start-revision + :document-id document-id))) + (unless occurrence-type + (error "~aoccurrencetype is missing!" + err-pref)) + (make-construct 'OccurrenceC + :start-revision start-revision + :topic owner-topic + :themes occurrence-scopes + :item-identifiers item-identities + :instance-of occurrence-type + :charvalue (getf value-and-datatype :value) + :datatype (getf value-and-datatype + :datatype))))))))) + (defun make-isidorus-names (owner-elem owner-topic tm-id start-revision &key (owner-xml-base nil) (document-id *document-id*)) - "Creates all names of a resource node that are in a property isidorus:name + "Creates all names of resource nodes that are in a property isidorus:name and have the type isidorus:Name." (declare (dom:element owner-elem)) (declare (string tm-id)) (declare (TopicC owner-topic)) (let ((content (child-nodes-or-text owner-elem :trim t)) - (root (elt (dom:child-nodes (dom:owner-document owner-elem)) 0))) + (root (elt (dom:child-nodes (dom:owner-document owner-elem)) 0)) + (err-pref "From make-isidorus-name(): ")) (when (and (not (stringp content)) (> (length content) 0)) (loop for property across content @@ -163,7 +220,7 @@ (let ((xml-base (get-xml-base property :old-base owner-xml-base))) (let ((nodes - (let ((nodeID (get-ns-attribute property "nodeID"))) + (let ((nodeID (nodeID-of-property-or-child property))) (if nodeID (get-all-isidorus-nodes-by-id nodeID root *tm2rdf-name-type-uri*) @@ -175,11 +232,15 @@ (loop for node in nodes append (make-isidorus-identifiers (getf node :elem) start-revision)))) - (name-type (make-name-type nodes tm-id start-revision - :document-id document-id)) + (name-type (make-x-type nodes tm-id start-revision + *tm2rdf-nametype-property* + :document-id document-id)) (name-value (getf (make-value nodes tm-id) :value)) (name-scopes (make-scopes nodes tm-id start-revision :document-id document-id))) + (unless name-type + (error "~anametype is missing!" + err-pref)) (let ((this (make-construct 'NameC :start-revision start-revision @@ -200,7 +261,8 @@ (let ((root (when name-nodes (elt (dom:child-nodes - (dom:owner-document (getf (first name-nodes) :elem))) 0)))) + (dom:owner-document (getf (first name-nodes) :elem))) 0))) + (err-pref "From make-isidorus-variant(): ")) (remove-if #'null (loop for name-node in name-nodes @@ -237,7 +299,10 @@ (make-scopes nodes tm-id start-revision :document-id document-id) (themes owner-name))) ;XTM 2.0: 4.12 - (value-and-type (make-value nodes tm-id))) + (value-and-type (make-value nodes tm-id))) + (unless variant-scopes + (error "~ascope is missing!" + err-pref)) (make-construct 'VariantC :start-revision start-revision :item-identifiers item-identities @@ -336,7 +401,7 @@ -(defun make-name-type (node-list tm-id start-revision +(defun make-x-type (node-list tm-id start-revision uri-of-property &key (document-id *document-id*)) "Creates a topic stub that is the type of the name represented by the passed nodes." @@ -348,7 +413,7 @@ when (let ((prop-ns (dom:namespace-uri property)) (prop-name (get-node-name property))) (string= (concatenate-uri prop-ns prop-name) - *tm2rdf-nametype-property*)) + uri-of-property)) return property)) return (let ((content (child-nodes-or-text (getf node :elem) :trim t))) @@ -356,7 +421,7 @@ when (let ((prop-ns (dom:namespace-uri property)) (prop-name (get-node-name property))) (string= (concatenate-uri prop-ns prop-name) - *tm2rdf-nametype-property*)) + uri-of-property)) return (list :elem property :xml-base (get-xml-base property @@ -368,7 +433,7 @@ (let ((type-uri (get-ref-of-property (getf property :elem) tm-id (getf property :xml-base)))) (unless type-uri - (error "From make-name-type(): type-uri is missing!")) + (error "From make-x-type(): type-uri is missing!")) (with-tm (start-revision document-id tm-id) (make-topic-stub (getf type-uri :psi) nil (getf type-uri :topicid) nil start-revision @@ -430,7 +495,9 @@ (make-isidorus-names elem this tm-id start-revision :owner-xml-base xml-base :document-id document-id) - ;TDOD: create topic occurrences + (make-isidorus-occurrences + elem this tm-id start-revision + :owner-xml-base xml-base :document-id document-id) (make-literals this literals tm-id start-revision :document-id document-id) (make-associations Modified: trunk/src/xml/rdf/isidorus_constructs_tools.lisp ============================================================================== --- trunk/src/xml/rdf/isidorus_constructs_tools.lisp (original) +++ trunk/src/xml/rdf/isidorus_constructs_tools.lisp Wed Sep 2 10:15:46 2009 @@ -317,4 +317,19 @@ (list :elem (elt content 0) :xml-base (get-xml-base (elt content 0) :old-base xml-base)) (list :elem property-node - :xml-base xml-base)))) \ No newline at end of file + :xml-base xml-base)))) + + +(defun nodeID-of-property-or-child (elem) + "Returns either the nodeID of the given element or if tere isn't one + the nodeID of the element's first child node. If there is no nodeID + at all, nil is returned." + (declare (dom:element elem)) + (let ((elem-nodeID (get-ns-attribute elem "nodeID"))) + (if elem-nodeID + elem-nodeID + (let ((elem-content (child-nodes-or-text elem :trim t))) + (when (and (> (length elem-content) 0) + (not (stringp elem-content))) + (get-ns-attribute (elt elem-content 0) "nodeID")))))) + \ No newline at end of file