[isidorus-cvs] r130 - in trunk/src: unit_tests xml/rdf
Lukas Giessmann
lgiessmann at common-lisp.net
Wed Sep 2 14:15:47 UTC 2009
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
More information about the Isidorus-cvs
mailing list