[isidorus-cvs] r100 - in trunk/src: unit_tests xml/rdf xml/xtm
Lukas Giessmann
lgiessmann at common-lisp.net
Fri Jul 31 11:54:47 UTC 2009
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))
More information about the Isidorus-cvs
mailing list