[isidorus-cvs] r99 - in trunk/src: unit_tests xml/rdf
Lukas Giessmann
lgiessmann at common-lisp.net
Thu Jul 30 14:25:24 UTC 2009
Author: lgiessmann
Date: Thu Jul 30 10:25:23 2009
New Revision: 99
Log:
added rdf:li handling for to rdf-importer
Modified:
trunk/src/unit_tests/rdf_importer_test.lisp
trunk/src/xml/rdf/importer.lisp
trunk/src/xml/rdf/rdf_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 10:25:23 2009
@@ -35,7 +35,8 @@
:test-get-types
:test-get-literals-of-content
:test-get-super-classes-of-node-content
- :test-get-associations-of-node-content))
+ :test-get-associations-of-node-content
+ :test-parse-properties-of-node))
(declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0)))
@@ -258,7 +259,7 @@
(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)))
+ do (is-true (rdf-importer::parse-property property 0)))
(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"
@@ -267,70 +268,70 @@
: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))
+ (signals error (rdf-importer::parse-property prop 0))
(dom:set-attribute-ns prop *rdf-ns* "parseType" "Resource")
- (is-true (rdf-importer::parse-property prop))
+ (is-true (rdf-importer::parse-property prop 0))
(dom:set-attribute-ns prop *rdf-ns* "ID" "newID")
- (is-true (rdf-importer::parse-property prop))
+ (is-true (rdf-importer::parse-property prop 0))
(dom:set-attribute-ns prop *rdf-ns* "bad" "bad")
- (signals error (rdf-importer::parse-property prop))
+ (signals error (rdf-importer::parse-property prop 0))
(dom:remove-attribute-ns prop *rdf-ns* "bad")
- (is-true (rdf-importer::parse-property prop))
+ (is-true (rdf-importer::parse-property prop 0))
(dom:append-child prop text-node)
- (signals error (rdf-importer::parse-property prop))
+ (signals error (rdf-importer::parse-property prop 0))
(dom:remove-child prop text-node)
- (is-true (rdf-importer::parse-property prop)))
+ (is-true (rdf-importer::parse-property prop 0)))
(let ((prop (elt children 1)))
(dom:set-attribute-ns prop *rdf-ns* "nodeID" "bad")
- (signals error (rdf-importer::parse-property prop))
+ (signals error (rdf-importer::parse-property prop 0))
(dom:remove-attribute-ns prop *rdf-ns* "nodeID")
- (is-true (rdf-importer::parse-property prop))
+ (is-true (rdf-importer::parse-property prop 0))
(dom:set-attribute-ns prop *rdf-ns* "ID" "newID")
- (is-true (rdf-importer::parse-property prop))
+ (is-true (rdf-importer::parse-property prop 0))
(dom:append-child prop text-node)
- (signals error (rdf-importer::parse-property prop))
+ (signals error (rdf-importer::parse-property prop 0))
(dom:remove-child prop text-node)
- (is-true (rdf-importer::parse-property prop)))
+ (is-true (rdf-importer::parse-property prop 0)))
(let ((prop (elt children 3)))
(dom:append-child prop text-node)
- (signals error (rdf-importer::parse-property prop))
+ (signals error (rdf-importer::parse-property prop 0))
(dom:remove-child prop text-node)
- (is-true (rdf-importer::parse-property prop)))
+ (is-true (rdf-importer::parse-property prop 0)))
(let ((prop (elt children 4)))
(dom:append-child prop text-node)
- (signals error (rdf-importer::parse-property prop))
+ (signals error (rdf-importer::parse-property prop 0))
(dom:remove-child prop text-node)
- (is-true (rdf-importer::parse-property prop)))
+ (is-true (rdf-importer::parse-property prop 0)))
(let ((prop (elt children 5)))
(dom:set-attribute-ns prop *rdf-ns* "type" "newType")
- (is-true (rdf-importer::parse-property prop))
+ (is-true (rdf-importer::parse-property prop 0))
(dom:set-attribute-ns prop *rdf-ns* "unknown" "unknown")
- (is-true (rdf-importer::parse-property prop))
+ (is-true (rdf-importer::parse-property prop 0))
(dom:append-child prop text-node)
- (signals error (rdf-importer::parse-property prop))
+ (signals error (rdf-importer::parse-property prop 0))
(dom:remove-child prop text-node)
- (is-true (rdf-importer::parse-property prop))
+ (is-true (rdf-importer::parse-property prop 0))
(dom:remove-attribute-ns prop *rdf-ns* "unknown")
- (is-true (rdf-importer::parse-property prop))
+ (is-true (rdf-importer::parse-property prop 0))
(dom:append-child prop text-node)
- (signals error (rdf-importer::parse-property prop))
+ (signals error (rdf-importer::parse-property prop 0))
(dom:remove-child prop text-node)
- (is-true (rdf-importer::parse-property prop)))
+ (is-true (rdf-importer::parse-property prop 0)))
(let ((prop (elt children 10)))
(dom:set-attribute-ns prop *rdf-ns* "type" "newType")
- (signals error (rdf-importer::parse-property prop))
+ (signals error (rdf-importer::parse-property prop 0))
(dom:remove-attribute-ns prop *rdf-ns* "type")
- (is-true (rdf-importer::parse-property prop))
+ (is-true (rdf-importer::parse-property prop 0))
(dom:set-attribute-ns prop *rdf-ns* "nodeID" "newNodeID")
- (signals error (rdf-importer::parse-property prop))
+ (signals error (rdf-importer::parse-property prop 0))
(dom:remove-attribute-ns prop *rdf-ns* "nodeID")
- (is-true (rdf-importer::parse-property prop))
+ (is-true (rdf-importer::parse-property prop 0))
(dom:set-attribute-ns prop *rdf-ns* "resource" "newResource")
- (signals error (rdf-importer::parse-property prop))
+ (signals error (rdf-importer::parse-property prop 0))
(dom:remove-attribute-ns prop *rdf-ns* "resource")
- (is-true (rdf-importer::parse-property prop))
+ (is-true (rdf-importer::parse-property prop 0))
(dom:set-attribute-ns prop *rdf-ns* "ID" "newID")
- (is-true (rdf-importer::parse-property prop))))))))
+ (is-true (rdf-importer::parse-property prop 0))))))))
(test test-get-types
@@ -382,7 +383,7 @@
(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))
+ do (rdf-importer::parse-property property 0))
(let ((types
(append
(list (list
@@ -477,7 +478,7 @@
(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))))
+ (elt (dom:child-nodes node) iter) 0)))
(let ((literals (rdf-importer::get-literals-of-node-content
node tm-id nil nil)))
(is (= (length literals) 7))
@@ -598,7 +599,7 @@
(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)))
+ do (is-true (rdf-importer::parse-property property 0)))
(let ((super-classes (rdf-importer::get-super-classes-of-node-content
node tm-id xml-base)))
(is (= (length super-classes) 8))
@@ -637,7 +638,7 @@
(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))))))))
+ (elt (rdf-importer::child-nodes-or-text node) 1) 0)))))))
(test test-get-associations-of-node-content
@@ -685,7 +686,7 @@
(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)))
+ do (is-true (rdf-importer::parse-property property 0)))
(let ((associations
(rdf-importer::get-associations-of-node-content node tm-id nil)))
(is (= (length associations) 12))
@@ -774,6 +775,44 @@
associations)))))))
+(test test-parse-properties-of-node
+ (let ((doc-1
+ (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:li rdf:resource=\"anyType\" />"
+ "<rdf:li> </rdf:li>"
+ "<rdf:li rdf:nodeID=\"anyClass\" />"
+ "<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: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)))
+ (is-true (rdf-importer::parse-properties-of-node node))
+ (is (= (length rdf-importer::*_n-map*) 7))
+ (format t "~a~%" rdf-importer::*_n-map*)
+ (dotimes (iter (length rdf-importer::*_n-map*))
+ (is-true (find-if
+ #'(lambda(x)
+ (string= (getf x :type)
+ (concatenate
+ 'string *rdf-ns* "_"
+ (write-to-string (+ 1 iter)))))
+ rdf-importer::*_n-map*)))
+ (rdf-importer::remove-node-properties-from-*_n-map* node)
+ (is (= (length rdf-importer::*_n-map*) 0))))))
+
+
+
(defun run-rdf-importer-tests()
(it.bese.fiveam:run! 'test-get-literals-of-node)
(it.bese.fiveam:run! 'test-parse-node)
@@ -782,4 +821,5 @@
(it.bese.fiveam:run! 'test-get-types)
(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
+ (it.bese.fiveam:run! 'test-get-associations-of-node-content)
+ (it.bese.fiveam:run! 'test-parse-properties-of-node))
\ 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 10:25:23 2009
@@ -21,7 +21,8 @@
(defun rdf-importer (rdf-xml-path repository-path
&key
(tm-id nil)
- (document-id (get-uuid)))
+ (document-id (get-uuid))
+ (revision (get-revision)))
(setf *document-id* document-id)
(tm-id-p tm-id "rdf-importer")
(let ((rdf-dom
@@ -31,11 +32,11 @@
(unless elephant:*store-controller*
(elephant:open-store
(get-store-spec repository-path)))
- (import-dom rdf-dom :tm-id tm-id :document-id document-id)))
+ (import-dom rdf-dom revision :tm-id tm-id :document-id document-id))
+ (setf *_n-map* nil))
-
-(defun import-dom (rdf-dom &key (tm-id nil) (document-id *document-id*))
+(defun import-dom (rdf-dom 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))
@@ -47,21 +48,18 @@
(let ((children (child-nodes-or-text rdf-dom)))
(when children
(loop for child across children
- do (import-node child tm-id :document-id document-id
+ do (import-node child tm-id revision :document-id document-id
:xml-base xml-base :xml-lang xml-lang))))
- (import-node rdf-dom tm-id :document-id document-id
+ (import-node rdf-dom tm-id revision :document-id document-id
:xml-base xml-base :xml-lang xml-lang))))
-(defun import-node (elem tm-id &key (document-id *document-id*)
+(defun import-node (elem tm-id revision &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)
(let ((fn-xml-base (get-xml-base elem :old-base xml-base)))
- (when (child-nodes-or-text elem)
- (loop for property across (child-nodes-or-text elem)
- do (parse-property property)))
+ (parse-properties-of-node elem)
(let ((about (get-absolute-attribute elem tm-id xml-base "about"))
(nodeID (get-ns-attribute elem "nodeID"))
(ID (get-absolute-attribute elem tm-id xml-base "ID"))
@@ -74,10 +72,27 @@
(list :value (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)))
- ;TODO: create elephant-objects
- ;TODO: recursion on all nodes/arcs
- (declare (ignorable about nodeID ID UUID literals associations ;TODO: remove
- types super-classes)))))
+
+ ;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
+ ;make instance-of associations
+ ;make topictype topics with topic id
+ ;make super-sub-class assoications
+ ;make and add names
+ ;make occurrencetype topics with topic id
+ ;make and add occurrences
+ ;make referenced topic with topic id
+ ;make and add associations
+
+
+ ;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))))
(defun get-literals-of-node-content (node tm-id xml-base xml-lang)
@@ -128,13 +143,6 @@
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."
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 10:25:23 2009
@@ -37,6 +37,8 @@
concatenate-uri
push-string
node-to-string)
+ (:import-from :datamodel
+ get-revision)
(:import-from :xml-importer
get-uuid
get-store-spec)
@@ -59,18 +61,71 @@
"range" "range" "label" "comment"
"member" "seeAlso" "isDefinedBy"))
-(defun _n-p (node-name)
+(defvar *_n-map* nil)
+
+
+(defun _n-p (node)
"Returns t if the given value is of the form _[0-9]+"
- (when (and node-name
- (> (length node-name) 0)
- (eql (elt node-name 0) #\_))
- (let ((rest
- (subseq node-name 1 (length node-name))))
- (declare (string node-name))
- (handler-case (let ((int
- (parse-integer rest)))
- int)
- (condition () nil)))))
+ (let ((node-name (get-node-name node)))
+ (when (and node-name
+ (> (length node-name) 0)
+ (eql (elt node-name 0) #\_))
+ (let ((rest
+ (subseq node-name 1 (length node-name))))
+ (declare (string node-name))
+ (handler-case (let ((int
+ (parse-integer rest)))
+ int)
+ (condition () nil))))))
+
+
+(defun set-_n-name (property _n-counter)
+ "Returns a name of the form <rdf>_[1-9][0-9]* and adds a tupple
+ of the form :elem <dom-elem> :type<<rdf>_[1-9][0-9]*> to the
+ list *_n-map*.
+ If the dom-elem is already contained in the list only the
+ <rdf>_[1-9][0-9]* name is returned."
+ (let ((map-item (find-if #'(lambda(x)
+ (eql (getf x :elem) property))
+ *_n-map*)))
+ (if map-item
+ (getf map-item :type)
+ (let ((new-type-name
+ (concatenate 'string *rdf-ns* "_" (write-to-string _n-counter))))
+ (push (list :elem property
+ :type new-type-name)
+ *_n-map*)
+ new-type-name))))
+
+
+(defun unset-_n-name (property)
+ (setf *_n-map* (remove-if
+ #'(lambda(x)
+ (eql (getf x :elem) property))
+ *_n-map*)))
+
+
+(defun remove-node-properties-from-*_n-map* (node)
+ "Removes all node's properties from the list *_n-map*."
+ (declare (dom:element node))
+ (let ((properties (child-nodes-or-text node)))
+ (when properties
+ (loop for property across properties
+ do (unset-_n-name property)))))
+
+
+(defun get-type-of-node-name (node)
+ "Returns the type of the node name (namespace + tagname).
+ When the node is contained in *_n-map* the corresponding
+ value of this map will be returned."
+ (let ((map-item (find-if #'(lambda(x)
+ (eql (getf x :elem) node))
+ *_n-map*)))
+ (if map-item
+ (getf map-item :type)
+ (let ((node-name (get-node-name node))
+ (node-ns (dom:namespace-uri node)))
+ (concatenate-uri node-ns node-name)))))
(defun parse-node-name (node)
@@ -169,7 +224,7 @@
(or ID nodeID about UUID))))))
-(defun parse-property-name (property)
+(defun parse-property-name (property _n-counter)
"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."
@@ -193,11 +248,14 @@
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))))
+ err-pref property-name)))
+ (when (and (string= property-ns *rdf-ns*)
+ (string= property-name "li"))
+ (set-_n-name property _n-counter)))
t)
-(defun parse-property (property)
+(defun parse-property (property _n-counter)
"Parses a property that represents a rdf-arc."
(declare (dom:element property))
(let ((err-pref "From parse-property(): ")
@@ -212,7 +270,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)
+ (parse-property-name property _n-counter)
(when (and parseType
(or nodeID resource datatype type literals))
(error "~awhen rdf:parseType is set the attributes: ~a => ~a are not allowed!"
@@ -302,6 +360,20 @@
t)
+(defun parse-properties-of-node (node)
+ (let ((child-nodes (child-nodes-or-text node))
+ (_n-counter 0))
+ (when child-nodes
+ (loop for property across child-nodes
+ do (let ((prop-name (get-node-name property))
+ (prop-ns (dom:namespace-uri node)))
+ (when (and (string= prop-name "li")
+ (string= prop-ns *rdf-ns*))
+ (incf _n-counter))
+ (parse-property property _n-counter)))))
+ t)
+
+
(defun get-absolute-attribute (elem tm-id xml-base attr-name
&key (ns-uri *rdf-ns*))
"Returns an absolute 'attribute' or nil."
More information about the Isidorus-cvs
mailing list