Author: lgiessmann Date: Fri Jul 31 07:54:22 2009 New Revision: 100 Log: fixed some problems with rdf-helper functions; cimpleted the handling for rdf:li; fixed and added some unite test for 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 Fri Jul 31 07:54:22 2009 @@ -387,7 +387,8 @@ (let ((types (append (list (list - :value (rdf-importer::get-type-of-node-name node) + :topicid (rdf-importer::get-type-of-node-name node) + :psi (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 @@ -398,14 +399,21 @@ (is (= (length types) 10)) (is-true (find-if #'(lambda(x) - (and (string= (getf x :value) + (and (string= (getf x :topicid) + (concatenate + 'string *rdf-ns* "anyType")) + (string= (getf x :topicid) (concatenate 'string *rdf-ns* "anyType")) (not (getf x :ID)))) types)) (is-true (find-if #'(lambda(x) - (and (string= (getf x :value) + (and (string= (getf x :topicid) + (concatenate + 'string tm-id + "/xml-base/first/attr-type")) + (string= (getf x :psi) (concatenate 'string tm-id "/xml-base/first/attr-type")) @@ -413,14 +421,20 @@ types)) (is-true (find-if #'(lambda(x) - (and (string= (getf x :value) + (and (string= (getf x :topicid) + "http://test-tm/xml-base/first/content-type-1") + (string= (getf x :psi) "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) + (and (string= (getf x :topicid) + (concatenate + 'string tm-id + "/xml-base/first/c-about-type-2")) + (string= (getf x :psi) (concatenate 'string tm-id "/xml-base/first/c-about-type-2")) @@ -429,23 +443,27 @@ types)) (is-true (find-if #'(lambda(x) - (and (string= (getf x :value) "c-nodeID-type-2") + (and (string= (getf x :topicid) "c-nodeID-type-2") + (not (getf x :psi)) (not (getf x :ID)))) types)) (is-true (find-if #'(lambda(x) - (and (string= (getf x :value) + (and (string= (getf x :topicid) + "http://new-base#c-ID-type-2") + (string= (getf x :psi) "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) + (and (string= (getf x :topicid) node-uuid) + (not (getf x :psi)) (string= (getf x :ID) "http://test-tm/xml-base/first#rdfID3"))) types)) (is-true (= 10 (count-if #'(lambda(x) - (> (length (getf x :value)) 0)) + (> (length (getf x :topicid)) 0)) types)))))))) @@ -603,38 +621,61 @@ (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 + (is-true + (find-if + #'(lambda(x) + (and + (string= + (getf x :psi) + "http://test-tm/base/initial/xml-base/first/content-type-1") + (string= + (getf x :topicid) + "http://test-tm/base/initial/xml-base/first/content-type-1") + (string= + (getf x :ID) + "http://test-tm/base/initial/xml-base/first#rdfID"))) + super-classes)) + (is-true (find-if + #'(lambda(x) + (and + (string= + (getf x :topicid) + (concatenate 'string tm-id xml-base + "/xml-base/first/c-about-type-2")) + (string= + (getf x :psi) + (concatenate 'string tm-id xml-base + "/xml-base/first/c-about-type-2")) + (string= (getf x :ID) + (concatenate 'string tm-id xml-base + "/xml-base/first#rdfID2")))) + super-classes)) + (is-true (find-if #'(lambda(x) - (string= (getf x :ID) - "http://test-tm/base/initial/xml-base/first#rdfID")) + (and (string= (getf x :topicid) "c-nodeID-type-2") + (not (getf x :psi)) + (not (getf x :ID)))) + super-classes)) + (is-true (find-if + #'(lambda(x) + (and (string= (getf x :topicid) + "http://new-base#c-ID-type-2") + (string= (getf x :psi) + "http://new-base#c-ID-type-2") + (not (getf x :ID)))) 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)) + (is (= (count-if #'(lambda(x) (> (length (getf x :topicid)) 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)) + (is-true (find-if + #'(lambda(x) + (and + (string= + (getf x :ID) + "http://test-tm/base/initial/xml-base/first#rdfID3") + (not (getf x :psi)) + (> (length (getf x :topicid))))) + 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 @@ -694,7 +735,9 @@ #'(lambda(x) (and (string= (getf x :type) (concatenate 'string *rdf-ns* "unknown")) - (string= (getf x :value) + (string= (getf x :topicid) + "http://xml-base/first/assoc-1") + (string= (getf x :psi) "http://xml-base/first/assoc-1") (not (getf x :ID)))) associations)) @@ -702,12 +745,14 @@ #'(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"))) + (string= (getf x :topicid) "arc1-nodeID") + (not (getf x :psi)))) associations)) (is-true (find-if #'(lambda(x) (and (string= (getf x :type) "http://test/arcs/arc2") - (> (length (getf x :value)) 0) + (> (length (getf x :topicid)) 0) + (not (getf x :psi)) (not (getf x :ID)))) associations)) (is-true (find-if @@ -715,39 +760,47 @@ (and (string= (getf x :type) "http://test/arcs/arc3") (string= (getf x :ID) "http://xml-base/first#rdfID-2") - (> (length (getf x :value)) 0))) + (not (getf x :psi)) + (> (length (getf x :topicid)) 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))) + (not (getf x :psi)) + (> (length (getf x :topicid)) 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))) + (not (getf x :psi)) + (> (length (getf x :topicid)) 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) + (string= (getf x :topicid) + "http://xml-base/first/con-1") + (string= (getf x :psi) "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"))) + (string= (getf x :topicid) "con-2") + (not (getf x :psi)))) associations)) (is-true (find-if #'(lambda(x) (and (string= (getf x :type) "http://test/arcs/arc8") (not (getf x :ID)) - (string= (getf x :value) + (string= (getf x :topicid) + "http://xml-base/first#rdfID-4") + (string= (getf x :psi) "http://xml-base/first#rdfID-4"))) associations)) (is-true (find-if @@ -755,14 +808,17 @@ (and (string= (getf x :type) "http://test/arcs/arc9") (string= (getf x :ID) "http://xml-base/first/add#rdfID-5") - (> (length (getf x :value))))) + (not (getf x :psi)) + (> (length (getf x :topicid))))) 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) + (string= (getf x :psi) + "http://xml-base/first/assoc-11") + (string= (getf x :topicid) "http://xml-base/first/assoc-11"))) associations)) (is-true (find-if @@ -771,7 +827,8 @@ (concatenate 'string *rdf-ns* "subClassOf")) (not (getf x :ID)) - (string= (getf x :value) "assoc-12"))) + (not (getf x :psi)) + (string= (getf x :topicid) "assoc-12"))) associations))))))) @@ -780,26 +837,30 @@ (concatenate 'string "<rdf:Description xmlns:rdf=\"" *rdf-ns* "\" " "xmlns:arcs=\"http://test/arcs/\" " "xml:base=\"http://xml-base/first\" " - "rdf:about=\"resource\" rdf:type=\"attr-type\">" + "rdf:about=\"resource\" rdf:type=\"attr-type\" " + "rdf:li=\"li-attr\">" "<rdf:li rdf:resource=\"anyType\" />" - "<rdf:li> </rdf:li>" + "<rdf:li> text-1 </rdf:li>" "<rdf:li rdf:nodeID=\"anyClass\" />" - "<rdf:li> </rdf:li>" + "<rdf:li> </rdf:li>" "<rdf:li rdf:resource=\"assoc-1\"/>" "<rdf:li rdf:type=\"assoc-2-type\">" " </rdf:li>" - "<rdf:li rdf:parseType=\"Literal\" />" - "<rdf:_123 arcs:arc5=\"text-arc5\" />" - "<rdf:arc6 rdf:ID=\"rdfID-3\"/>" - "<rdf:arcs rdf:ID=\"rdfID-4\"/>" + "<rdf:li rdf:parseType=\"Literal\" > text-3</rdf:li>" + "<rdf:_123 arcs:arc5=\"text-arc5\"/>" + "<rdf:arc6 rdf:ID=\"rdfID-3\"> text-4 </rdf:arc6>" + "<rdf:arcs rdf:ID=\"rdfID-4\" xml:lang=\" \">" + "text-5</rdf:arcs>" "</rdf:Description>"))) - (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))) + (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder))) + (tm-id "http://test-tm")) + (setf rdf-importer::*_n-map* nil) (is-true dom-1) (is (= (length (dom:child-nodes dom-1)))) (let ((node (elt (dom:child-nodes dom-1) 0))) + (is-true (rdf-importer::parse-node node)) (is-true (rdf-importer::parse-properties-of-node node)) - (is (= (length rdf-importer::*_n-map*) 7)) - (format t "~a~%" rdf-importer::*_n-map*) + (is (= (length rdf-importer::*_n-map*) 8)) (dotimes (iter (length rdf-importer::*_n-map*)) (is-true (find-if #'(lambda(x) @@ -808,8 +869,104 @@ 'string *rdf-ns* "_" (write-to-string (+ 1 iter))))) rdf-importer::*_n-map*))) + (let ((assocs + (rdf-importer::get-associations-of-node-content node tm-id nil)) + (content-literals + (rdf-importer::get-literals-of-node-content node tm-id nil "de")) + (attr-literals + (rdf-importer::get-literals-of-node node nil))) + (is (= (length assocs) 5)) + (is (= (length content-literals) 5)) + (is (= (length attr-literals) 1)) + (is-true (find-if #'(lambda(x) + (and (string= (getf x :type) + (concatenate 'string *rdf-ns* "_1")) + (not (getf x :lang)) + (string= (getf x :value) "li-attr") + (not (getf x :lang)) + (not (getf x :ID)))) + attr-literals)) + (is-true (find-if #'(lambda(x) + (and (string= (getf x :topicid) + "http://xml-base/first/anyType") + (string= (getf x :psi) + "http://xml-base/first/anyType") + (string= (getf x :type) + (concatenate 'string *rdf-ns* "_2")) + (not (getf x :ID)))) + assocs)) + (is-true (find-if #'(lambda(x) + (and (string= (getf x :value) " text-1 ") + (string= (getf x :lang) "de") + (string= (getf x :datatype) *xml-string*) + (string= (getf x :type) + (concatenate 'string *rdf-ns* "_3")) + (not (getf x :ID)))) + content-literals)) + (is-true (find-if #'(lambda(x) + (and (string= (getf x :topicid) "anyClass") + (not (getf x :psi)) + (string= (getf x :type) + (concatenate 'string *rdf-ns* "_4")) + (not (getf x :ID)))) + assocs)) + (is-true (find-if #'(lambda(x) + (and (string= (getf x :value) " ") + (string= (getf x :type) + (concatenate 'string *rdf-ns* "_5")) + (string= (getf x :datatype) *xml-string*) + (string= (getf x :lang) "de") + (not (getf x :ID)))) + content-literals)) + (is-true (find-if #'(lambda(x) + (and (string= (getf x :topicid) + "http://xml-base/first/assoc-1") + (string= (getf x :psi) + "http://xml-base/first/assoc-1") + (string= (getf x :type) + (concatenate 'string *rdf-ns* "_6")) + (not (getf x :ID)))) + assocs)) + (is-true (find-if #'(lambda(x) + (and (> (length (getf x :topicid)) 0) + (not (getf x :psi)) + (string= (getf x :type) + (concatenate 'string *rdf-ns* "_7")) + (not (getf x :ID)))) + assocs)) + (is-true (find-if #'(lambda(x) + (and (string= (getf x :value) " text-3") + (string= (getf x :lang) "de") + (string= (getf x :datatype) *xml-string*) + (string= (getf x :type) + (concatenate 'string *rdf-ns* "_8")) + (not (getf x :ID)))) + content-literals)) + (is-true (find-if #'(lambda(x) + (and (string= (getf x :value) " text-4 ") + (string= (getf x :lang) "de") + (string= (getf x :datatype) *xml-string*) + (string= + (getf x :type) + (concatenate 'string *rdf-ns* "arc6")) + (string= + (getf x :ID) + "http://xml-base/first#rdfID-3"))) + content-literals)) + (is-true (find-if #'(lambda(x) + (and (string= (getf x :value) "text-5") + (string= (getf x :lang) nil) + (string= (getf x :datatype) *xml-string*) + (string= + (getf x :type) + (concatenate 'string *rdf-ns* "arcs")) + (string= + (getf x :ID) + "http://xml-base/first#rdfID-4"))) + content-literals))) (rdf-importer::remove-node-properties-from-*_n-map* node) (is (= (length rdf-importer::*_n-map*) 0)))))) + Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Fri Jul 31 07:54:22 2009 @@ -22,7 +22,7 @@ &key (tm-id nil) (document-id (get-uuid)) - (revision (get-revision))) + (start-revision (d:get-revision))) (setf *document-id* document-id) (tm-id-p tm-id "rdf-importer") (let ((rdf-dom @@ -32,11 +32,12 @@ (unless elephant:*store-controller* (elephant:open-store (get-store-spec repository-path))) - (import-dom rdf-dom revision :tm-id tm-id :document-id document-id)) + (import-dom rdf-dom start-revision :tm-id tm-id :document-id document-id)) (setf *_n-map* nil)) -(defun import-dom (rdf-dom revision &key (tm-id nil) (document-id *document-id*)) +(defun import-dom (rdf-dom start-revision + &key (tm-id nil) (document-id *document-id*)) (tm-id-p tm-id "import-dom") (let ((xml-base (get-xml-base rdf-dom)) (xml-lang (get-xml-lang rdf-dom)) @@ -48,14 +49,15 @@ (let ((children (child-nodes-or-text rdf-dom))) (when children (loop for child across children - do (import-node child tm-id revision :document-id document-id + do (import-node child tm-id start-revision :document-id document-id :xml-base xml-base :xml-lang xml-lang)))) - (import-node rdf-dom tm-id revision :document-id document-id + (import-node rdf-dom tm-id start-revision :document-id document-id :xml-base xml-base :xml-lang xml-lang)))) -(defun import-node (elem tm-id revision &key (document-id *document-id*) +(defun import-node (elem tm-id start-revision &key (document-id *document-id*) (xml-base nil) (xml-lang nil)) + (remove-node-properties-from-*_n-map* elem) ;in case of an failed last call (tm-id-p tm-id "import-node") (parse-node elem) (let ((fn-xml-base (get-xml-base elem :old-base xml-base))) @@ -69,20 +71,23 @@ xml-base xml-lang))) (associations (get-associations-of-node-content elem tm-id xml-base)) (types (append (list - (list :value (get-type-of-node-name elem) :ID nil)) + (list :topicid (get-type-of-node-name elem) + :psi (get-type-of-node-name elem) + :ID nil)) (get-types-of-node-content elem tm-id fn-xml-base))) (super-classes (get-super-classes-of-node-content elem tm-id xml-base))) - + (let ((topic-stub (make-topic-stub-from-node about ID nodeID UUID + start-revision + :document-id document-id))) + ;TODO: - ;get-topic by topic id - ;make psis - ;if no ones exist create one with topic id - ;add psis - ;make nametype topic with topic id + ;*get-topic by topic id + ;*make psis + ;*if the topic does not exist create one with topic id + ;*add psis ;make instance-of associations ;make topictype topics with topic id - ;make super-sub-class assoications - ;make and add names + ;make super-sub-class associations ;make occurrencetype topics with topic id ;make and add occurrences ;make referenced topic with topic id @@ -91,8 +96,46 @@ ;TODO: start recursion ... (remove-node-properties-from-*_n-map* elem) - (or tm-id document-id revision about nodeID ID UUID literals ;TODO: remove - associations types super-classes)))) + (or tm-id document-id topic-stub nodeID UUID literals ;TODO: remove + associations types super-classes))))) + + +(defun make-topic-stub-from-node (about ID nodeId UUID start-revision + &key (document-id *document-id*)) + "Returns a topic corresponding to the passed parameters. + When the searched topic does not exist there will be created one. + If about or ID is set there will aslo be created a new PSI." +; (let ((topic-id (or about ID nodeID UUID)) +; (psi-value (or about ID)) +; (err-pref "From make-topic-stub-from-node(): ")) +; (unless topic-id +; (error "~aone of about ID nodeID UUID must be set!" +; err-pref)) +; (elephant:ensure-transaction (:txn-nosync t) +; (let ((top (get-item-by-id topic-id :xtm-id document-id +; :revision start-revision))) +; (let ((topic-psis (map 'list #'d:uri (d:psis top)))) +; (if (and psi-value +; (not (find psi-value topic-psis :test #'string=))) +; (let ((psis (list (d::make-instance +; 'd:PersistentIdC +; :uri psi-value +; :start-revision start-revision)))) +; ;create only a new topic if there existed no one +; (d::make-instance 'd:TopicC +; :topicid topic-id +; :psis psis +; :xtm-id document-id +; :start-revision start-revision)) +; top)))))) +) + + +(defun make-occurrence-from-node (top literals start-revision + &key (document-id *document-id*)) +; (loop for literal in literals +; do (let ((type + ) (defun get-literals-of-node-content (node tm-id xml-base xml-lang) @@ -110,10 +153,14 @@ (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)))) + :ns-uri *rdf2tm-ns*)) + (type (get-ns-attribute property "type")) + (prop-literals (get-literals-of-property + property nil))) + (and (or (or datatype + (string= parseType "Literal")) + (not (or nodeID resource UUID parseType))) + (not (or type prop-literals)))) collect (let ((content (child-nodes-or-text property)) (ID (get-absolute-attribute property tm-id fn-xml-base "ID")) @@ -151,8 +198,10 @@ (let ((attr-type (if (get-ns-attribute node "type") (list - (list :value (absolutize-value (get-ns-attribute node "type") - fn-xml-base tm-id) + (list :topicid (absolutize-value (get-ns-attribute node "type") + fn-xml-base tm-id) + :psi (absolutize-value (get-ns-attribute node "type") + fn-xml-base tm-id) :ID nil)) nil)) (content-types @@ -168,15 +217,18 @@ (ID (get-absolute-attribute child tm-id fn-xml-base "ID"))) (if (or nodeID resource UUID) - (list :value (or nodeID resource UUID) + (list :topicid (or nodeID resource UUID) + :psi resource :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))))))))) + (let ((refs + (get-node-refs + (child-nodes-or-text child) + tm-id child-xml-base))) + (list :topicid (getf (first refs) :topicid) + :psi (getf (first refs) :psi) + :ID ID))))))))) (remove-if #'null (append attr-type content-types))))) @@ -286,16 +338,16 @@ 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)))))))) + (if (or nodeID resource UUID) + (list :topicid (or nodeID resource UUID) + :psi resource + :ID ID) + (let ((refs (get-node-refs + (child-nodes-or-text property) + tm-id prop-xml-base))) + (list :topicid (getf (first refs) :topicid) + :psi (getf (first refs) :psi) + :ID ID))))))))) (defun get-associations-of-node-content (node tm-id xml-base) @@ -336,14 +388,15 @@ (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 + (if (or nodeID resource UUID) + (list :type full-name + :topicid (or nodeID resource UUID) + :psi resource + :ID ID) + (let ((refs (get-node-refs + (child-nodes-or-text property) + tm-id prop-xml-base))) + (list :type full-name + :topicid (getf (first refs) :topicid) + :psi (getf (first refs) :psi) + :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 Fri Jul 31 07:54:22 2009 @@ -7,7 +7,7 @@ ;;+----------------------------------------------------------------------------- (defpackage :rdf-importer - (:use :cl :cxml :elephant :datamodel :isidorus-threading) + (:use :cl :cxml :elephant :datamodel :isidorus-threading :datamodel) (:import-from :constants *rdf-ns* *rdfs-ns* @@ -37,8 +37,6 @@ concatenate-uri push-string node-to-string) - (:import-from :datamodel - get-revision) (:import-from :xml-importer get-uuid get-store-spec) @@ -52,7 +50,7 @@ "Statement" "Property" "XMLLiteral")) (defvar *rdf-properties* (list "type" "first" "rest" "subject" "predicate" - "object")) + "object" "li")) (defvar *rdfs-types* (list "Resource" "Literal" "Class" "Datatype" "Container" "ContainerMembershipProperty")) @@ -99,10 +97,10 @@ (defun unset-_n-name (property) - (setf *_n-map* (remove-if - #'(lambda(x) - (eql (getf x :elem) property)) - *_n-map*))) + "Deletes the passed property tupple of the *_n-map* list." + (setf *_n-map* (remove-if #'(lambda(x) + (eql (getf x :elem) property)) + *_n-map*))) (defun remove-node-properties-from-*_n-map* (node) @@ -111,7 +109,10 @@ (let ((properties (child-nodes-or-text node))) (when properties (loop for property across properties - do (unset-_n-name property))))) + do (unset-_n-name property)))) + (dom:map-node-map + #'(lambda(attr) (unset-_n-name attr)) + (dom:attributes node))) (defun get-type-of-node-name (node) @@ -221,7 +222,8 @@ (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)))))) + (list :topicid (or ID about nodeID UUID) + :psi (or ID about))))))) (defun parse-property-name (property _n-counter) @@ -239,7 +241,8 @@ (when (string= property-name "RDF") (error "~ardf:RDF not allowed here!" err-pref)) - (unless (find property-name *rdf-properties* :test #'string=) + (unless (or (find property-name *rdf-properties* :test #'string=) + (_n-p property)) (format t "~aWarning: rdf:~a is not a known RDF property!~%" err-pref property-name))) (when (string= property-ns *rdfs-ns*) @@ -326,7 +329,7 @@ (string= node-ns *rdf-ns*)) (> (length literals) 0)) (not (or nodeID resource)) - (not content)) + (not content)) (dom:set-attribute-ns property *rdf2tm-ns* "UUID" (get-uuid))) (when (or about subClassOf) (error "~a~a not allowed here!" @@ -361,8 +364,19 @@ (defun parse-properties-of-node (node) + "Parses all node's properties by calling the parse-propery + function and sets all rdf:li properties as a tupple to the + *_n-map* list." (let ((child-nodes (child-nodes-or-text node)) (_n-counter 0)) + (when (get-ns-attribute node "li") + (dom:map-node-map + #'(lambda(attr) + (when (and (string= (get-node-name attr) "li") + (string= (dom:namespace-uri attr) *rdf-ns*)) + (incf _n-counter) + (set-_n-name attr _n-counter))) + (dom:attributes node))) (when child-nodes (loop for property across child-nodes do (let ((prop-name (get-node-name property)) Modified: trunk/src/xml/xtm/tools.lisp ============================================================================== --- trunk/src/xml/xtm/tools.lisp (original) +++ trunk/src/xml/xtm/tools.lisp Fri Jul 31 07:54:22 2009 @@ -117,10 +117,17 @@ its value as a string." (declare (dom:element elem)) (let ((new-lang - (get-ns-attribute elem "lang" :ns-uri *xml-ns*))) + (let ((val + (get-ns-attribute elem "lang" :ns-uri *xml-ns*))) + (when val + (string-trim '(#\Space #\Tab #\Newline) val))))) (if (dom:has-attribute-ns elem *xml-ns* "lang") - new-lang - old-lang))) + (if (= (length new-lang) 0) + nil + new-lang) + (if (= (length old-lang) 0) + nil + old-lang)))) (defun get-xml-base(elem &key (old-base nil)) @@ -132,7 +139,9 @@ (if (find #\# (get-ns-attribute elem "base" :ns-uri *xml-ns*)) (error "From get-xml-base(): the base-uri ~a is not valid" (get-ns-attribute elem *xml-ns* "base")) - (get-ns-attribute elem "base" :ns-uri *xml-ns*)))) + (when (get-ns-attribute elem "base" :ns-uri *xml-ns*) + (string-trim '(#\Space #\Tab #\Newline) + (get-ns-attribute elem "base" :ns-uri *xml-ns*)))))) (if (and (> (length inner-base) 0) (eql (elt inner-base 0) #\/)) (subseq inner-base 1 (length inner-base))