[isidorus-cvs] r98 - in trunk/src: unit_tests xml/rdf xml/xtm
Lukas Giessmann
lgiessmann at common-lisp.net
Thu Jul 30 12:26:36 UTC 2009
Author: lgiessmann
Date: Thu Jul 30 08:26:23 2009
New Revision: 98
Log:
added more helpers and unit test ot the rdf-importer
Modified:
trunk/src/unit_tests/rdf_importer_test.lisp
trunk/src/xml/rdf/importer.lisp
trunk/src/xml/rdf/rdf_tools.lisp
trunk/src/xml/xtm/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 Thu Jul 30 08:26:23 2009
@@ -26,19 +26,26 @@
xpath-select-location-path
get-ns-attribute
absolute-uri-p)
- (:export :test-get-literals-of-node
+ (:export :rdf-importer-test
+ :test-get-literals-of-node
:test-parse-node
- :run-rdf-importer-tests))
+ :run-rdf-importer-tests
+ :test-get-literals-of-property
+ :test-parse-property
+ :test-get-types
+ :test-get-literals-of-content
+ :test-get-super-classes-of-node-content
+ :test-get-associations-of-node-content))
(declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0)))
(in-package :rdf-importer-test)
-(def-suite importer-test
+(def-suite rdf-importer-test
:description "tests various key functions of the importer")
-(in-suite importer-test)
+(in-suite rdf-importer-test)
(test test-get-literals-of-node
@@ -351,7 +358,6 @@
"<rdf:type rdf:ID=\"rdfID2\">"
"<rdf:Description rdf:about=\"c-about-type-2\"/>"
"</rdf:type>"
-
"<rdf:type>"
"<rdf:Description rdf:nodeID=\"c-nodeID-type-2\"/>"
"</rdf:type>"
@@ -361,7 +367,6 @@
"<rdf:type rdf:ID=\"rdfID3\">"
"<rdf:Description/>"
"</rdf:type>"
-
"<arcs:arc rdf:resource=\"anyArc\"/>"
"<rdf:arc>"
"<rdf:Description rdf:about=\"anyResource\"/>"
@@ -390,57 +395,54 @@
0)
"UUID" :ns-uri *rdf2tm-ns*)))
(is (= (length types) 10))
- (is-true (find-if #'(lambda(x)
- (and
- (string= (getf x :value)
- (concatenate
- 'string *rdf-ns* "anyType"))
- (not (getf x :ID))))
- types))
- (is-true (find-if #'(lambda(x)
- (and
- (string= (getf x :value)
- (concatenate
- 'string tm-id
- "/xml-base/first/attr-type"))
- (not (getf x :ID))))
- types))
- (is-true (find-if #'(lambda(x)
- (and (string=
- (getf x :value)
+ (is-true (find-if
+ #'(lambda(x)
+ (and (string= (getf x :value)
+ (concatenate
+ 'string *rdf-ns* "anyType"))
+ (not (getf x :ID))))
+ types))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (string= (getf x :value)
(concatenate
'string tm-id
- "/xml-base/first/content-type-1"))
- (string= (getf x :ID)
- "rdfID")))
- types))
- (is-true (find-if #'(lambda(x)
- (and (string=
- (getf x :value)
+ "/xml-base/first/attr-type"))
+ (not (getf x :ID))))
+ types))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (string= (getf x :value)
+ "http://test-tm/xml-base/first/content-type-1")
+ (string= (getf x :ID)
+ "http://test-tm/xml-base/first#rdfID")))
+ types))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (string= (getf x :value)
(concatenate
'string tm-id
"/xml-base/first/c-about-type-2"))
- (string= (getf x :ID)
- "rdfID2")))
- types))
- (is-true (find-if #'(lambda(x)
- (and
- (string= (getf x :value)
- "c-nodeID-type-2")
- (not (getf x :ID))))
- types))
- (is-true (find-if #'(lambda(x)
- (and
- (string= (getf x :value)
- "http://new-base#c-ID-type-2")
- (not (getf x :ID))))
- types))
- (is-true (find-if #'(lambda(x)
- (and
- (string= (getf x :value) node-uuid)
- (string= (getf x :ID)
- "rdfID3")))
- types))
+ (string= (getf x :ID)
+ "http://test-tm/xml-base/first#rdfID2")))
+ types))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (string= (getf x :value) "c-nodeID-type-2")
+ (not (getf x :ID))))
+ types))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (string= (getf x :value)
+ "http://new-base#c-ID-type-2")
+ (not (getf x :ID))))
+ types))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (string= (getf x :value) node-uuid)
+ (string= (getf x :ID)
+ "http://test-tm/xml-base/first#rdfID3")))
+ types))
(is-true (= 10 (count-if #'(lambda(x)
(> (length (getf x :value)) 0))
types))))))))
@@ -534,7 +536,8 @@
"<root><child>childText5</child> </root>")
(string= (getf x :type)
"http://isidorus/props/lit5")
- (string= (getf x :ID) "rdfID")
+ (string= (getf x :ID)
+ "http://test-tm/base/first#rdfID")
(string= (getf x :lang) "de")
(string= (getf x :datatype) *xml-string*)))
literals))
@@ -549,10 +552,234 @@
literals)))))))
+(test test-get-super-classes-of-node-content
+ (let ((doc-1
+ (concatenate 'string "<rdf:Description xmlns:rdf=\"" *rdf-ns* "\" "
+ "xmlns:isi=\"" *rdf2tm-ns* "\" "
+ "xmlns:rdfs=\"" *rdfs-ns* "\" "
+ "xmlns:arcs=\"http://test/arcs/\" "
+ "xml:base=\"xml-base/first\" "
+ "rdf:about=\"resource\" rdf:type=\"attr-type\">"
+ "<rdfs:subClassOf rdf:ID=\"rdfID\" "
+ "rdf:resource=\"content-type-1\"/>"
+ "<rdfs:subClassOf /><!-- blank_node -->"
+ "<rdfs:subClassOf arcs:arc=\"literalArc\"/>"
+ "<rdfs:subClassOf rdf:parseType=\"Collection\" "
+ " xml:base=\"http://xml-base/absolute/\">"
+ "<!-- blank_node that is a list -->"
+ "<rdf:Description rdf:about=\"c-about-type\"/>"
+ "<rdf:Description rdf:ID=\"c-id-type\"/>"
+ "<rdf:Description rdf:nodeID=\"c-nodeID-type\"/>"
+ "<rdf:Description/><!-- blank_node -->"
+ "</rdfs:subClassOf>"
+ "<rdfs:subClassOf rdf:ID=\"rdfID2\">"
+ "<rdf:Description rdf:about=\"c-about-type-2\"/>"
+ "</rdfs:subClassOf>"
+ "<rdfs:subClassOf>"
+ "<rdf:Description rdf:nodeID=\"c-nodeID-type-2\"/>"
+ "</rdfs:subClassOf>"
+ "<rdfs:subClassOf xml:base=\"http://new-base/\">"
+ "<rdf:Description rdf:ID=\"c-ID-type-2\"/>"
+ "</rdfs:subClassOf>"
+ "<rdfs:subClassOf rdf:ID=\"rdfID3\">"
+ "<rdf:Description/>"
+ "</rdfs:subClassOf>"
+ "<arcs:arc rdf:resource=\"anyArc\"/>"
+ "<rdfs:arc>"
+ "<rdf:Description rdf:about=\"anyResource\"/>"
+ "</rdfs:arc>"
+ "</rdf:Description>")))
+ (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder))))
+ (is-true dom-1)
+ (is (= (length (dom:child-nodes dom-1))))
+ (let ((node (elt (dom:child-nodes dom-1) 0))
+ (tm-id "http://test-tm")
+ (xml-base "/base/initial"))
+ (is-true node)
+ (is-true (rdf-importer::parse-node node))
+ (loop for property across (rdf-importer::child-nodes-or-text node)
+ do (is-true (rdf-importer::parse-property property)))
+ (let ((super-classes (rdf-importer::get-super-classes-of-node-content
+ node tm-id xml-base)))
+ (is (= (length super-classes) 8))
+ (is-true (find-if
+ #'(lambda(x)
+ (string= (getf x :ID)
+ "http://test-tm/base/initial/xml-base/first#rdfID"))
+ super-classes))
+ (is-true (map 'list
+ #'(lambda(x)
+ (and
+ (> (length (getf x :value)) 0)
+ (string=
+ (getf x :ID)
+ (concatenate 'string tm-id xml-base
+ "/xml-base/first/c-about-type-2"))))
+ super-classes))
+ (is-true (map 'list
+ #'(lambda(x)
+ (and (string= (getf x :value) "c-nodeID-type-2")
+ (not (getf x :ID))))
+ super-classes))
+ (is-true (map 'list
+ #'(lambda(x)
+ (and (string= (getf x :value)
+ "http://new/base#c-ID-type-2")
+ (not (getf x :ID))))
+ super-classes))
+ (is (= (count-if #'(lambda(x) (> (length (getf x :value)) 0))
+ super-classes)
+ 8))
+ (is-true (find-if #'(lambda(x)
+ (string= (getf x :ID)
+ "http://test-tm/base/initial/xml-base/first#rdfID3"))
+ super-classes))
+ (dom:append-child (elt (rdf-importer::child-nodes-or-text node) 1)
+ (dom:create-text-node dom-1 "new text"))
+ (signals error (rdf-importer::parse-property
+ (elt (rdf-importer::child-nodes-or-text node) 1))))))))
+
+
+(test test-get-associations-of-node-content
+ (let ((doc-1
+ (concatenate 'string "<rdf:Description xmlns:rdf=\"" *rdf-ns* "\" "
+ "xmlns:isi=\"" *rdf2tm-ns* "\" "
+ "xmlns:rdfs=\"" *rdfs-ns* "\" "
+ "xmlns:arcs=\"http://test/arcs/\" "
+ "xml:base=\"http://xml-base/first\" "
+ "rdf:about=\"resource\" rdf:type=\"attr-type\">"
+ "<rdf:type rdf:resource=\"anyType\" />"
+ "<rdf:type> </rdf:type>"
+ "<rdfs:subClassOf rdf:nodeID=\"anyClass\" />"
+ "<rdfs:subClassOf> </rdfs:subClassOf>"
+ "<rdf:unknown rdf:resource=\"assoc-1\"/>"
+ "<rdfs:unknown rdf:type=\"assoc-2-type\">"
+ " </rdfs:unknown>"
+ "<arcs:arc1 rdf:ID=\"rdfID-1\" "
+ "rdf:nodeID=\"arc1-nodeID\"/>"
+ "<arcs:arc2 rdf:parseType=\"Collection\">"
+ "<rdf:Description rdf:about=\"col\" />"
+ "</arcs:arc2>"
+ "<arcs:arc3 rdf:parseType=\"Resource\" "
+ "rdf:ID=\"rdfID-2\" />"
+ "<arcs:lit rdf:parseType=\"Literal\" />"
+ "<arcs:arc4 arcs:arc5=\"text-arc5\" />"
+ "<arcs:arc6 rdf:ID=\"rdfID-3\">"
+ "<rdf:Description rdf:about=\"con-1\" />"
+ "</arcs:arc6>"
+ "<arcs:arc7>"
+ "<rdf:Description rdf:nodeID=\"con-2\" />"
+ "</arcs:arc7>"
+ "<arcs:arc8>"
+ "<rdf:Description rdf:ID=\"rdfID-4\" />"
+ "</arcs:arc8>"
+ "<arcs:arc9 rdf:ID=\"rdfID-5\" xml:base=\"add\">"
+ "<rdf:Description />"
+ "</arcs:arc9>"
+ "<rdfs:type rdf:resource=\"assoc-11\"> </rdfs:type>"
+ "<rdf:subClassOf rdf:nodeID=\"assoc-12\" />"
+ "</rdf:Description>")))
+ (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))
+ (tm-id "http://test-tm"))
+ (is-true dom-1)
+ (is (= (length (dom:child-nodes dom-1)) 1))
+ (let ((node (elt (dom:child-nodes dom-1) 0)))
+ (loop for property across (rdf-importer::child-nodes-or-text node)
+ do (is-true (rdf-importer::parse-property property)))
+ (let ((associations
+ (rdf-importer::get-associations-of-node-content node tm-id nil)))
+ (is (= (length associations) 12))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (string= (getf x :type)
+ (concatenate 'string *rdf-ns* "unknown"))
+ (string= (getf x :value)
+ "http://xml-base/first/assoc-1")
+ (not (getf x :ID))))
+ associations))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (string= (getf x :type) "http://test/arcs/arc1")
+ (string= (getf x :ID) "http://xml-base/first#rdfID-1")
+ (string= (getf x :value) "arc1-nodeID")))
+ associations))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (string= (getf x :type) "http://test/arcs/arc2")
+ (> (length (getf x :value)) 0)
+ (not (getf x :ID))))
+ associations))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (string= (getf x :type) "http://test/arcs/arc3")
+ (string= (getf x :ID)
+ "http://xml-base/first#rdfID-2")
+ (> (length (getf x :value)) 0)))
+ associations))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (string= (getf x :type) "http://test/arcs/arc4")
+ (not (getf x :ID))
+ (> (length (getf x :value)) 0)))
+ associations))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (string= (getf x :type) "http://test/arcs/arc4")
+ (not (getf x :ID))
+ (> (length (getf x :value)) 0)))
+ associations))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (string= (getf x :type) "http://test/arcs/arc6")
+ (string= (getf x :ID)
+ "http://xml-base/first#rdfID-3")
+ (string= (getf x :value)
+ "http://xml-base/first/con-1")))
+ associations))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (string= (getf x :type) "http://test/arcs/arc7")
+ (not (getf x :ID))
+ (string= (getf x :value) "con-2")))
+ associations))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (string= (getf x :type) "http://test/arcs/arc8")
+ (not (getf x :ID))
+ (string= (getf x :value)
+ "http://xml-base/first#rdfID-4")))
+ associations))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (string= (getf x :type) "http://test/arcs/arc9")
+ (string= (getf x :ID)
+ "http://xml-base/first/add#rdfID-5")
+ (> (length (getf x :value)))))
+ associations))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (string= (getf x :type)
+ (concatenate 'string *rdfs-ns* "type"))
+ (not (getf x :ID))
+ (string= (getf x :value)
+ "http://xml-base/first/assoc-11")))
+ associations))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (string= (getf x :type)
+ (concatenate 'string *rdf-ns*
+ "subClassOf"))
+ (not (getf x :ID))
+ (string= (getf x :value) "assoc-12")))
+ associations)))))))
+
+
(defun run-rdf-importer-tests()
(it.bese.fiveam:run! 'test-get-literals-of-node)
(it.bese.fiveam:run! 'test-parse-node)
(it.bese.fiveam:run! 'test-get-literals-of-property)
(it.bese.fiveam:run! 'test-parse-property)
(it.bese.fiveam:run! 'test-get-types)
- (it.bese.fiveam:run! 'test-get-literals-of-content))
\ No newline at end of file
+ (it.bese.fiveam:run! 'test-get-literals-of-content)
+ (it.bese.fiveam:run! 'test-get-super-classes-of-node-content)
+ (it.bese.fiveam:run! 'test-get-associations-of-node-content))
\ 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 Thu Jul 30 08:26:23 2009
@@ -45,9 +45,10 @@
(if (and (string= elem-ns *rdf-ns*)
(string= elem-name "RDF"))
(let ((children (child-nodes-or-text rdf-dom)))
- (loop for child across children
- do (import-node child tm-id :document-id document-id
- :xml-base xml-base :xml-lang xml-lang)))
+ (when children
+ (loop for child across children
+ do (import-node child tm-id :document-id document-id
+ :xml-base xml-base :xml-lang xml-lang))))
(import-node rdf-dom tm-id :document-id document-id
:xml-base xml-base :xml-lang xml-lang))))
@@ -58,24 +59,23 @@
(tm-id-p tm-id "import-node")
(parse-node elem)
(let ((fn-xml-base (get-xml-base elem :old-base xml-base)))
- (loop for property across (child-nodes-or-text elem)
- do (parse-property property))
- (let ((about
- (if (get-ns-attribute elem "about")
- (absolutize-value (get-ns-attribute elem "about")
- fn-xml-base tm-id)
- nil))
+ (when (child-nodes-or-text elem)
+ (loop for property across (child-nodes-or-text elem)
+ do (parse-property property)))
+ (let ((about (get-absolute-attribute elem tm-id xml-base "about"))
(nodeID (get-ns-attribute elem "nodeID"))
- (ID (get-ns-attribute elem "ID"))
+ (ID (get-absolute-attribute elem tm-id xml-base "ID"))
(UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*))
(literals (append (get-literals-of-node elem xml-lang)
(get-literals-of-node-content elem tm-id
xml-base xml-lang)))
- (associations nil)
+ (associations (get-associations-of-node-content elem tm-id xml-base))
(types (append (list
(list :value (get-type-of-node-name elem) :ID nil))
(get-types-of-node-content elem tm-id fn-xml-base)))
- (super-classes nil)) ;TODO: implement
+ (super-classes (get-super-classes-of-node-content elem tm-id xml-base)))
+ ;TODO: create elephant-objects
+ ;TODO: recursion on all nodes/arcs
(declare (ignorable about nodeID ID UUID literals associations ;TODO: remove
types super-classes)))))
@@ -88,14 +88,9 @@
(fn-xml-base (get-xml-base node :old-base xml-base))
(fn-xml-lang (get-xml-lang node :old-lang xml-lang)))
(let ((literals
- (loop for property across properties
- when (let ((prp-xml-base (get-xml-base property
- :old-base fn-xml-base)))
- (let ((datatype
- (when (get-ns-attribute property "datatype")
- (absolutize-value
- (get-ns-attribute property "datatype")
- prp-xml-base tm-id)))
+ (when properties
+ (loop for property across properties
+ when (let ((datatype (get-ns-attribute property "datatype"))
(parseType (get-ns-attribute property "parseType"))
(nodeID (get-ns-attribute property "nodeID"))
(resource (get-ns-attribute property "resource"))
@@ -103,41 +98,33 @@
:ns-uri *rdf2tm-ns*)))
(or (or datatype
(string= parseType "Literal"))
- (not (or nodeID resource UUID parseType)))))
- collect (let ((content (child-nodes-or-text property))
- (prp-xml-base (get-xml-base property
- :old-base fn-xml-base))
- (ID (get-ns-attribute property "ID"))
- (prp-name (get-node-name property))
- (prp-ns (dom:namespace-uri property))
- (child-xml-lang
- (get-xml-lang property :old-lang fn-xml-lang)))
- (let ((full-name (concatenate-uri prp-ns prp-name))
- (datatype
- (if (get-ns-attribute property "datatype")
- (absolutize-value
- (get-ns-attribute property "datatype")
- prp-xml-base tm-id)
- *xml-string*))
- (text
- (cond
- ((= (length content) 0)
- "")
- ((not (stringp content)) ;must be an element
- (let ((text-val ""))
- (loop for content-node across
- (dom:child-nodes property)
- do (push-string
- (node-to-string content-node)
- text-val))
- text-val))
- (t content))))
- (list :type full-name
- :value text
- :ID ID
- :lang child-xml-lang
- :datatype datatype))))))
-
+ (not (or nodeID resource UUID parseType))))
+ collect (let ((content (child-nodes-or-text property))
+ (ID (get-absolute-attribute property tm-id
+ fn-xml-base "ID"))
+ (child-xml-lang
+ (get-xml-lang property :old-lang fn-xml-lang)))
+ (let ((full-name (get-type-of-node-name property))
+ (datatype (get-datatype property tm-id fn-xml-base))
+ (text
+ (cond
+ ((= (length content) 0)
+ "")
+ ((not (stringp 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)))
+ text-val))
+ (t content))))
+ (list :type full-name
+ :value text
+ :ID ID
+ :lang child-xml-lang
+ :datatype datatype)))))))
literals)))
@@ -151,6 +138,7 @@
(defun get-types-of-node-content (node tm-id xml-base)
"Returns a list of type-uris that corresponds to the node's content
or attributes."
+ (tm-id-p tm-id "get-types-of-node-content")
(let ((fn-xml-base (get-xml-base node :old-base xml-base)))
(let ((attr-type
(if (get-ns-attribute node "type")
@@ -160,27 +148,27 @@
:ID nil))
nil))
(content-types
- (loop for child across (child-nodes-or-text node)
- when (and (string= (dom:namespace-uri child) *rdf-ns*)
- (string= (get-node-name child) "type"))
- collect (let ((nodeID (get-ns-attribute child "nodeID"))
- (resource (if (get-ns-attribute child "resource")
- (absolutize-value
- (get-ns-attribute child "resource")
- fn-xml-base tm-id)))
- (UUID (get-ns-attribute child "UUID"
- :ns-uri *rdf2tm-ns*))
- (ID (get-ns-attribute child "ID")))
- (if (or nodeID resource UUID)
- (list :value (or nodeID resource UUID)
- :ID ID)
- (let ((child-xml-base
- (get-xml-base child :old-base fn-xml-base)))
- (loop for ref in
- (get-node-refs (child-nodes-or-text child)
- tm-id child-xml-base)
- append (list :value ref
- :ID ID))))))))
+ (when (child-nodes-or-text node)
+ (loop for child across (child-nodes-or-text node)
+ when (and (string= (dom:namespace-uri child) *rdf-ns*)
+ (string= (get-node-name child) "type"))
+ collect (let ((nodeID (get-ns-attribute child "nodeID"))
+ (resource (get-absolute-attribute
+ child tm-id fn-xml-base "resource"))
+ (UUID (get-ns-attribute child "UUID"
+ :ns-uri *rdf2tm-ns*))
+ (ID (get-absolute-attribute child tm-id
+ fn-xml-base "ID")))
+ (if (or nodeID resource UUID)
+ (list :value (or nodeID resource UUID)
+ :ID ID)
+ (let ((child-xml-base
+ (get-xml-base child :old-base fn-xml-base)))
+ (loop for ref in
+ (get-node-refs (child-nodes-or-text child)
+ tm-id child-xml-base)
+ append (list :value ref
+ :ID ID)))))))))
(remove-if #'null (append attr-type content-types)))))
@@ -192,7 +180,7 @@
#'(lambda(attr)
(let ((attr-ns (dom:namespace-uri attr))
(attr-name (get-node-name attr)))
- (let ((l-type (concatenate-uri attr-ns attr-name))
+ (let ((l-type (get-type-of-node-name attr))
(l-value (if (get-ns-attribute property attr-name
:ns-uri attr-ns)
(get-ns-attribute property attr-name
@@ -236,7 +224,7 @@
#'(lambda(attr)
(let ((attr-ns (dom:namespace-uri attr))
(attr-name (get-node-name attr)))
- (let ((l-type (concatenate-uri attr-ns attr-name))
+ (let ((l-type (get-type-of-node-name attr))
(l-value (if (get-ns-attribute node attr-name :ns-uri attr-ns)
(get-ns-attribute node attr-name :ns-uri attr-ns)
"")))
@@ -268,3 +256,86 @@
attributes))
+(defun get-super-classes-of-node-content (node tm-id xml-base)
+ "Returns a list of super-classes and IDs."
+ (declare (dom:element node))
+ (tm-id-p tm-id "get-super-classes-of-node-content")
+ (let ((content (child-nodes-or-text node))
+ (fn-xml-base (get-xml-base node :old-base xml-base)))
+ (when content
+ (loop for property across content
+ when (let ((prop-name (get-node-name property))
+ (prop-ns (dom:namespace-uri property)))
+ (and (string= prop-name "subClassOf")
+ (string= prop-ns *rdfs-ns*)))
+ collect (let ((prop-xml-base (get-xml-base property
+ :old-base fn-xml-base)))
+ (let ((ID (get-absolute-attribute property tm-id
+ fn-xml-base "ID"))
+ (nodeID (get-ns-attribute property "nodeID"))
+ (resource
+ (get-absolute-attribute property tm-id
+ fn-xml-base "resource"))
+ (UUID (get-ns-attribute property "UUID"
+ :ns-uri *rdf2tm-ns*)))
+ (let ((value
+ (if (or nodeID resource UUID)
+ (or nodeID resource UUID)
+ (let ((res-values
+ (get-node-refs
+ (child-nodes-or-text property)
+ tm-id prop-xml-base)))
+ (first res-values)))))
+ (list :value value
+ :ID ID))))))))
+
+
+(defun get-associations-of-node-content (node tm-id xml-base)
+ "Returns a list of associations with a type, value and ID member."
+ (declare (dom:element node))
+ (let ((properties (child-nodes-or-text node))
+ (fn-xml-base (get-xml-base node :old-base xml-base)))
+ (loop for property across properties
+ when (let ((prop-name (get-node-name property))
+ (prop-ns (dom:namespace-uri property))
+ (prop-content (child-nodes-or-text property))
+ (resource (get-absolute-attribute property tm-id
+ fn-xml-base "resource"))
+ (nodeID (get-ns-attribute property "nodeID"))
+ (type (get-ns-attribute property "type"))
+ (parseType (get-ns-attribute property "parseType"))
+ (UUID (get-ns-attribute property "UUID"
+ :ns-uri *rdf2tm-ns*)))
+ (and (or resource nodeID type UUID
+ (and parseType
+ (or (string= parseType "Collection")
+ (string= parseType "Resource")))
+ (and (> (length prop-content) 0)
+ (not (stringp prop-content)))
+ (> (length (get-literals-of-property property nil)) 0))
+ (not (and (string= prop-name "type")
+ (string= prop-ns *rdf-ns*)))
+ (not (and (string= prop-name "subClassOf")
+ (string= prop-ns *rdfs-ns*)))))
+ collect (let ((prop-xml-base (get-xml-base property
+ :old-base fn-xml-base)))
+ (let ((resource
+ (get-absolute-attribute property tm-id
+ fn-xml-base "resource"))
+ (nodeID (get-ns-attribute property "nodeID"))
+ (UUID (get-ns-attribute property "UUID"
+ :ns-uri *rdf2tm-ns*))
+ (ID (get-absolute-attribute property tm-id
+ fn-xml-base "ID"))
+ (full-name (get-type-of-node-name property)))
+ (let ((value
+ (if (or nodeID resource UUID)
+ (or nodeID resource UUID)
+ (let ((res-values
+ (get-node-refs
+ (child-nodes-or-text property)
+ tm-id prop-xml-base)))
+ (first res-values)))))
+ (list :type full-name
+ :value value
+ :ID ID)))))))
\ 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 Thu Jul 30 08:26:23 2009
@@ -185,7 +185,7 @@
(error "~ardf:RDF not allowed here!"
err-pref))
(unless (find property-name *rdf-properties* :test #'string=)
- (format t "~aWarning: ~a is not a known RDF property!~%"
+ (format t "~aWarning: rdf:~a is not a known RDF property!~%"
err-pref property-name)))
(when (string= property-ns *rdfs-ns*)
(when (find property-name *rdfs-types* :test #'string=)
@@ -212,6 +212,7 @@
(subClassOf (get-ns-attribute property "subClassOf" :ns-uri *rdfs-ns*))
(literals (get-literals-of-property property nil))
(content (child-nodes-or-text property :trim t)))
+ (parse-property-name property)
(when (and parseType
(or nodeID resource datatype type literals))
(error "~awhen rdf:parseType is set the attributes: ~a => ~a are not allowed!"
@@ -264,7 +265,8 @@
content))
(when (and (or type
(and (string= node-name "type")
- (string= node-ns *rdf-ns*)))
+ (string= node-ns *rdf-ns*))
+ (> (length literals) 0))
(not (or nodeID resource))
(not content))
(dom:set-attribute-ns property *rdf2tm-ns* "UUID" (get-uuid)))
@@ -274,6 +276,21 @@
(if about
(concatenate 'string "rdf:about (" about ")")
(concatenate 'string "rdfs:subClassOf (" subClassOf ")"))))
+ (when (and (string= node-name "subClassOf")
+ (string= node-ns *rdfs-ns*)
+ (not (or nodeID resource content)))
+ (dom:set-attribute-ns property *rdf2tm-ns* "UUID" (get-uuid)))
+ (when (and (or (and (string= node-name "type")
+ (string= node-ns *rdf-ns*))
+ (and (string= node-name "subClassOf")
+ (string= node-ns *rdfs-ns*)))
+ (and (> (length content) 0)
+ (stringp content)))
+ (error "~awhen ~a not allowed to own literal content: ~a!"
+ err-pref (if (string= node-name "type")
+ "rdf:type"
+ "rdfs:subClassOf")
+ content))
(dolist (item *rdf-types*)
(when (get-ns-attribute property item)
(error "~ardf:~a is a type and not allowed here!"
@@ -284,3 +301,28 @@
err-pref item))))
t)
+
+(defun get-absolute-attribute (elem tm-id xml-base attr-name
+ &key (ns-uri *rdf-ns*))
+ "Returns an absolute 'attribute' or nil."
+ (declare (dom:element elem))
+ (declare (string attr-name))
+ (tm-id-p tm-id "get-ID")
+ (let ((attr (get-ns-attribute elem attr-name :ns-uri ns-uri))
+ (fn-xml-base (get-xml-base elem :old-base xml-base)))
+ (when attr
+ (if (and (string= ns-uri *rdf-ns*)
+ (string= attr-name "ID"))
+ (absolutize-id attr fn-xml-base tm-id)
+ (absolutize-value attr fn-xml-base tm-id)))))
+
+
+(defun get-datatype (elem tm-id xml-base)
+ "Returns a datatype value. The default is xml:string."
+ (let ((fn-xml-base (get-xml-base elem :old-base xml-base)))
+ (let ((datatype
+ (get-absolute-attribute elem tm-id fn-xml-base "datatype")))
+ (if datatype
+ datatype
+ *xml-string*))))
+
\ No newline at end of file
Modified: trunk/src/xml/xtm/tools.lisp
==============================================================================
--- trunk/src/xml/xtm/tools.lisp (original)
+++ trunk/src/xml/xtm/tools.lisp Thu Jul 30 08:26:23 2009
@@ -27,6 +27,7 @@
:get-xml-lang
:get-xml-base
:absolutize-value
+ :absolutize-id
:concatenate-uri
:push-string
:node-to-string))
More information about the Isidorus-cvs
mailing list