[isidorus-cvs] r97 - in trunk: docs src src/unit_tests src/xml/rdf src/xml/xtm
Lukas Giessmann
lgiessmann at common-lisp.net
Wed Jul 29 14:53:57 UTC 2009
Author: lgiessmann
Date: Wed Jul 29 10:53:52 2009
New Revision: 97
Log:
added some basic functions and unit tests for the rdf-importer
Modified:
trunk/docs/json.ebnf
trunk/src/isidorus.asd
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/docs/json.ebnf
==============================================================================
--- trunk/docs/json.ebnf (original)
+++ trunk/docs/json.ebnf Wed Jul 29 10:53:52 2009
@@ -41,14 +41,14 @@
Scope = "\"scopes\":" (DblList | Null)
InstanceOf = "\"instanceOfs\":" (DblList | Null)
Type = "\"type\":" List
-ID = "\id\":" string
+ID = "\id\":" String
TopicRef = "\"topicRef\":" List
Variant = "{" ItemIdentity "," Scope "," RData "}"
Variants = "\"variants\":" (("[" Variant+ "]") | Null)
Name = "{" ItemIdentity "," Type "," Scope "," Value "," Variants "}"
-Names = "\"names\":" ("[" Name+ "]") | Null
+Names = "\"names\":" (("[" Name+ "]") | Null)
Occurrence = "{" ItemIdentity "," Type "," Scope "," RData "}"
Occurrences = "\"occurrences\":" (("[" Occurrence+ "]") | Null)
@@ -60,7 +60,7 @@
Roles = "\"roles\":" (("[" Role+ "]") | Null)
Association = "{" ItemIdentity "," Type "," Scope "," Roles "}"
-Associations "\"associations\":" (("[" Association "]") | Null)
+Associations = "\"associations\":" (("[" Association "]") | Null)
TopicStub = "{" ID "," ItemIdentity "," SubjectLocator "," SubjectIdentifier "}"
TopicStubs = "\"topicStubs\":" (("[" TopicStub+ "]") | Null)
Modified: trunk/src/isidorus.asd
==============================================================================
--- trunk/src/isidorus.asd (original)
+++ trunk/src/isidorus.asd Wed Jul 29 10:53:52 2009
@@ -134,7 +134,8 @@
(:file "json_test"
:depends-on ("fixtures"))
(:file "threading_test")
- (:file "rdf_importer_test"))
+ (:file "rdf_importer_test"
+ :depends-on ("fixtures")))
:depends-on ("atom"
"constants"
"model"
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 Jul 29 10:53:52 2009
@@ -13,17 +13,19 @@
:xml-importer
:datamodel
:it.bese.FiveAM
- :unittests-constants
:fixtures)
(:import-from :constants
*rdf-ns*
*rdfs-ns*
- *rdf2tm-ns*)
+ *rdf2tm-ns*
+ *xml-ns*
+ *xml-string*)
(:import-from :xml-tools
xpath-child-elems-by-qname
xpath-single-child-elem-by-qname
xpath-select-location-path
- get-ns-attribute)
+ get-ns-attribute
+ absolute-uri-p)
(:export :test-get-literals-of-node
:test-parse-node
:run-rdf-importer-tests))
@@ -46,53 +48,97 @@
"xmlns:isi=\"http://isidorus/test#\" "
"rdf:type=\"rdfType\" rdf:ID=\"rdfID\" rdf:nodeID=\""
"rdfNodeID\" rdf:unknown=\"rdfUnknown\" "
- "isi:ID=\"isiID\" isi:arc=\"isiArc\"/>"))
- (doc-2
- (concatenate 'string "<rdf:Description xmlns:rdf=\"" *rdf-ns* "\" "
- "xmlns:rdfs=\"" *rdfs-ns* "\" "
- "rdfs:subClassOf=\"rdfsSubClassOf\" />")))
- (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))
- (dom-2 (cxml:parse doc-2 (cxml-dom:make-dom-builder))))
+ "isi:ID=\"isiID\" isi:arc=\"isiArc\" "
+ "isi:empty=\"\"/>")))
+ (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder))))
+ (is (= (length (dom:child-nodes dom-1)) 1))
+ (let ((literals (rdf-importer::get-literals-of-node
+ (elt (dom:child-nodes dom-1) 0) nil)))
+ (is-true literals)
+ (is (= (length literals) 4))
+ (is-true (find-if #'(lambda(x)
+ (and
+ (string= (getf x :value) "rdfUnknown")
+ (string= (getf x :type)
+ (concatenate 'string *rdf-ns* "unknown"))
+ (not (getf x :ID))))
+ literals))
+ (is-true (find-if #'(lambda(x)
+ (and
+ (string= (getf x :value) "isiID")
+ (string= (getf x :type)
+ "http://isidorus/test#ID")
+ (not (getf x :ID))))
+ literals))
+ (is-true (find-if #'(lambda(x)
+ (and
+ (string= (getf x :value) "isiArc")
+ (string= (getf x :type)
+ "http://isidorus/test#arc")
+ (not (getf x :ID))))
+ literals))
+ (is-true (find-if #'(lambda(x)
+ (and
+ (string= (getf x :value) "")
+ (string= (getf x :type)
+ "http://isidorus/test#empty")
+ (not (getf x :ID))))
+ literals))
+ (map 'list #'(lambda(x) (is-false (getf x :lang)))
+ literals)))
+
+ (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder))))
(is (= (length (dom:child-nodes dom-1)) 1))
- (is (= (length (dom:child-nodes dom-2)) 1))
+ (dom:set-attribute-ns (elt (dom:child-nodes dom-1) 0)
+ *xml-ns* "lang" "de")
(let ((literals (rdf-importer::get-literals-of-node
- (elt (dom:child-nodes dom-1) 0))))
+ (elt (dom:child-nodes dom-1) 0) "en")))
(is-true literals)
- (is (= (length literals) 3))
+ (is (= (length literals) 4))
(is-true (find-if #'(lambda(x)
(and
(string= (getf x :value) "rdfUnknown")
(string= (getf x :type)
- (concatenate 'string *rdf-ns* "unknown"))))
+ (concatenate 'string *rdf-ns* "unknown"))
+ (not (getf x :ID))))
literals))
(is-true (find-if #'(lambda(x)
(and
(string= (getf x :value) "isiID")
(string= (getf x :type)
- "http://isidorus/test#ID")))
+ "http://isidorus/test#ID")
+ (not (getf x :ID))))
literals))
(is-true (find-if #'(lambda(x)
(and
(string= (getf x :value) "isiArc")
(string= (getf x :type)
- "http://isidorus/test#arc")))
- literals)))
- (signals error (rdf-importer::get-literals-of-node
- (elt (dom:child-nodes dom-2) 0))))))
+ "http://isidorus/test#arc")
+ (not (getf x :ID))))
+ literals))
+ (is-true (find-if #'(lambda(x)
+ (and
+ (string= (getf x :value) "")
+ (string= (getf x :type)
+ "http://isidorus/test#empty")
+ (not (getf x :ID))))
+ literals))
+ (map 'list #'(lambda(x) (is-true (string= (getf x :lang) "de")))
+ literals)))))
(test test-parse-node
"Tests the parse-node function."
(let ((doc-1
- (concatenate 'string "<rdf:Description xmlns:rdf=\"" *rdf-ns* "\" "
+ (concatenate 'string "<rdf:UnknownType xmlns:rdf=\"" *rdf-ns* "\" "
"xmlns:isi=\"" *rdf2tm-ns* "\" "
"xmlns:arcs=\"http://test/arcs/\" "
"rdf:ID=\"rdfID\" xml:base=\"xmlBase\" "
"arcs:arc=\"arcsArc\">"
"<arcs:rel>"
- "<rdf:Element rdf:about=\"element\"/>"
+ "<rdf:Description rdf:about=\"element\"/>"
"</arcs:rel>"
- "</rdf:Description>")))
+ "</rdf:UnknownType>")))
(let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder))))
(is (length (dom:child-nodes dom-1)) 1)
(let ((node (elt (dom:child-nodes dom-1) 0)))
@@ -113,16 +159,400 @@
(dom:remove-attribute-ns node *rdf-ns* "nodeID")
(is-true (rdf-importer::parse-node node))
(is-true (get-ns-attribute node "UUID" :ns-uri *rdf2tm-ns*))
+ (dom:set-attribute-ns node *rdf-ns* "resource" "rdfResource")
+ (signals error (rdf-importer::parse-node node))
+ (dom:set-attribute-ns node *rdf-ns* "resource" "")
+ (is-true (rdf-importer::parse-node node))
(dom:replace-child node (dom:create-text-node dom-1 "anyText")
(xpath-single-child-elem-by-qname
node "http://test/arcs/" "rel"))
(signals error (rdf-importer::parse-node node))))))
+(test test-get-literals-of-property
+ "Tests the function get-literals-or-property."
+ (let ((doc-1
+ (concatenate 'string "<prop:property xmlns:prop=\"http://props/\" "
+ "xmlns:rdf=\"" *rdf-ns* "\" "
+ "xmlns:rdfs=\"" *rdfs-ns* "\" "
+ "rdf:type=\"rdfType\" rdf:resource=\"rdfResource\" "
+ "rdf:nodeID=\"rdfNodeID\" "
+ "prop:prop1=\"http://should/be/a/literal\" "
+ "prop:prop2=\"prop-2\" "
+ "prop:prop3=\"\">content-text</prop:property>")))
+ (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder))))
+ (is-true dom-1)
+ (is (= (length (dom:child-nodes dom-1)) 1))
+ (let ((property (elt (dom:child-nodes dom-1) 0)))
+ (let ((literals (rdf-importer::get-literals-of-property property nil)))
+ (is (= (length literals) 3))
+ (is-true (find-if #'(lambda(x)
+ (and
+ (string= (getf x :value)
+ "http://should/be/a/literal")
+ (string= (getf x :type) "http://props/prop1")
+ (not (getf x :ID))))
+ literals))
+ (is-true (find-if #'(lambda(x)
+ (and
+ (string= (getf x :value) "prop-2")
+ (string= (getf x :type) "http://props/prop2")
+ (not (getf x :ID))))
+ literals))
+ (is-true (find-if #'(lambda(x)
+ (and
+ (string= (getf x :value) "")
+ (string= (getf x :type) "http://props/prop3")
+ (not (getf x :ID))))
+ literals)))))))
+
+
+(test test-parse-property
+ "Tests the function parse-property."
+ (let ((doc-1
+ (concatenate 'string "<rdf:Description xmlns:rdf=\"" *rdf-ns* "\" "
+ "xmlns:rdfs=\"" *rdfs-ns* "\" "
+ "xmlns:prop=\"http://isidorus/props/\">"
+ "<prop:prop0 rdf:parseType=\"Resource\" />"
+ "<prop:prop1 rdf:parseType=\"Resource\">"
+ "<prop:prop1_0 rdf:resource=\"prop21\" />"
+ "</prop:prop1>"
+ "<prop:prop2 rdf:parseType=\"Literal\">"
+ "<content_root>content-text</content_root>"
+ "</prop:prop2>"
+ "<prop:prop3 rdf:parseType=\"Collection\" />"
+ "<prop:prop4 rdf:parseType=\"Collection\">"
+ "<prop:prop4_0 rdf:resource=\"prop5_1\" />"
+ "<prop:prop4_1 rdf:nodeID=\"prop5_2\" />"
+ "<prop:prop4_2/>"
+ "</prop:prop4>"
+ "<prop:prop5 />"
+ "<prop:prop6>prop6</prop:prop6>"
+ "<prop:prop7 rdf:nodeID=\"prop7\"/>"
+ "<prop:prop8 rdf:resource=\"prop8\" />"
+ "<prop:prop9 rdf:type=\"typeProp9\"> </prop:prop9>"
+ "<prop:prop10 rdf:datatype=\"datatypeProp10\" />"
+ "<prop:prop11 rdf:ID=\"IDProp11\"> </prop:prop11>"
+ "<prop:prop12 rdf:ID=\"IDprop12\" rdf:nodeID=\"prop12\">"
+ " </prop:prop12>"
+ "<prop:prop13 />"
+ "<prop:prop14>prop14</prop:prop14>"
+ "<prop:prop15 rdf:nodeID=\"prop15\"/>"
+ "<prop:prop16 rdf:resource=\"prop16\" />"
+ "<prop:prop17 rdf:type=\"typeProp17\"> </prop:prop17>"
+ "<prop:prop18 rdf:ID=\"IDprop18\" rdf:nodeID=\"prop18\">"
+ " </prop:prop18>"
+ "</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)) 1))
+ (let ((child (elt (dom:child-nodes dom-1) 0)))
+ (let ((children (rdf-importer::child-nodes-or-text child))
+ (text-node (dom:create-text-node dom-1 "new text node")))
+ (is (= (length children) 19))
+ (loop for property across children
+ do (is-true (rdf-importer::parse-property property)))
+ (dotimes (i (length children))
+ (if (or (= i 0) (= i 1) (= i 3) (= i 4) (= i 9) (= i 17))
+ (is-true (get-ns-attribute (elt children i) "UUID"
+ :ns-uri *rdf2tm-ns*))
+ (is-false (get-ns-attribute (elt children i) "UUID"
+ :ns-uri *rdf2tm-ns*))))
+ (let ((prop (elt children 0)))
+ (dom:set-attribute-ns prop *rdf-ns* "parseType" "Unknown")
+ (signals error (rdf-importer::parse-property prop))
+ (dom:set-attribute-ns prop *rdf-ns* "parseType" "Resource")
+ (is-true (rdf-importer::parse-property prop))
+ (dom:set-attribute-ns prop *rdf-ns* "ID" "newID")
+ (is-true (rdf-importer::parse-property prop))
+ (dom:set-attribute-ns prop *rdf-ns* "bad" "bad")
+ (signals error (rdf-importer::parse-property prop))
+ (dom:remove-attribute-ns prop *rdf-ns* "bad")
+ (is-true (rdf-importer::parse-property prop))
+ (dom:append-child prop text-node)
+ (signals error (rdf-importer::parse-property prop))
+ (dom:remove-child prop text-node)
+ (is-true (rdf-importer::parse-property prop)))
+ (let ((prop (elt children 1)))
+ (dom:set-attribute-ns prop *rdf-ns* "nodeID" "bad")
+ (signals error (rdf-importer::parse-property prop))
+ (dom:remove-attribute-ns prop *rdf-ns* "nodeID")
+ (is-true (rdf-importer::parse-property prop))
+ (dom:set-attribute-ns prop *rdf-ns* "ID" "newID")
+ (is-true (rdf-importer::parse-property prop))
+ (dom:append-child prop text-node)
+ (signals error (rdf-importer::parse-property prop))
+ (dom:remove-child prop text-node)
+ (is-true (rdf-importer::parse-property prop)))
+ (let ((prop (elt children 3)))
+ (dom:append-child prop text-node)
+ (signals error (rdf-importer::parse-property prop))
+ (dom:remove-child prop text-node)
+ (is-true (rdf-importer::parse-property prop)))
+ (let ((prop (elt children 4)))
+ (dom:append-child prop text-node)
+ (signals error (rdf-importer::parse-property prop))
+ (dom:remove-child prop text-node)
+ (is-true (rdf-importer::parse-property prop)))
+ (let ((prop (elt children 5)))
+ (dom:set-attribute-ns prop *rdf-ns* "type" "newType")
+ (is-true (rdf-importer::parse-property prop))
+ (dom:set-attribute-ns prop *rdf-ns* "unknown" "unknown")
+ (is-true (rdf-importer::parse-property prop))
+ (dom:append-child prop text-node)
+ (signals error (rdf-importer::parse-property prop))
+ (dom:remove-child prop text-node)
+ (is-true (rdf-importer::parse-property prop))
+ (dom:remove-attribute-ns prop *rdf-ns* "unknown")
+ (is-true (rdf-importer::parse-property prop))
+ (dom:append-child prop text-node)
+ (signals error (rdf-importer::parse-property prop))
+ (dom:remove-child prop text-node)
+ (is-true (rdf-importer::parse-property prop)))
+ (let ((prop (elt children 10)))
+ (dom:set-attribute-ns prop *rdf-ns* "type" "newType")
+ (signals error (rdf-importer::parse-property prop))
+ (dom:remove-attribute-ns prop *rdf-ns* "type")
+ (is-true (rdf-importer::parse-property prop))
+ (dom:set-attribute-ns prop *rdf-ns* "nodeID" "newNodeID")
+ (signals error (rdf-importer::parse-property prop))
+ (dom:remove-attribute-ns prop *rdf-ns* "nodeID")
+ (is-true (rdf-importer::parse-property prop))
+ (dom:set-attribute-ns prop *rdf-ns* "resource" "newResource")
+ (signals error (rdf-importer::parse-property prop))
+ (dom:remove-attribute-ns prop *rdf-ns* "resource")
+ (is-true (rdf-importer::parse-property prop))
+ (dom:set-attribute-ns prop *rdf-ns* "ID" "newID")
+ (is-true (rdf-importer::parse-property prop))))))))
+
+
+(test test-get-types
+ "Tests the functions get-type-of-node-name, get-types-of-content,
+ get-node-rerfs, absolute-uri-p, absolutize-value and absolutize-id."
+ (let ((tm-id "http://test-tm")
+ (doc-1
+ (concatenate 'string "<rdf:anyType xmlns:rdf=\"" *rdf-ns* "\" "
+ "xmlns:isi=\"" *rdf2tm-ns* "\" "
+ "xmlns:arcs=\"http://test/arcs/\" "
+ "xml:base=\"xml-base/first\" "
+ "rdf:about=\"resource\" rdf:type=\"attr-type\">"
+ "<rdf:type rdf:ID=\"rdfID\" "
+ "rdf:resource=\"content-type-1\"/>"
+ "<rdf:type /><!-- blank_node -->"
+ "<rdf:type arcs:arc=\"literalArc\"/>"
+ "<rdf:type 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 -->"
+ "</rdf:type>"
+ "<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>"
+ "<rdf:type xml:base=\"http://new-base/\">"
+ "<rdf:Description rdf:ID=\"c-ID-type-2\"/>"
+ "</rdf:type>"
+ "<rdf:type rdf:ID=\"rdfID3\">"
+ "<rdf:Description/>"
+ "</rdf:type>"
+
+ "<arcs:arc rdf:resource=\"anyArc\"/>"
+ "<rdf:arc>"
+ "<rdf:Description rdf:about=\"anyResource\"/>"
+ "</rdf:arc>"
+ "</rdf:anyType>")))
+ (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder))))
+ (is-true dom-1)
+ (is (= (length (dom:child-nodes dom-1)) 1))
+ (is-true (absolute-uri-p tm-id))
+ (is-false (absolute-uri-p "http//bad"))
+ (is-false (absolute-uri-p ""))
+ (is-false (absolute-uri-p " "))
+ (is-false (absolute-uri-p nil))
+ (let ((node (elt (dom:child-nodes dom-1) 0)))
+ (loop for property across (rdf-importer::child-nodes-or-text node)
+ do (rdf-importer::parse-property property))
+ (let ((types
+ (append
+ (list (list
+ :value (rdf-importer::get-type-of-node-name node)
+ :ID nil))
+ (rdf-importer::get-types-of-node-content node tm-id nil)))
+ (node-uuid (get-ns-attribute
+ (elt (rdf-importer::child-nodes-or-text
+ (elt (rdf-importer::child-nodes-or-text node) 7))
+ 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)
+ (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)
+ (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))
+ (is-true (= 10 (count-if #'(lambda(x)
+ (> (length (getf x :value)) 0))
+ types))))))))
+(test test-get-literals-of-content
+ (let ((doc-1
+ (concatenate 'string "<rdf:Description xmlns:rdf=\"" *rdf-ns* "\" "
+ "xmlns:rdfs=\"" *rdfs-ns* "\" "
+ "xmlns:prop=\"http://isidorus/props/\" "
+ "xml:base=\"base/first\" xml:lang=\"de\" >"
+ "<prop:lit0>text0</prop:lit0>"
+ "<prop:lit1 rdf:parseType=\"Literal\">text1</prop:lit1>"
+ "<prop:lit2 xml:base=\"http://base/absolute\" "
+ "rdf:datatype=\"dType1\">text2</prop:lit2>"
+ "<prop:arc rdf:parseType=\"Collection\"/>"
+ "<prop:lit3 xml:lang=\"en\" rdf:datatype=\"dType2\">"
+ "<![CDATA[text3]]></prop:lit3>"
+ "<prop:lit4 rdf:datatype=\"dType2\"><root><child/></root>"
+ " </prop:lit4>"
+ "<prop:lit5 rdf:ID=\"rdfID\" "
+ "rdf:parseType=\"Literal\"><root><child>"
+ "childText5</child> </root></prop:lit5>"
+ "<prop:lit6 xml:lang=\"\" rdf:parseType=\"Literal\">"
+ " <![CDATA[text6]]> abc "
+ "</prop:lit6>"
+ "</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)))
+ (dotimes (iter (length (dom:child-nodes node)))
+ (is-true (rdf-importer::parse-property
+ (elt (dom:child-nodes node) iter))))
+ (let ((literals (rdf-importer::get-literals-of-node-content
+ node tm-id nil nil)))
+ (is (= (length literals) 7))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (string= (getf x :value) "text0")
+ (string= (getf x :type)
+ "http://isidorus/props/lit0")
+ (not (getf x :ID))
+ (string= (getf x :lang) "de")
+ (string= (getf x :datatype) *xml-string*)))
+ literals))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (string= (getf x :value) "text1")
+ (string= (getf x :type)
+ "http://isidorus/props/lit1")
+ (not (getf x :ID))
+ (string= (getf x :lang) "de")
+ (string= (getf x :datatype) *xml-string*)))
+ literals))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (string= (getf x :value) "text2")
+ (string= (getf x :type)
+ "http://isidorus/props/lit2")
+ (not (getf x :ID))
+ (string= (getf x :lang) "de")
+ (string= (getf x :datatype)
+ "http://base/absolute/dType1")))
+ literals))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (string= (getf x :value) "text3")
+ (string= (getf x :type)
+ "http://isidorus/props/lit3")
+ (not (getf x :ID))
+ (string= (getf x :lang) "en")
+ (string= (getf x :datatype)
+ "http://test-tm/base/first/dType2")))
+ literals))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (string= (getf x :value)
+ "<root><child></child></root> ")
+ (string= (getf x :type)
+ "http://isidorus/props/lit4")
+ (not (getf x :ID))
+ (string= (getf x :lang) "de")
+ (string= (getf x :datatype)
+ "http://test-tm/base/first/dType2")))
+ literals))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (string= (getf x :value)
+ "<root><child>childText5</child> </root>")
+ (string= (getf x :type)
+ "http://isidorus/props/lit5")
+ (string= (getf x :ID) "rdfID")
+ (string= (getf x :lang) "de")
+ (string= (getf x :datatype) *xml-string*)))
+ literals))
+ (is-true (find-if
+ #'(lambda(x)
+ (and (string= (getf x :value) " text6 abc ")
+ (string= (getf x :type)
+ "http://isidorus/props/lit6")
+ (not (getf x :ID))
+ (not (getf x :lang))
+ (string= (getf x :datatype) *xml-string*)))
+ literals)))))))
(defun run-rdf-importer-tests()
(it.bese.fiveam:run! 'test-get-literals-of-node)
- (it.bese.fiveam:run! 'test-parse-node))
\ No newline at end of file
+ (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
Modified: trunk/src/xml/rdf/importer.lisp
==============================================================================
--- trunk/src/xml/rdf/importer.lisp (original)
+++ trunk/src/xml/rdf/importer.lisp Wed Jul 29 10:53:52 2009
@@ -54,5 +54,217 @@
(defun import-node (elem tm-id &key (document-id *document-id*)
(xml-base nil) (xml-lang nil))
+ (declare (ignorable document-id)) ;TODO: remove
+ (tm-id-p tm-id "import-node")
(parse-node elem)
- )
\ No newline at end of file
+ (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))
+ (nodeID (get-ns-attribute elem "nodeID"))
+ (ID (get-ns-attribute elem "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)
+ (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
+ (declare (ignorable about nodeID ID UUID literals associations ;TODO: remove
+ types super-classes)))))
+
+
+(defun get-literals-of-node-content (node tm-id xml-base xml-lang)
+ "Returns a list of literals that is produced of a node's content."
+ (declare (dom:element node))
+ (tm-id-p tm-id "get-literals-of-content")
+ (let ((properties (child-nodes-or-text node))
+ (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)))
+ (parseType (get-ns-attribute property "parseType"))
+ (nodeID (get-ns-attribute property "nodeID"))
+ (resource (get-ns-attribute property "resource"))
+ (UUID (get-ns-attribute property "UUID"
+ :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))))))
+
+ literals)))
+
+
+(defun get-type-of-node-name (node)
+ "Returns the type of the node name (namespace + tagname)."
+ (let ((node-name (get-node-name node))
+ (node-ns (dom:namespace-uri node)))
+ (concatenate-uri node-ns node-name)))
+
+
+(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."
+ (let ((fn-xml-base (get-xml-base node :old-base xml-base)))
+ (let ((attr-type
+ (if (get-ns-attribute node "type")
+ (list
+ (list :value (absolutize-value (get-ns-attribute node "type")
+ fn-xml-base tm-id)
+ :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))))))))
+ (remove-if #'null (append attr-type content-types)))))
+
+
+(defun get-literals-of-property (property xml-lang)
+ "Returns a list of attributes that are treated as literal nodes."
+ (let ((fn-xml-lang (get-xml-lang property :old-lang xml-lang))
+ (attributes nil))
+ (dom:map-node-map
+ #'(lambda(attr)
+ (let ((attr-ns (dom:namespace-uri attr))
+ (attr-name (get-node-name attr)))
+ (let ((l-type (concatenate-uri attr-ns attr-name))
+ (l-value (if (get-ns-attribute property attr-name
+ :ns-uri attr-ns)
+ (get-ns-attribute property attr-name
+ :ns-uri attr-ns)
+ "")))
+ (cond
+ ((string= attr-ns *rdf-ns*)
+ (unless (or (string= attr-name "ID")
+ (string= attr-name "resource")
+ (string= attr-name "nodeID")
+ (string= attr-name "type")
+ (string= attr-name "parseType")
+ (string= attr-name "datatype"))
+ (push (list :type l-type
+ :value l-value
+ :ID nil
+ :lang fn-xml-lang
+ :datatype *xml-string*)
+ attributes)))
+ ((or (string= attr-ns *xml-ns*)
+ (string= attr-ns *xmlns-ns*))
+ nil);;do nothing, all xml-attributes are no literals
+ (t
+ (unless (and (string= attr-ns *rdf2tm-ns*)
+ (string= attr-name "UUID"))
+ (push (list :type l-type
+ :value l-value
+ :ID nil
+ :lang fn-xml-lang
+ :datatype *xml-string*)
+ attributes)))))))
+ (dom:attributes property))
+ attributes))
+
+
+(defun get-literals-of-node (node xml-lang)
+ "Returns alist of attributes that are treated as literal nodes."
+ (let ((fn-xml-lang (get-xml-lang node :old-lang xml-lang))
+ (attributes nil))
+ (dom:map-node-map
+ #'(lambda(attr)
+ (let ((attr-ns (dom:namespace-uri attr))
+ (attr-name (get-node-name attr)))
+ (let ((l-type (concatenate-uri attr-ns attr-name))
+ (l-value (if (get-ns-attribute node attr-name :ns-uri attr-ns)
+ (get-ns-attribute node attr-name :ns-uri attr-ns)
+ "")))
+ (cond
+ ((string= attr-ns *rdf-ns*)
+ (unless (or (string= attr-name "ID")
+ (string= attr-name "about")
+ (string= attr-name "nodeID")
+ (string= attr-name "type"))
+ (push (list :type l-type
+ :value l-value
+ :ID nil
+ :lang fn-xml-lang
+ :datatype *xml-string*)
+ attributes)))
+ ((or (string= attr-ns *xml-ns*)
+ (string= attr-ns *xmlns-ns*))
+ nil);;do nothing, all xml-attributes are no literals
+ (t
+ (unless (and (string= attr-ns *rdf2tm-ns*)
+ (string= attr-name "UUID"))
+ (push (list :type l-type
+ :value l-value
+ :ID nil
+ :lang fn-xml-lang
+ :datatype *xml-string*)
+ attributes)))))))
+ (dom:attributes node))
+ attributes))
+
+
Modified: trunk/src/xml/rdf/rdf_tools.lisp
==============================================================================
--- trunk/src/xml/rdf/rdf_tools.lisp (original)
+++ trunk/src/xml/rdf/rdf_tools.lisp Wed Jul 29 10:53:52 2009
@@ -33,8 +33,10 @@
get-xml-lang
get-xml-base
absolutize-value
+ absolutize-id
concatenate-uri
- push-string)
+ push-string
+ node-to-string)
(:import-from :xml-importer
get-uuid
get-store-spec)
@@ -44,6 +46,18 @@
(in-package :rdf-importer)
+(defvar *rdf-types* (list "Description" "List" "Alt" "Bag" "Seq"
+ "Statement" "Property" "XMLLiteral"))
+
+(defvar *rdf-properties* (list "type" "first" "rest" "subject" "predicate"
+ "object"))
+
+(defvar *rdfs-types* (list "Resource" "Literal" "Class" "Datatype"
+ "Container" "ContainerMembershipProperty"))
+
+(defvar *rdfs-properties* (list "subClassOf" "subPropertyOf" "domain"
+ "range" "range" "label" "comment"
+ "member" "seeAlso" "isDefinedBy"))
(defun _n-p (node-name)
"Returns t if the given value is of the form _[0-9]+"
@@ -62,51 +76,28 @@
(defun parse-node-name (node)
"Parses the given node's name to the known rdf/rdfs nodes and arcs.
If the given name es equal to a property an error is thrown otherwise
- there is displayed a warning."
+ there is displayed a warning when the rdf ord rdfs namespace is used."
(declare (dom:element node))
(let ((node-name (get-node-name node))
- (node-ns (dom:namespace-uri node)))
+ (node-ns (dom:namespace-uri node))
+ (err-pref "From parse-node-name(): "))
(when (string= node-ns *rdf-ns*)
- (when (or (string= node-name "type")
- (string= node-name "first")
- (string= node-name "rest")
- (string= node-name "subject")
- (string= node-name "predicate")
- (string= node-name "object"))
- (error "From parse-node-name(): rdf:~a is a property and not allowed here!"
- node-name))
+ (when (find node-name *rdf-properties* :test #'string=)
+ (error "~ardf:~a is a property and not allowed here!"
+ err-pref node-name))
(when (string= node-name "RDF")
- (error "From parse-node-name(): rdf:RDF not allowed here!"))
- (unless (or (string= node-name "Description")
- (string= node-name "List")
- (string= node-name "Alt")
- (string= node-name "Bag")
- (string= node-name "Seq")
- (string= node-name "Statement")
- (string= node-name "Property")
- (string= node-name "XMLLiteral"))
- (format t "From parse-node-name(): Warning: ~a is not a known rdf:type!~%"
- node-name)))
+ (error "~ardf:RDF not allowed here!"
+ err-pref))
+ (unless (find node-name *rdf-types* :test #'string=)
+ (format t "~aWarning: ~a is not a known RDF type!~%"
+ err-pref node-name)))
(when (string= node-ns *rdfs-ns*)
- (when (or (string= node-name "subClassOf")
- (string= node-name "subPropertyOf")
- (string= node-name "domain")
- (string= node-name "range")
- (string= node-name "label")
- (string= node-name "comment")
- (string= node-name "member")
- (string= node-name "seeAlso")
- (string= node-name "isDefinedBy"))
- (error "From parse-node-name(): rdfs:~a is a property and not allowed here!"
- node-name))
- (unless (and (string= node-name "Resource")
- (string= node-name "Literal")
- (string= node-name "Class")
- (string= node-name "Datatype")
- (string= node-name "Cotnainer")
- (string= node-name "ContainerMembershipProperty"))
- (format t "From parse-node-name(): Warning: rdfs:~a is not a known rdfs:type!~%"
- node-name))))
+ (when (find node-name *rdfs-properties* :test #'string=)
+ (error "~ardfs:~a is a property and not allowed here!"
+ err-pref node-name))
+ (unless (find node-name *rdfs-types* :test #'string=)
+ (format t "~aWarning: rdfs:~a is not a known rdfs:type!~%"
+ err-pref node-name))))
t)
@@ -117,7 +108,12 @@
(let ((ID (get-ns-attribute node "ID"))
(nodeID (get-ns-attribute node "nodeID"))
(about (get-ns-attribute node "about"))
- (err-pref "From parse-node(): "))
+ (err-pref "From parse-node(): ")
+ (resource (get-ns-attribute node "resource"))
+ (datatype (get-ns-attribute node "datatype"))
+ (parseType (get-ns-attribute node "parseType"))
+ (class (get-ns-attribute node "Class" :ns-uri *rdfs-ns*))
+ (subClassOf (get-ns-attribute node "subClassOf" :ns-uri *rdfs-ns*)))
(when (and about nodeID)
(error "~ardf:about and rdf:nodeID are not allowed in parallel use: (~a) (~a)!"
err-pref about nodeID))
@@ -130,43 +126,161 @@
(handler-case (let ((content (child-nodes-or-text node :trim t)))
(when (stringp content)
(error "text-content not allowed here!")))
- (condition (err) (error "~a~a" err-pref err))))
+ (condition (err) (error "~a~a" err-pref err)))
+ (when (or resource datatype parseType class subClassOf)
+ (error "~a~a is not allowed here!"
+ err-pref (cond
+ (resource (concatenate 'string "resource("
+ resource ")"))
+ (datatype (concatenate 'string "datatype("
+ datatype ")"))
+ (parseType (concatenate 'string "parseType("
+ parseType ")"))
+ (class (concatenate 'string "Class(" class ")"))
+ (subClassOf (concatenate 'string "subClassOf("
+ subClassOf ")")))))
+ (dolist (item *rdf-types*)
+ (when (get-ns-attribute node item)
+ (error "~ardf:~a is a type and not allowed here!"
+ err-pref item)))
+ (dolist (item *rdfs-types*)
+ (when (get-ns-attribute node item :ns-uri *rdfs-ns*)
+ (error "~ardfs:~a is a type and not allowed here!"
+ err-pref item))))
t)
+(defun get-node-refs (nodes tm-id xml-base)
+ "Returns a list of node references that can be used as topic IDs."
+ (when (and nodes
+ (> (length nodes) 0))
+ (loop for node across nodes
+ collect (let ((fn-xml-base (get-xml-base node :old-base xml-base)))
+ (parse-node node)
+ (let ((ID (when (get-ns-attribute node "ID")
+ (absolutize-id (get-ns-attribute node "ID")
+ fn-xml-base tm-id)))
+ (nodeID (get-ns-attribute node "nodeID"))
+ (about (when (get-ns-attribute node "about")
+ (absolutize-value
+ (get-ns-attribute node "about")
+ fn-xml-base tm-id)))
+ (UUID (get-ns-attribute node "UUID" :ns-uri *rdf2tm-ns*)))
+ (or ID nodeID about UUID))))))
+
+
+(defun parse-property-name (property)
+ "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
+ there is displayed a warning when the rdf ord rdfs namespace is used."
+ (declare (dom:element property))
+ (let ((property-name (get-node-name property))
+ (property-ns (dom:namespace-uri property))
+ (err-pref "From parse-property-name(): "))
+ (when (string= property-ns *rdf-ns*)
+ (when (find property-name *rdf-types* :test #'string=)
+ (error "~ardf:~a is a node and not allowed here!"
+ err-pref property-name))
+ (when (string= property-name "RDF")
+ (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!~%"
+ err-pref property-name)))
+ (when (string= property-ns *rdfs-ns*)
+ (when (find property-name *rdfs-types* :test #'string=)
+ (error "~ardfs:~a is a type and not allowed here!"
+ err-pref property-name))
+ (unless (find property-name *rdfs-properties* :test #'string=)
+ (format t "~aWarning: rdfs:~a is not a known rdfs:type!~%"
+ err-pref property-name))))
+ t)
+
+
+(defun parse-property (property)
+ "Parses a property that represents a rdf-arc."
+ (declare (dom:element property))
+ (let ((err-pref "From parse-property(): ")
+ (node-name (get-node-name property))
+ (node-ns (dom:namespace-uri property))
+ (nodeID (get-ns-attribute property "nodeID"))
+ (resource (get-ns-attribute property "resource"))
+ (datatype (get-ns-attribute property "datatype"))
+ (type (get-ns-attribute property "type"))
+ (parseType (get-ns-attribute property "parseType"))
+ (about (get-ns-attribute property "about"))
+ (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)))
+ (when (and parseType
+ (or nodeID resource datatype type literals))
+ (error "~awhen rdf:parseType is set the attributes: ~a => ~a are not allowed!"
+ err-pref
+ (append (list (cond (nodeID "rdf:nodeID")
+ (resource "rdf:resource")
+ (datatype "rdf:datatype")
+ (type "rdf:type")))
+ (map 'list #'(lambda(x)(getf x :type)) literals))
+ (append (list (or nodeID resource datatype type))
+ (map 'list #'(lambda(x)(getf x :value)) literals))))
+ (when (and parseType
+ (not (or (string= parseType "Resource")
+ (string= parseType "Literal")
+ (string= parseType "Collection"))))
+ (error "~aunknown rdf:parseType: ~a"
+ err-pref parseType))
+ (when (and parseType
+ (or (string= parseType "Resource")
+ (string= parseType "Collection")))
+ (dom:set-attribute-ns property *rdf2tm-ns* "UUID" (get-uuid)))
+ (when (and parseType (string= parseType "Resource") (stringp content))
+ (error "~ardf:parseType is set to 'Resource' expecting xml content: ~a!"
+ err-pref content))
+ (when (and parseType
+ (string= parseType "Collection")
+ (stringp content))
+ (error "~ardf:parseType is set to 'Collection' expecting resource content: ~a"
+ err-pref content))
+ (when (and nodeID resource)
+ (error "~aondly one of rdf:nodeID and rdf:resource is allowed: (~a) (~a)!"
+ err-pref nodeID resource))
+ (when (and (or nodeID resource type)
+ datatype)
+ (error "~aonly one of ~a and rdf:datatype (~a) is allowed!"
+ err-pref
+ (cond
+ (nodeID (concatenate 'string "rdf:nodeID (" nodeID ")"))
+ (resource (concatenate 'string "rdf:resource (" resource ")"))
+ (type (concatenate 'string "rdf:type (" type ")")))
+ datatype))
+ (when (and (or type nodeID resource)
+ (> (length content) 0))
+ (error "~awhen ~a is set no content is allowed: ~a!"
+ err-pref
+ (cond
+ (type (concatenate 'string "rdf:type (" type ")"))
+ (nodeID (concatenate 'string "rdf:nodeID (" nodeID ")"))
+ (resource (concatenate 'string "rdf:resource (" resource ")")))
+ content))
+ (when (and (or type
+ (and (string= node-name "type")
+ (string= node-ns *rdf-ns*)))
+ (not (or nodeID resource))
+ (not content))
+ (dom:set-attribute-ns property *rdf2tm-ns* "UUID" (get-uuid)))
+ (when (or about subClassOf)
+ (error "~a~a not allowed here!"
+ err-pref
+ (if about
+ (concatenate 'string "rdf:about (" about ")")
+ (concatenate 'string "rdfs:subClassOf (" subClassOf ")"))))
+ (dolist (item *rdf-types*)
+ (when (get-ns-attribute property item)
+ (error "~ardf:~a is a type and not allowed here!"
+ err-pref item)))
+ (dolist (item *rdfs-types*)
+ (when (get-ns-attribute property item :ns-uri *rdfs-ns*)
+ (error "~ardfs:~a is a type and not allowed here!"
+ err-pref item))))
+ t)
-(defun get-literals-of-node (node)
- "Returns alist of attributes that are treated as literal nodes."
- (let ((attributes nil))
- (dom:map-node-map
- #'(lambda(attr)
- (let ((attr-ns (dom:namespace-uri attr))
- (attr-name (get-node-name attr)))
- (cond
- ((string= attr-ns *rdf-ns*)
- (unless (or (string= attr-name "ID")
- (string= attr-name "about")
- (string= attr-name "nodeID")
- (string= attr-name "type"))
- (push (list :type (concatenate-uri attr-ns attr-name)
- :value (get-ns-attribute node attr-name))
- attributes)))
- ((or (string= attr-ns *xml-ns*)
- (string= attr-ns *xmlns-ns*))
- nil);;do nothing, all xml-attributes are no literals
- ((string= attr-ns *rdfs-ns*)
- (if (or (string= attr-name "subClassOf")
- (string= attr-name "Class"))
- (error "From get-literals-of-node(): rdfs:~a is not allowed here"
- attr-name)
- (push (list :type (concatenate-uri attr-ns attr-name)
- :value (get-ns-attribute node attr-name
- :ns-uri attr-ns))
- attributes)))
- (t
- (push (list :type (concatenate-uri attr-ns attr-name)
- :value (get-ns-attribute node attr-name
- :ns-uri attr-ns))
- attributes)))))
- (dom:attributes node))
- attributes))
\ 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 Wed Jul 29 10:53:52 2009
@@ -28,7 +28,8 @@
:get-xml-base
:absolutize-value
:concatenate-uri
- :push-string))
+ :push-string
+ :node-to-string))
(in-package :xml-tools)
@@ -65,13 +66,24 @@
(concatenate 'string prep-ns separator value))))
-(defun absolutize-value(value base tm-id)
- "Returns the passed value as an absolute uri computed
+(defun absolutize-id (id xml-base tm-id)
+ "Returns the passed id as an absolute uri computed
with the given base and tm-id."
+ (declare (string id tm-id))
+ (let ((prep-id (if (and (> (length id) 0)
+ (eql (elt id 0) #\#))
+ id
+ (concatenate 'string "#" (string-left-trim "/" id)))))
+ (absolutize-value prep-id xml-base tm-id)))
+
+
+(defun absolutize-value(value xml-base tm-id)
+ "Returns the passed value as an absolute uri computed
+ with the given xml-base and tm-id."
(declare (string value tm-id))
(unless (absolute-uri-p tm-id)
(error "From absolutize-value(): you must provide a stable identifier (PSI-style) for this TM: ~a" tm-id))
- (when (> (count #\# value) 2)
+ (when (> (count #\# value) 1)
(error "From absolutize-value(): value is allowed to have only one \"#\": ~a" value))
(if (absolute-uri-p value)
value
@@ -80,8 +92,8 @@
(string-left-trim "/" value)
""))
(prep-base
- (if (> (length base) 0)
- (string-right-trim "/" base)
+ (if (> (length xml-base) 0)
+ (string-right-trim "/" xml-base)
"")))
(let ((fragment
(if (and (> (length prep-value) 0)
@@ -323,4 +335,27 @@
(loop for child-node across (dom:child-nodes elem)
unless (or (dom:text-node-p child-node)
(dom:comment-p child-node))
- collect child-node))
\ No newline at end of file
+ collect child-node))
+
+
+(defun node-to-string (elem)
+ "Transforms the passed node element recursively to a string."
+ (if (dom:text-node-p elem)
+ (dom:node-value elem)
+ (let ((node-name (dom:node-name elem))
+ (attributes (dom:attributes elem))
+ (child-nodes (dom:child-nodes elem))
+ (elem-string ""))
+ (push-string (concatenate 'string "<" node-name) elem-string)
+ (dom:map-node-map
+ #'(lambda(attr)
+ (let ((attr-name (dom:node-name attr))
+ (attr-value (dom:node-value attr)))
+ (push-string (concatenate 'string " " attr-name "=\""
+ attr-value "\"")
+ elem-string)))
+ attributes)
+ (push-string ">" elem-string)
+ (loop for child-node across child-nodes
+ do (push-string (node-to-string child-node) elem-string))
+ (push-string (concatenate 'string "</" node-name ">") elem-string))))
\ No newline at end of file
More information about the Isidorus-cvs
mailing list