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))