[isidorus-cvs] r128 - in trunk/src: . unit_tests xml/rdf
Lukas Giessmann
lgiessmann at common-lisp.net
Wed Sep 2 10:58:34 UTC 2009
Author: lgiessmann
Date: Wed Sep 2 06:58:33 2009
New Revision: 128
Log:
rdf-importer: added handling for the isidorus-types Topic, Name and Variant; currently importing isidorus:Association and isidorus:Role is missing
Modified:
trunk/src/constants.lisp
trunk/src/unit_tests/rdf_importer_test.lisp
trunk/src/xml/rdf/importer.lisp
trunk/src/xml/rdf/rdf_tools.lisp
Modified: trunk/src/constants.lisp
==============================================================================
--- trunk/src/constants.lisp (original)
+++ trunk/src/constants.lisp Wed Sep 2 06:58:33 2009
@@ -53,7 +53,14 @@
:*tm2rdf-associaiton-property*
:*tm2rdf-subjectIdentifier-property*
:*tm2rdf-itemIdentity-property*
- :*tm2rdf-subjectLocator-property*))
+ :*tm2rdf-subjectLocator-property*
+ :*tm2rdf-value-property*
+ :*tm2rdf-nametype-property*
+ :*tm2rdf-scope-property*
+ :*tm2rdf-varianttype-property*
+ :*tm2rdf-occurrencetype-property*
+ :*tm2rdf-roletype-property*
+ :*tm2rdf-associationtype-property*))
(in-package :constants)
@@ -144,3 +151,17 @@
(defparameter *tm2rdf-subjectLocator-property* (concatenate 'string *tm2rdf-ns* "subjectLocator"))
(defparameter *tm2rdf-itemIdentity-property* (concatenate 'string *tm2rdf-ns* "itemIdentity"))
+
+(defparameter *tm2rdf-value-property* (concatenate 'string *tm2rdf-ns* "value"))
+
+(defparameter *tm2rdf-nametype-property* (concatenate 'string *tm2rdf-ns* "nametype"))
+
+(defparameter *tm2rdf-scope-property* (concatenate 'string *tm2rdf-ns* "scope"))
+
+(defparameter *tm2rdf-varianttype-property* (concatenate 'string *tm2rdf-ns* "varianttype"))
+
+(defparameter *tm2rdf-occurrencetype-property* (concatenate 'string *tm2rdf-ns* "occurrencetype"))
+
+(defparameter *tm2rdf-roletype-property* (concatenate 'string *tm2rdf-ns* "roletype"))
+
+(defparameter *tm2rdf-associationtype-property* (concatenate 'string *tm2rdf-ns* "associationtype"))
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 06:58:33 2009
@@ -21,6 +21,7 @@
*tm2rdf-ns*
*xml-ns*
*xml-string*
+ *xml-uri*
*instance-psi*
*type-psi*
*type-instance-psi*
@@ -69,7 +70,9 @@
:test-xml-base
:test-get-type-psis
:test-get-all-type-psis
- :test-isidorus-type-p))
+ :test-isidorus-type-p
+ :test-get-all-isidorus-nodes-by-id
+ :test-import-isidorus-name))
(declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0)))
@@ -3256,6 +3259,227 @@
'rdf-importer::occurrence)))))))
+(test test-get-all-isidorus-nodes-by-id
+ "Tests the function get-all-isidorus-nodes-by-id."
+ (let ((doc-1
+ (concatenate 'string "<rdf:RDF xmlns:rdf=\"" *rdf-ns* "\" "
+ "xmlns:sw=\"http://test/arcs/\">"
+ " <rdf:Description rdf:nodeID=\"node-id-1\"/>"
+ " <rdf:Description rdf:nodeID=\"node-id-2\"/>"
+ " <rdf:Description rdf:nodeID=\"node-id-1\">"
+ " <sw:arc rdf:nodeID=\"node-id-2\"/>"
+ " </rdf:Description>"
+ " <rdf:Description rdf:nodeID=\"node-id-3\">"
+ " <sw:arc rdf:nodeID=\"node-id-1\"/>"
+ " <sw:arc rdf:nodeID=\"node-id-4\"/>"
+ " </rdf:Description>"
+ " <sw:Node rdf:nodeID=\"node-id-4\" "
+ " xml:base=\"http://base/\">"
+ " <sw:arc>"
+ " <rdf:Description rdf:nodeID=\"node-id-1\" "
+ " xml:base=\"suffix\"/>"
+ " </sw:arc>"
+ " </sw:Node>"
+ "</rdf:RDF>")))
+ (let ((root (elt (dom:child-nodes (cxml:parse doc-1
+ (cxml-dom:make-dom-builder)))
+ 0))
+ (description (concatenate 'string *rdf-ns* "Description"))
+ (sw-node "http://test/arcs/Node"))
+ (let ((node-id-1 (list
+ (list :elem (elt (rdf-importer::child-nodes-or-text
+ root) 0)
+ :xml-base nil)
+ (list :elem (elt (rdf-importer::child-nodes-or-text
+ root) 2)
+ :xml-base nil)
+ (list :elem (elt
+ (rdf-importer::child-nodes-or-text
+ (elt
+ (rdf-importer::child-nodes-or-text
+ (elt (rdf-importer::child-nodes-or-text
+ root) 4)) 0)) 0)
+ :xml-base "http://base/suffix")))
+ (node-id-2 (elt (rdf-importer::child-nodes-or-text root) 1))
+ (node-id-3 (elt (rdf-importer::child-nodes-or-text root) 3))
+ (node-id-4 (elt (rdf-importer::child-nodes-or-text root) 4)))
+ (is (= (length (rdf-importer::child-nodes-or-text root)) 5))
+ (is (= (length (rdf-importer::get-all-isidorus-nodes-by-id
+ "node-id-3" root nil)) 1))
+ (is (eql (getf (first (rdf-importer::get-all-isidorus-nodes-by-id
+ "node-id-3" root nil)) :elem)
+ node-id-3))
+ (is (= (length (rdf-importer::get-all-isidorus-nodes-by-id
+ "node-id-2" root nil)) 1))
+ (is (eql (getf (first (rdf-importer::get-all-isidorus-nodes-by-id
+ "node-id-2" root description)) :elem)
+ node-id-2))
+ (is (eql (getf (first (rdf-importer::get-all-isidorus-nodes-by-id
+ "node-id-4" root sw-node)) :elem)
+ node-id-4))
+ (is (string= (getf (first (rdf-importer::get-all-isidorus-nodes-by-id
+ "node-id-4" root sw-node)) :xml-base)
+ "http://base/"))
+ (is (= (length (intersection
+ node-id-1
+ (rdf-importer::get-all-isidorus-nodes-by-id
+ "node-id-1" root description)
+ :test #'(lambda(x y)
+ (and (eql (getf x :elem) (getf y :elem))
+ (string= (getf x :xml-base)
+ (getf y :xml-base))))))
+ (length node-id-1)))))))
+
+
+(test test-import-isidorus-name
+ "Tests all functions that are responsible to import a resource
+ representing isidorus:Name."
+ (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\">"
+ " <isi:subjectIdentifier>http://topic-psi-1</isi:subjectIdentifier>"
+ " <isi:subjectLocator>http://topic-sl-1</isi:subjectLocator>"
+ " <isi:itemIdentity>http://topic-ii-1</isi:itemIdentity>"
+ " <sw:arc rdf:resource=\"http://resource-1\"/>"
+ " <isi:name>"
+ " <isi:Name>"
+ " <isi:itemIdentity>http://itemIdentity-1</isi:itemIdentity>"
+ " <isi:itemIdentity>http://itemIdentity-2</isi:itemIdentity>"
+ " <isi:scope rdf:resource=\"http://scope-1\"/>"
+ " <isi:scope rdf:resource=\"http://scope-2\"/>"
+ " <isi:value rdf:datatype=\"anyDatatype\">value-1</isi:value>"
+ " <isi:nametype rdf:resource=\"http://nametype-1\"/>"
+ " <isi:variant rdf:nodeID=\"variant-1\"/>"
+ " </isi:Name>"
+ " </isi:name>"
+ " <isi:name rdf:parseType=\"Resource\">"
+ " <rdf:type rdf:resource=\"" *tm2rdf-name-type-uri* "\"/>"
+ " <isi:itemIdentity>http://itemIdentity-4</isi:itemIdentity>"
+ " <isi:value rdf:datatype=\"anyDatatype\">value-3</isi:value>"
+ " <isi:nametype rdf:resource=\"http://nametype-2\"/>"
+ " <isi:variant rdf:parseType=\"Resource\">"
+ " <rdf:type>"
+ " <rdf:Description rdf:about=\"" *tm2rdf-variant-type-uri* "\"/>"
+ " </rdf:type>"
+ " <isi:value>value-4</isi:value>"
+ " <isi:scope>"
+ " <rdf:Description rdf:about=\"http://scope-3\"/>"
+ " </isi:scope>"
+ " </isi:variant>"
+ " </isi:name>"
+ " </rdf:Description>"
+
+ " <rdf:Description rdf:nodeID=\"variant-1\">"
+ " <isi:scope rdf:resource=\"http://scope-3\"/>"
+ " <isi:value rdf:datatype=\"dt-2\">value-2</isi:value>"
+ " </rdf:Description>"
+
+ " <rdf:Description rdf:nodeID=\"variant-1\">"
+ " <isi:itemIdentity rdf:datatype=\"" *xml-uri* "\">http://itemIdentity-3</isi:itemIdentity>"
+ " <rdf:type rdf:resource=\"" *tm2rdf-variant-type-uri* "\"/>"
+ " <isi:scope rdf:resource=\"http://scope-4\"/>"
+ " </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)) 3))
+ (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:NameC)) 2))
+ (is (= (length (elephant:get-instances-by-class 'd:VariantC)) 2))
+ (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 27))
+ (is-false (find-if #'(lambda(x)
+ (not (d:psis x)))
+ (elephant:get-instances-by-class 'd:TopicC)))
+ (is-true (d:get-item-by-psi "http://node-1"))
+ (is-true (d:get-item-by-psi "http://topic-psi-1"))
+ (is-true (d:get-item-by-psi "http://resource-1"))
+ (is-true (d:get-item-by-psi "http://scope-1"))
+ (is-true (d:get-item-by-psi "http://scope-2"))
+ (is-true (d:get-item-by-psi "http://scope-3"))
+ (is-true (d:get-item-by-psi "http://scope-4"))
+ (is-true (d:get-item-by-psi "http://nametype-1"))
+ (is-true (d:get-item-by-psi "http://nametype-1"))
+ (is-true (d:get-item-by-psi "http://test/arcs/arc"))
+ (let ((top (d:get-item-by-psi "http://node-1"))
+ (nt-1 (d:get-item-by-psi "http://nametype-1"))
+ (nt-2 (d:get-item-by-psi "http://nametype-2"))
+ (scope-1 (d:get-item-by-psi "http://scope-1"))
+ (scope-2 (d:get-item-by-psi "http://scope-2"))
+ (scope-3 (d:get-item-by-psi "http://scope-3"))
+ (scope-4 (d:get-item-by-psi "http://scope-4")))
+ (is (= (length (d:psis top)) 2))
+ (is-true (find (elephant:get-instance-by-value 'd:PersistentIdC 'd:uri
+ "http://topic-psi-1")
+ (d:psis top)))
+ (is (= (length (d:item-identifiers top)) 1))
+ (is (string= (d:uri (first (d:item-identifiers top)))
+ "http://topic-ii-1"))
+ (is (= (length (d:locators top)) 1))
+ (is (string= (d:uri (first (d:locators top)))
+ "http://topic-sl-1"))
+ (is (= (length (d:names top)) 2))
+ (let ((name-1 (find-if #'(lambda(x)
+ (eql (d:instance-of x) nt-1))
+ (d:names top)))
+ (name-2 (find-if #'(lambda(x)
+ (eql (d:instance-of x) nt-2))
+ (d:names top))))
+ (is-true name-1)
+ (is-true name-2)
+ (is (= (length (d:item-identifiers name-1)) 2))
+ (is (= (length
+ (intersection
+ (d:item-identifiers name-1)
+ (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 (d:item-identifiers name-2)) 1))
+ (is (string= (d:uri (first (d:item-identifiers name-2)))
+ "http://itemIdentity-4"))
+ (is (= (length (d:themes name-1)) 2))
+ (is (= (length (intersection (list scope-1 scope-2)
+ (d:themes name-1)))
+ 2))
+ (is-false (d:themes name-2))
+ (is (string= (d:charvalue name-1) "value-1"))
+ (is (string= (d:charvalue name-2) "value-3"))
+ (is (= (length (d:variants name-1)) 1))
+ (is (= (length (d:variants name-2)) 1))
+ (let ((variant-1 (first (d:variants name-1)))
+ (variant-2 (first (d:variants name-2))))
+ (is (= (length (d:item-identifiers variant-1)) 1))
+ (is (string= (d:uri (first (d:item-identifiers variant-1)))
+ "http://itemIdentity-3"))
+ (is-false (d:item-identifiers variant-2))
+ (is (= (length (d:themes variant-1)) 4))
+ (is (= (length (intersection (list scope-3 scope-4
+ scope-1 scope-2)
+ (d:themes variant-1)))
+ 4))
+ (is (= (length (d:themes variant-2)) 1))
+ (is (eql scope-3 (first (d:themes variant-2))))
+ (is (string= (d:charvalue variant-1)
+ "value-2"))
+ (is (string= (d:charvalue variant-2)
+ "value-4"))
+ (is (string= (d:datatype variant-1)
+ (concatenate 'string tm-id "/dt-2")))
+ (is (string= (d:datatype variant-2)
+ *xml-string*))))))))
+
+
+
(defun run-rdf-importer-tests()
"Runs all defined tests."
(when elephant:*store-controller*
@@ -3281,4 +3505,6 @@
(it.bese.fiveam:run! 'test-xml-base)
(it.bese.fiveam:run! 'test-get-type-psis)
(it.bese.fiveam:run! 'test-get-all-type-psis)
- (it.bese.fiveam:run! 'test-isidorus-type-p))
\ No newline at end of file
+ (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
Modified: trunk/src/xml/rdf/importer.lisp
==============================================================================
--- trunk/src/xml/rdf/importer.lisp (original)
+++ trunk/src/xml/rdf/importer.lisp Wed Sep 2 06:58:33 2009
@@ -84,6 +84,7 @@
(let ((children (child-nodes-or-text rdf-dom :trim t)))
(when children
(loop for child across children
+ when (non-isidorus-type-p child tm-id :parent-xml-base xml-base)
do (import-node child tm-id start-revision :document-id document-id
:xml-base xml-base :xml-lang xml-lang))))
(import-node rdf-dom tm-id start-revision :document-id document-id
@@ -96,31 +97,37 @@
(format t ">> import-node: ~a <<~%" (dom:node-name elem)) ;TODO: remove
(tm-id-p tm-id "import-node")
(parse-node elem)
- (let ((fn-xml-lang (get-xml-lang elem :old-lang xml-lang)))
+ (let ((fn-xml-lang (get-xml-lang elem :old-lang xml-lang))
+ (fn-xml-base (get-xml-base elem :old-base xml-base)))
(let ((about (get-absolute-attribute elem tm-id xml-base "about"))
(nodeID (get-ns-attribute elem "nodeID"))
(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
(let ((literals (append (get-literals-of-node elem fn-xml-lang)
(get-literals-of-node-content
elem tm-id xml-base fn-xml-lang)))
(associations (get-associations-of-node-content elem tm-id xml-base))
(types (get-types-of-node elem tm-id :parent-xml-base xml-base))
(super-classes
- (get-super-classes-of-node-content elem tm-id xml-base)))
- ;TODO: collect isidorus' subjectIdentifiers, itemIdentities,
- ; subjectLocators, names and occurrences
- ; add the collected constructs to the topic-stub
-
- ;TODO: collect associations and association roles and create the
- ; corresponding constructs and stops the recusrion
+ (get-super-classes-of-node-content elem tm-id xml-base))
+ (subject-identities (make-isidorus-identifiers
+ elem start-revision :what "subjectIdentifier"))
+ (item-identifiers (make-isidorus-identifiers elem start-revision))
+ (subject-locators (make-isidorus-identifiers elem start-revision
+ :what "subjectLocator")))
(with-tm (start-revision document-id tm-id)
(let ((this
(make-topic-stub
about ID nodeID UUID start-revision xml-importer::tm
- :document-id document-id)))
+ :document-id document-id
+ :additional-subject-identifiers subject-identities
+ :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
(make-literals this literals tm-id start-revision
:document-id document-id)
(make-associations this associations xml-importer::tm
@@ -136,6 +143,257 @@
this))))))
+
+(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
+ 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)))
+ (when (and (not (stringp content))
+ (> (length content) 0))
+ (loop for property across content
+ when (isidorus-type-p property tm-id 'name
+ :parent-xml-base owner-xml-base)
+ collect
+ (let ((xml-base (get-xml-base property
+ :old-base owner-xml-base)))
+ (let ((nodes
+ (let ((nodeID (get-ns-attribute property "nodeID")))
+ (if nodeID
+ (get-all-isidorus-nodes-by-id
+ nodeID root *tm2rdf-name-type-uri*)
+ (list (self-or-child-node
+ property *tm2rdf-name-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))))
+ (name-type (make-name-type nodes tm-id start-revision
+ :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)))
+ ;(format t "ii: ~a~%type: ~a~%value: ~a~%scopes: ~a~%~%"
+ ; item-identities name-type name-value name-scopes)
+ (let ((this
+ (make-construct 'NameC
+ :start-revision start-revision
+ :topic owner-topic
+ :charvalue name-value
+ :instance-of name-type
+ :item-identifiers item-identities
+ :themes name-scopes)))
+ (make-isidorus-variants nodes this tm-id start-revision
+ :document-id document-id)))))))))
+
+
+(defun make-isidorus-variants (name-nodes owner-name tm-id start-revision
+ &key (document-id *document-id*))
+ "Creates name variants of the passed name-nodes."
+ (declare (NameC owner-name))
+ (declare (string tm-id))
+ (let ((root
+ (when name-nodes
+ (elt (dom:child-nodes
+ (dom:owner-document (getf (first name-nodes) :elem))) 0))))
+ (remove-if
+ #'null
+ (loop for name-node in name-nodes
+ collect (let ((content (child-nodes-or-text (getf name-node :elem))))
+ (when (and (not (stringp content))
+ (> (length content) 0))
+ (loop for property across content
+ when (isidorus-type-p
+ property tm-id 'variant
+ :parent-xml-base (getf name-node :xml-base))
+ collect
+ (let ((nodes
+ (let ((nodeID
+ (get-ns-attribute property "nodeID")))
+ (if nodeID
+ (get-all-isidorus-nodes-by-id
+ nodeID root *tm2rdf-name-type-uri*)
+ (list (self-or-child-node
+ property
+ *tm2rdf-variant-type-uri*
+ :xml-base
+ (get-xml-base
+ property
+ :old-base
+ (getf name-node :xml-base))))))))
+ (let ((item-identities
+ (remove-if
+ #'null
+ (loop for node in nodes
+ append (make-isidorus-identifiers
+ (getf node :elem) start-revision))))
+ (variant-scopes
+ (append
+ (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)))
+ (make-construct 'VariantC
+ :start-revision start-revision
+ :item-identifiers item-identities
+ :themes variant-scopes
+ :charvalue
+ (getf value-and-type :value)
+ :datatype
+ (getf value-and-type :datatype)
+ :name owner-name))))))))))
+
+
+(defun self-or-child-node (property-node type-uri &key (xml-base))
+ "Returns either the passed node or the child-node when it is
+ rdf:Description."
+ (declare (dom:element property-node))
+ (let ((content (child-nodes-or-text property-node :trim t)))
+ (if (and (= (length content) 1)
+ (or (and (string= (dom:namespace-uri (elt content 0)) *rdf-ns*)
+ (string= (get-node-name (elt content 0)) "Description"))
+ (string= (concatenate-uri (dom:namespace-uri (elt content 0))
+ (get-node-name (elt content 0)))
+ type-uri)))
+ (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))))
+
+
+(defun make-scopes (node-list tm-id start-revision
+ &key (document-id *document-id*))
+ "Creates for every found scope a corresponding topic stub."
+ (let ((properties
+ (remove-if
+ #'null
+ (loop for node in node-list
+ append (let ((content (child-nodes-or-text (getf node :elem)
+ :trim t)))
+ (loop for property across content
+ when (let ((prop-ns (dom:namespace-uri property))
+ (prop-name (get-node-name property)))
+ (string= (concatenate-uri prop-ns prop-name)
+ *tm2rdf-scope-property*))
+ collect (list :elem property
+ :xml-base (get-xml-base
+ property
+ :old-base
+ (getf node :xml-base)))))))))
+ (let ((scope-uris
+ (remove-if #'null
+ (map 'list #'(lambda(x)
+ (get-ref-of-property (getf x :elem) tm-id
+ (getf x :xml-base)))
+ properties))))
+ (with-tm (start-revision document-id tm-id)
+ (map 'list #'(lambda(x)
+ (let ((topicid (getf x :topicid))
+ (psi (getf x :psi)))
+ (make-topic-stub psi nil topicid nil start-revision
+ xml-importer::tm
+ :document-id document-id)))
+ scope-uris)))))
+
+
+(defun make-value (node-list tm-id)
+ "Returns the literal value of a property of the type isidorus:value."
+ (let ((property
+ (loop for node in node-list
+ when (or (let ((content (child-nodes-or-text (getf node :elem)
+ :trim t)))
+ (loop for property across content
+ when (let ((prop-ns (dom:namespace-uri property))
+ (prop-name (get-node-name property)))
+ (string= (concatenate-uri prop-ns prop-name)
+ *tm2rdf-value-property*))
+ return property))
+ (get-ns-attribute (getf node :elem)
+ "value" :ns-uri *tm2rdf-ns*))
+ return (or (let ((content (child-nodes-or-text (getf node :elem)
+ :trim t)))
+ (loop for property across content
+ when (let ((prop-ns (dom:namespace-uri property))
+ (prop-name (get-node-name property)))
+ (string= (concatenate-uri prop-ns prop-name)
+ *tm2rdf-value-property*))
+ return property))
+ (get-ns-attribute (getf node :elem)
+ "value" :ns-uri *tm2rdf-ns*)))))
+ (if property
+ (if (stringp property)
+ (list :value property :datatype *xml-string*)
+ (let ((prop-content (child-nodes-or-text property))
+ (type (let ((dt
+ (get-datatype
+ property tm-id
+ (find-if #'(lambda(x)
+ (eql property (getf x :elem)))
+ node-list))))
+ (if dt dt *xml-string*))))
+ (cond
+ ((= (length prop-content) 0)
+ (list :value "" :datatype type))
+ ((not (stringp prop-content)) ;must be an element
+ (let ((text-val ""))
+ (when (dom:child-nodes property)
+ (loop for content-node across
+ (dom:child-nodes property)
+ do (push-string
+ (node-to-string content-node)
+ text-val)))
+ (list :value text-val :datatype type)))
+ (t (list :value prop-content :datatype type)))))
+ (list :value "" :datatype *xml-string*))))
+
+
+
+(defun make-name-type (node-list tm-id start-revision
+ &key (document-id *document-id*))
+ "Creates a topic stub that is the type of the name represented by the
+ passed nodes."
+ (let ((property
+ (loop for node in node-list
+ when (let ((content (child-nodes-or-text (getf node :elem)
+ :trim t)))
+ (loop for property across content
+ when (let ((prop-ns (dom:namespace-uri property))
+ (prop-name (get-node-name property)))
+ (string= (concatenate-uri prop-ns prop-name)
+ *tm2rdf-nametype-property*))
+ return property))
+ return (let ((content (child-nodes-or-text (getf node :elem)
+ :trim t)))
+ (loop for property across content
+ when (let ((prop-ns (dom:namespace-uri property))
+ (prop-name (get-node-name property)))
+ (string= (concatenate-uri prop-ns prop-name)
+ *tm2rdf-nametype-property*))
+ return (list
+ :elem property
+ :xml-base (get-xml-base property
+ :old-base
+ (getf
+ node
+ :xml-base))))))))
+ (when property
+ (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!"))
+ (with-tm (start-revision document-id tm-id)
+ (make-topic-stub (getf type-uri :psi) nil
+ (getf type-uri :topicid) nil start-revision
+ xml-importer::tm :document-id document-id))))))
+
+
(defun import-arc (elem tm-id start-revision
&key (document-id *document-id*)
(xml-base nil) (xml-lang nil))
@@ -144,7 +402,6 @@
(declare (dom:element elem))
(format t ">> import-arc: ~a <<~%" (dom:node-name elem)) ;TODO: remove
(let ((fn-xml-lang (get-xml-lang elem :old-lang xml-lang))
- (fn-xml-base (get-xml-base elem :old-base xml-base))
(UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*))
(parseType (get-ns-attribute elem "parseType"))
(content (child-nodes-or-text elem :trim t)))
@@ -159,42 +416,51 @@
(string/= parseType "Collection")))
(when UUID
(parse-properties-of-node elem UUID)
- (let ((this
- (get-item-by-id UUID :xtm-id document-id
- :revision start-revision)))
- (let ((literals
- (append (get-literals-of-property
- elem fn-xml-lang)
- (get-literals-of-node-content
- elem tm-id xml-base fn-xml-lang)))
- (associations
- (get-associations-of-node-content
- elem tm-id xml-base))
- (types
- (remove-if
- #'null
- (append
- (get-types-of-node-content elem tm-id fn-xml-base)
- (when (get-ns-attribute elem "type")
- (list :ID nil
- :topicid (get-ns-attribute elem "type")
- :psi (get-ns-attribute elem "type"))))))
- (super-classes
- (get-super-classes-of-node-content
- elem tm-id xml-base)))
- ;TODO: collect isidorus' subjectIdentifiers, itemIdentities,
- ; subjectLocators, names and occurrences
- ; add the collected constructs to the topic-stub
- (make-literals this literals tm-id start-revision
- :document-id document-id)
- (make-associations this associations xml-importer::tm
- start-revision :document-id document-id)
- (make-types this types xml-importer::tm start-revision
- :document-id document-id)
- (make-super-classes
- this super-classes xml-importer::tm
- start-revision :document-id document-id))
- this)))))
+ (let ((subject-identifiers
+ (make-isidorus-identifiers
+ elem start-revision :what "subjectIdentifier"))
+ (item-identities
+ (make-isidorus-identifiers elem start-revision))
+ (subject-locators
+ (make-isidorus-identifiers elem start-revision
+ :what "subjectLocator")))
+ (let ((this
+ (make-topic-stub
+ nil nil nil UUID start-revision xml-importer::tm
+ :additional-subject-identifiers
+ subject-identifiers
+ :item-identifiers item-identities
+ :subject-locators subject-locators
+ :document-id document-id)))
+ (let ((literals
+ (append (get-literals-of-property
+ elem fn-xml-lang)
+ (get-literals-of-node-content
+ elem tm-id xml-base fn-xml-lang)))
+ (associations
+ (get-associations-of-node-content
+ elem tm-id xml-base))
+ (types (get-types-of-property
+ elem tm-id
+ :parent-xml-base xml-base))
+ (super-classes
+ (get-super-classes-of-node-content
+ elem tm-id xml-base)))
+ (make-isidorus-names elem this tm-id start-revision
+ :owner-xml-base xml-base
+ :document-id document-id)
+ ;TDOD: create topic occurrences
+ (make-literals this literals tm-id start-revision
+ :document-id document-id)
+ (make-associations
+ this associations xml-importer::tm
+ start-revision :document-id document-id)
+ (make-types this types xml-importer::tm start-revision
+ :document-id document-id)
+ (make-super-classes
+ this super-classes xml-importer::tm
+ start-revision :document-id document-id))
+ this))))))
(make-recursion-from-arc elem tm-id start-revision
:document-id document-id
:xml-base xml-base :xml-lang xml-lang)
@@ -276,7 +542,7 @@
(map 'list #'(lambda(literal)
(make-occurrence owner-top literal start-revision
tm-id :document-id document-id))
- literals))
+ (filter-isidorus-literals literals)))
(defun make-associations (owner-top associations tm start-revision
@@ -408,7 +674,9 @@
(defun make-topic-stub (about ID nodeId UUID start-revision
- tm &key (document-id *document-id*))
+ tm &key (document-id *document-id*)
+ (additional-subject-identifiers nil)
+ (item-identifiers nil) (subject-locators nil))
"Returns a topic corresponding to the passed parameters.
When the searched topic does not exist there will be created one.
If about or ID is set there will also be created a new PSI."
@@ -429,15 +697,23 @@
inner-top))))
(if top
top
- (let ((psi (when psi-uri
- (make-instance 'PersistentIdC
- :uri psi-uri
- :start-revision start-revision))))
+ (let ((psis (if psi-uri
+ (remove-if
+ #'null
+ (append
+ (list
+ (make-instance 'PersistentIdC
+ :uri psi-uri
+ :start-revision start-revision))
+ additional-subject-identifiers))
+ additional-subject-identifiers)))
(handler-case (add-to-topicmap
tm
(make-construct 'TopicC
:topicid topic-id
- :psis (when psi (list psi))
+ :psis psis
+ :item-identifiers item-identifiers
+ :locators subject-locators
:xtm-id document-id
:start-revision start-revision))
(Condition (err)(error "Creating topic ~a failed: ~a"
@@ -917,4 +1193,46 @@
collect (import-node item tm-id start-revision
:document-id document-id
:xml-base xml-base
- :xml-lang xml-lang))))))))
\ No newline at end of file
+ :xml-lang xml-lang))))))))
+
+
+(defun make-isidorus-identifiers (owner-elem start-revision &key (what "itemIdentity"))
+ "Returns a list oc created identifier objects that can be
+ used directly in make-topic-stub."
+ (declare (dom:element owner-elem))
+ (declare (string what))
+ (when (and (string/= what "itemIdentity")
+ (string/= what "subjectIdentifier")
+ (string/= what "subjectLocator"))
+ (error "From make-identifiers(): what must be set to: ~a but is ~a"
+ (list "itemIdentity" "subjectIdentifiers" "subjectLocator")
+ what))
+ (let ((content (child-nodes-or-text owner-elem :trim t))
+ (class-symbol (cond
+ ((string= what "itemIdentity")
+ 'ItemIdentifierC)
+ ((string= what "subjectIdentifier")
+ 'PersistentIdC)
+ ((string= what "subjectLocator")
+ 'SubjectLocatorC))))
+ (unless (stringp content)
+ (let ((identifiers
+ (loop for property across content
+ when (let ((prop-ns (dom:namespace-uri property))
+ (prop-name (get-node-name property))
+ (prop-content (child-nodes-or-text property :trim t)))
+ (and (string= prop-ns *tm2rdf-ns*)
+ (string= prop-name what)
+ (stringp prop-content)
+ (> (length prop-content) 0)))
+ collect (let ((uri (child-nodes-or-text property :trim t)))
+ (make-instance class-symbol
+ :uri uri
+ :start-revision start-revision))))
+ (identifier-attr
+ (let ((attr (get-ns-attribute owner-elem what :ns-uri *tm2rdf-ns*)))
+ (when attr
+ (list (make-instance class-symbol
+ :uri attr
+ :start-revision start-revision))))))
+ (remove-if #'null (append identifiers identifier-attr))))))
\ No newline at end of file
Modified: trunk/src/xml/rdf/rdf_tools.lisp
==============================================================================
--- trunk/src/xml/rdf/rdf_tools.lisp (original)
+++ trunk/src/xml/rdf/rdf_tools.lisp Wed Sep 2 06:58:33 2009
@@ -45,7 +45,15 @@
*tm2rdf-association-property*
*tm2rdf-subjectIdentifier-property*
*tm2rdf-itemIdentity-property*
- *tm2rdf-subjectLocator-property*)
+ *tm2rdf-subjectLocator-property*
+ *tm2rdf-ns*
+ *tm2rdf-value-property*
+ *tm2rdf-nametype-property*
+ *tm2rdf-scope-property*
+ *tm2rdf-varianttype-property*
+ *tm2rdf-occurrencetype-property*
+ *tm2rdf-roletype-property*
+ *tm2rdf-associationtype-property*)
(:import-from :xml-constants
*rdf_core_psis.xtm*
*core_psis.xtm*)
@@ -290,6 +298,29 @@
:psi (or ID about)))))))
+(defun get-ref-of-property (property-elem tm-id xml-base)
+ "Returns a plist of the form (:topicid <string> :psi <string>).
+ That contains the property's value."
+ (declare (dom:element property-elem))
+ (declare (string tm-id))
+ (let ((nodeId (get-ns-attribute property-elem "nodeID"))
+ (resource (get-ns-attribute property-elem "resource"))
+ (content (let ((node-refs
+ (get-node-refs (child-nodes-or-text property-elem)
+ tm-id xml-base)))
+ (when node-refs
+ (first node-refs)))))
+ (cond
+ (nodeID
+ (list :topicid nodeID
+ :psi nil))
+ (resource
+ (list :topicid resource
+ :psi resource))
+ (content
+ content))))
+
+
(defun parse-property-name (property owner-identifier)
"Parses the given property's name to the known rdf/rdfs nodes and arcs.
If the given name es equal to an node an error is thrown otherwise
@@ -501,6 +532,19 @@
(get-types-of-node-content elem tm-id xml-base)))))
+(defun get-types-of-property (elem tm-id &key (parent-xml-base nil))
+ "Returns a plist of all property's types of the form
+ (:topicid <string> :psi <string> :ID <string>)."
+ (let ((xml-base (get-xml-base elem :old-base parent-xml-base)))
+ (remove-if #'null
+ (append
+ (get-types-of-node-content elem tm-id xml-base)
+ (when (get-ns-attribute elem "type")
+ (list :ID nil
+ :topicid (get-ns-attribute elem "type")
+ :psi (get-ns-attribute elem "type")))))))
+
+
(defun get-type-psis (elem tm-id
&key (parent-xml-base nil))
"Returns a list of type-uris of the passed node."
@@ -617,6 +661,34 @@
(string= uri property-name-uri))))
+(defun non-isidorus-type-p (elem tm-id &key (parent-xml-base nil)
+ (ignore-topic nil))
+ "Returns t if the passed element is not of an isidorus' type.
+ The environmental property is not analysed by this function!"
+ (declare (dom:element elem))
+ (declare (string tm-id))
+ (let ((nodeID (get-ns-attribute elem "nodeID"))
+ (document (dom:owner-document elem))
+ (types
+ (let ((b-types
+ (list
+ *tm2rdf-name-type-uri* *tm2rdf-variant-type-uri*
+ *tm2rdf-occurrence-type-uri* *tm2rdf-association-type-uri*
+ *tm2rdf-role-type-uri*))
+ (a-types (list *tm2rdf-topic-type-uri*)))
+ (if ignore-topic
+ b-types
+ (append a-types b-types)))))
+ (if nodeID
+ (not (loop for type in types
+ when (type-of-id-p nodeId type tm-id document)
+ return t))
+ (not (loop for type in types
+ when (type-p elem type tm-id
+ :parent-xml-base parent-xml-base)
+ return t)))))
+
+
(defun isidorus-type-p (property-elem-or-node-elem tm-id what
&key(parent-xml-base nil))
"Returns t if the node elem is of the type isidorus:<Type> and is
@@ -654,7 +726,16 @@
property-elem-or-node-elem)
(get-node-name property-elem-or-node-elem))))
(if (or (string= type *tm2rdf-topic-type-uri*)
- (string= type *tm2rdf-association-type-uri*))
+ (string= type *tm2rdf-association-type-uri*)
+ (let ((parseType (get-ns-attribute property-elem-or-node-elem
+ "parseType")))
+ (and parseType
+ (string= parseType "Resource")))
+ (get-ns-attribute property-elem-or-node-elem "type")
+ (get-ns-attribute property-elem-or-node-elem "value"
+ :ns-uri *tm2rdf-ns*)
+ (get-ns-attribute property-elem-or-node-elem "itemIdentity"
+ :ns-uri *tm2rdf-ns*))
(type-p property-elem-or-node-elem type tm-id
:parent-xml-base parent-xml-base)
(when (string= elem-uri property)
@@ -686,5 +767,85 @@
(string= x-uri *tm2rdf-role-property*)
(string= x-uri *tm2rdf-subjectIdentifier-property*)
(string= x-uri *tm2rdf-itemIdentity-property*)
+ (string= x-uri *tm2rdf-value-property*)
+ (string= x-uri *tm2rdf-scope-property*)
+ (string= x-uri *tm2rdf-nametype-property*)
+ (string= x-uri *tm2rdf-varianttype-property*)
+ (string= x-uri *tm2rdf-associationtype-property*)
+ (string= x-uri *tm2rdf-occurrencetype-property*)
+ (string= x-uri *tm2rdf-roletype-property*)
(string= x-uri *tm2rdf-subjectLocator-property*))))
- content))))
\ No newline at end of file
+ content))))
+
+
+(defun get-all-isidorus-nodes-by-id (node-id current-node type-uri
+ &key (parent-xml-base nil)
+ (collected-nodes nil))
+ "Returns a list of all nodes that own the given nodeID and are of
+ type type-uri, rdf:Description or when the rdf:parseType is set to
+ Resource or the isidorus:value attribute is set."
+ (declare (dom:element current-node))
+ (declare (string node-id))
+ (let ((datatype (when (get-ns-attribute current-node "datatype")
+ t))
+ (parseType (let ((attr (get-ns-attribute current-node "parseType")))
+ (when (and attr
+ (string= attr "Literal"))
+ t)))
+ (content (child-nodes-or-text current-node :trim t))
+ (xml-base (get-xml-base current-node :old-base parent-xml-base))
+ (nodeID (get-ns-attribute current-node "nodeID"))
+ (node-uri-p (let ((node-uri
+ (concatenate-uri (dom:namespace-uri current-node)
+ (get-node-name current-node)))
+ (description (concatenate 'string *rdf-ns*
+ "Description")))
+ (or (string= node-uri (if type-uri type-uri ""))
+ (string= node-uri description)
+ (get-ns-attribute current-node "type")
+ (get-ns-attribute current-node "value"
+ :ns-uri *tm2rdf-ns*)
+ (get-ns-attribute current-node "itemIdentity"
+ :ns-uri *tm2rdf-ns*)
+ (let ((parseType (get-ns-attribute current-node
+ "parseType")))
+ (when parseType
+ (string= parseType "Resource")))))))
+ (remove-duplicates
+ (remove-if
+ #'null
+ (if (or datatype parseType (stringp content) (not content))
+ (if (and (string= nodeID node-id) node-uri-p)
+ (append (list (list :elem current-node
+ :xml-base xml-base))
+ collected-nodes)
+ collected-nodes)
+ (if (and (string= nodeID node-id) node-uri-p)
+ (loop for item across content
+ append (get-all-isidorus-nodes-by-id
+ node-id item type-uri
+ :collected-nodes (append
+ (list (list :elem current-node
+ :xml-base xml-base))
+ collected-nodes)
+ :parent-xml-base xml-base))
+ (loop for item across content
+ append (get-all-isidorus-nodes-by-id
+ node-id item type-uri
+ :collected-nodes collected-nodes
+ :parent-xml-base xml-base)))))
+ :test #'(lambda(x y)
+ (eql (getf x :elem) (getf y :elem))))))
+
+
+(defun filter-isidorus-literals (literals)
+ "Removes all literals that are known isidorus properties which
+ are able to contain literal data."
+ (remove-if #'(lambda(x)
+ (or (string= (getf x :type)
+ *tm2rdf-subjectIdentifier-property*)
+ (string= (getf x :type)
+ *tm2rdf-itemIdentity-property*)
+ (string= (getf x :type)
+ *tm2rdf-subjectLocator-property*)))
+ literals))
\ No newline at end of file
More information about the Isidorus-cvs
mailing list