[isidorus-cvs] r112 - in trunk/src: unit_tests xml/rdf
Lukas Giessmann
lgiessmann at common-lisp.net
Mon Aug 10 10:48:59 UTC 2009
Author: lgiessmann
Date: Mon Aug 10 06:48:58 2009
New Revision: 112
Log:
rdf-importer: fixed a problem with rdf:li, so distributed rdf:li elementes ar not merged. intead of merging names the names of the form rdf:_n are incremented across the entire document for the same resource. when the user mixes rdf:li elements and rdf:_n elements on one resource there is no separate handling, i.e.these elements are merged anyway.
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 Mon Aug 10 06:48:58 2009
@@ -880,16 +880,18 @@
(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*) 8))
+ (is-true (rdf-importer::parse-properties-of-node
+ node "http://xml-base/first/resource"))
+ (is (= (length rdf-importer::*_n-map*) 1))
+ (is (= (length (getf (first rdf-importer::*_n-map*) :props)) 8))
(dotimes (iter (length rdf-importer::*_n-map*))
(is-true (find-if
#'(lambda(x)
- (string= (getf x :type)
+ (string= (getf x :name)
(concatenate
'string *rdf-ns* "_"
(write-to-string (+ 1 iter)))))
- rdf-importer::*_n-map*)))
+ (getf (first rdf-importer::*_n-map*) :props))))
(let ((assocs
(rdf-importer::get-associations-of-node-content node tm-id nil))
(content-literals
@@ -985,8 +987,7 @@
(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))))))
+ (setf rdf-importer::*_n-map* nil)))))
(test test-import-node-1
@@ -1741,7 +1742,7 @@
(date "http://www.w3.org/2001/XMLSchema#date")
(de (d:get-item-by-id "http://isidorus/rdf2tm_mapping/scope#de"))
(long "http://www.w3.org/2001/XMLSchema#unsignedLong"))
- (is (= (length topics) 65))
+ (is (= (length topics) 66))
(is (= (length occs) 23))
(is (= (length assocs) 30))
(is-true de)
@@ -2285,7 +2286,7 @@
#'(lambda(x)
(and (= (length (d:psis (d:instance-of x))) 1)
(string= (d:uri (first (d:psis (d:instance-of x))))
- (concatenate 'string constants:*rdf-ns* "_1"))
+ (concatenate 'string constants:*rdf-ns* "_2"))
(find-if
#'(lambda(y)
(and (eql (d:instance-of y) isi-subject)
@@ -2304,7 +2305,7 @@
#'(lambda(x)
(and (= (length (d:psis (d:instance-of x))) 1)
(string= (d:uri (first (d:psis (d:instance-of x))))
- (concatenate 'string constants:*rdf-ns* "_2"))
+ (concatenate 'string constants:*rdf-ns* "_3"))
(find-if
#'(lambda(y)
(and (eql (d:instance-of y) isi-subject)
@@ -2641,6 +2642,7 @@
(bag (get-item-by-id (concatenate 'string *rdf-ns* "Bag")))
(_1 (get-item-by-id (concatenate 'string *rdf-ns* "_1")))
(_2 (get-item-by-id (concatenate 'string *rdf-ns* "_2")))
+ (_3 (get-item-by-id (concatenate 'string *rdf-ns* "_3")))
(zauberlehrling
(get-item-by-id "http://some.where/poem/Der_Zauberlehrling"))
(poem (get-item-by-id (concatenate 'string types "Poem")))
@@ -2685,6 +2687,7 @@
(check-topic bag (concatenate 'string *rdf-ns* "Bag"))
(check-topic _1 (concatenate 'string *rdf-ns* "_1"))
(check-topic _2 (concatenate 'string *rdf-ns* "_2"))
+ (check-topic _3 (concatenate 'string *rdf-ns* "_3"))
(check-topic zauberlehrling "http://some.where/poem/Der_Zauberlehrling")
(check-topic poem (concatenate 'string types "Poem"))
(check-topic dateRange (concatenate 'string arcs "dateRange"))
Modified: trunk/src/xml/rdf/importer.lisp
==============================================================================
--- trunk/src/xml/rdf/importer.lisp (original)
+++ trunk/src/xml/rdf/importer.lisp Mon Aug 10 06:48:58 2009
@@ -105,12 +105,13 @@
; parseType="Collection" -> see also import-arc
(let ((fn-xml-base (get-xml-base elem :old-base xml-base))
(fn-xml-lang (get-xml-lang elem :old-lang xml-lang)))
- (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"))
- (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*))
- (literals (append (get-literals-of-node elem fn-xml-lang)
+ (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*)))
+ (parse-properties-of-node elem (or about nodeID ID UUID))
+
+ (let ((literals (append (get-literals-of-node elem fn-xml-lang)
(get-literals-of-node-content
elem tm-id xml-base fn-xml-lang)))
(associations (get-associations-of-node-content elem tm-id xml-base))
@@ -144,8 +145,7 @@
:document-id document-id
:xml-base xml-base
:xml-lang xml-lang)
- (remove-node-properties-from-*_n-map* elem)
- this))))))
+ this)))))))
(defun import-arc (elem tm-id start-revision
@@ -163,7 +163,7 @@
(and parseType
(string/= parseType "Collection")))
(when UUID
- (parse-properties-of-node elem)
+ (parse-properties-of-node elem UUID)
(with-tm (start-revision document-id tm-id)
(let ((this (get-item-by-id UUID :xtm-id document-id
:revision start-revision)))
Modified: trunk/src/xml/rdf/rdf_tools.lisp
==============================================================================
--- trunk/src/xml/rdf/rdf_tools.lisp (original)
+++ trunk/src/xml/rdf/rdf_tools.lisp Mon Aug 10 06:48:58 2009
@@ -108,53 +108,73 @@
(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)
- "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 find-_n-name-of-property (property)
+ "Returns the properties name of the form rdf:_n or nil."
+ (let ((owner
+ (find-if
+ #'(lambda(x)
+ (find-if
+ #'(lambda(y)
+ (eql (getf y :elem) property))
+ (getf x :props)))
+ *_n-map*)))
+ (let ((elem (find-if #'(lambda(x)
+ (eql (getf x :elem) property))
+ (getf owner :props))))
+ (when elem
+ (getf elem :name)))))
-(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 :trim t)))
- (when properties
- (loop for property across properties
- do (unset-_n-name property))))
- (dom:map-node-map
- #'(lambda(attr) (unset-_n-name attr))
- (dom:attributes node)))
+
+
+(defun find-_n-name (owner-identifier property)
+ "Returns a name of the form rdf:_n of the property element
+ when it owns the tagname rdf:li and exists in the *_n-map* list.
+ Otherwise the return value is nil."
+ (let ((owner (find-if #'(lambda(x)
+ (string= (getf x :owner) owner-identifier))
+ *_n-map*)))
+ (when owner
+ (let ((prop (find-if #'(lambda(x)
+ (eql (getf x :elem) property))
+ (getf owner :props))))
+ (getf prop :name)))))
+
+
+(defun set-_n-name (owner-identifier property)
+ "Sets a new name of the form _n for the passed property element and
+ adds it to the list *_n-map*. If the property already exists in the
+ *_n-map* list, there won't be created a new entry but returned the
+ stored value name."
+ (let ((name (find-_n-name owner-identifier property)))
+ (if name
+ name
+ (let ((owner (find-if #'(lambda(x)
+ (string= (getf x :owner) owner-identifier))
+ *_n-map*)))
+ (if owner
+ (let ((new-name
+ (concatenate
+ 'string *rdf-ns* "_"
+ (write-to-string (+ (length (getf owner :props)) 1)))))
+ (push (list :elem property
+ :name new-name)
+ (getf owner :props))
+ new-name)
+ (progn
+ (push
+ (list :owner owner-identifier
+ :props (list
+ (list :elem property
+ :name (concatenate 'string *rdf-ns* "_1"))))
+ *_n-map*)
+ "_1"))))))
(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*)))
+ (let ((map-item (find-_n-name-of-property node)))
(if map-item
- (getf map-item :type)
+ map-item
(let ((node-name (get-node-name node))
(node-ns (dom:namespace-uri node)))
(concatenate-uri node-ns node-name)))))
@@ -258,7 +278,7 @@
:psi (or ID about)))))))
-(defun parse-property-name (property _n-counter)
+(defun parse-property-name (property owner-identifier)
"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."
@@ -286,11 +306,12 @@
err-pref property-name)))
(when (and (string= property-ns *rdf-ns*)
(string= property-name "li"))
- (set-_n-name property _n-counter)))
+ (set-_n-name owner-identifier property)))
+ ;(set-_n-name property _n-counter)))
t)
-(defun parse-property (property _n-counter)
+(defun parse-property (property owner-identifier)
"Parses a property that represents a rdf-arc."
(declare (dom:element property))
(let ((err-pref "From parse-property(): ")
@@ -305,7 +326,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 _n-counter)
+ (parse-property-name property owner-identifier)
(when (and parseType
(or nodeID resource datatype type literals))
(error "~awhen rdf:parseType is set the attributes: ~a => ~a are not allowed!"
@@ -382,7 +403,7 @@
(string= node-ns *rdfs-ns*)))
(and (> (length content) 0)
(stringp content)))
- (error "~awhen ~a not allowed to own literal content: ~a!"
+ (error "~awhen property is ~a literal content is not allowed: ~a!"
err-pref (if (string= node-name "type")
"rdf:type"
"rdfs:subClassOf")
@@ -398,28 +419,22 @@
t)
-(defun parse-properties-of-node (node)
+(defun parse-properties-of-node (node owner-identifier)
"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 :trim t))
- (_n-counter 0))
+ (let ((child-nodes (child-nodes-or-text node :trim t)))
+ ;(_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)))
+ (set-_n-name owner-identifier attr)))
(dom:attributes node)))
(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)))))
+ do (parse-property property owner-identifier))))
t)
More information about the Isidorus-cvs
mailing list