[isidorus-cvs] r139 - trunk/src/xml/rdf
Lukas Giessmann
lgiessmann at common-lisp.net
Wed Sep 9 07:42:01 UTC 2009
Author: lgiessmann
Date: Wed Sep 9 03:42:00 2009
New Revision: 139
Log:
rdf-importer: fixed a bug with xml:base and xml:lang; renamed some parameters for a better understanding
Modified:
trunk/src/xml/rdf/importer.lisp
trunk/src/xml/rdf/rdf_tools.lisp
Modified: trunk/src/xml/rdf/importer.lisp
==============================================================================
--- trunk/src/xml/rdf/importer.lisp (original)
+++ trunk/src/xml/rdf/importer.lisp Wed Sep 9 03:42:00 2009
@@ -84,31 +84,36 @@
(let ((children (child-nodes-or-text rdf-dom :trim t)))
(when children
(loop for child across children
- 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 start-revision :document-id document-id
- :xml-base xml-base :xml-lang xml-lang)))
+ do (import-node child tm-id start-revision
+ :document-id document-id
+ :parent-xml-base xml-base
+ :parent-xml-lang xml-lang))))
+ (import-node rdf-dom tm-id start-revision
+ :document-id document-id
+ :parent-xml-base xml-base
+ :parent-xml-lang xml-lang)))
(setf *_n-map* nil))
(defun import-node (elem tm-id start-revision &key (document-id *document-id*)
- (xml-base nil) (xml-lang nil))
+ (parent-xml-base nil) (parent-xml-lang nil))
+ "Imports an RDF node with all its properties and 'child' RDF nodes."
(tm-id-p tm-id "import-node")
(parse-node elem)
- (let ((fn-xml-lang (get-xml-lang elem :old-lang xml-lang)))
- (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*)))
- (parse-properties-of-node elem (or about nodeID ID UUID))
-
- (let ((literals (append (get-literals-of-node elem fn-xml-lang)
+ (let ((about (get-absolute-attribute elem tm-id parent-xml-base "about"))
+ (nodeID (get-ns-attribute elem "nodeID"))
+ (ID (get-absolute-attribute elem tm-id parent-xml-base "ID"))
+ (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 parent-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))
- (types (get-types-of-node elem tm-id :parent-xml-base xml-base))
+ elem tm-id parent-xml-base parent-xml-lang)))
+ (associations (get-associations-of-node-content elem tm-id
+ parent-xml-base))
+ (types (get-types-of-node elem tm-id
+ :parent-xml-base parent-xml-base))
(super-classes
- (get-super-classes-of-node-content elem tm-id xml-base)))
+ (get-super-classes-of-node-content elem tm-id parent-xml-base)))
(with-tm (start-revision document-id tm-id)
(let ((this
(make-topic-stub
@@ -124,19 +129,18 @@
start-revision :document-id document-id)
(make-recursion-from-node elem tm-id start-revision
:document-id document-id
- :xml-base xml-base
- :xml-lang xml-lang)
- this))))))
+ :parent-xml-base parent-xml-base
+ :parent-xml-lang parent-xml-lang)
+ this)))))
(defun import-arc (elem tm-id start-revision
&key (document-id *document-id*)
- (xml-base nil) (xml-lang nil))
+ (parent-xml-base nil) (parent-xml-lang nil))
"Imports a property that is an blank_node and continues the recursion
on this element."
(declare (dom:element elem))
- (let ((fn-xml-lang (get-xml-lang elem :old-lang xml-lang))
- (fn-xml-base (get-xml-base elem :old-base xml-base))
+ (let ((xml-lang (get-xml-lang elem :old-lang parent-xml-lang))
(UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*))
(parseType (get-ns-attribute elem "parseType"))
(content (child-nodes-or-text elem :trim t)))
@@ -156,24 +160,26 @@
:revision start-revision)))
(let ((literals
(append (get-literals-of-property
- elem fn-xml-lang)
+ elem xml-lang)
(get-literals-of-node-content
- elem tm-id xml-base fn-xml-lang)))
+ elem tm-id parent-xml-base
+ parent-xml-lang)))
(associations
(get-associations-of-node-content
- elem tm-id xml-base))
+ elem tm-id parent-xml-base))
(types
(remove-if
#'null
(append
- (get-types-of-node-content elem tm-id fn-xml-base)
+ (get-types-of-node-content elem tm-id
+ parent-xml-base)
(when (get-ns-attribute elem "type")
(list :ID nil
:topicid (get-ns-attribute elem "type")
:psi (get-ns-attribute elem "type"))))))
(super-classes
(get-super-classes-of-node-content
- elem tm-id xml-base)))
+ elem tm-id parent-xml-base)))
(make-literals this literals tm-id start-revision
:document-id document-id)
(make-associations this associations xml-importer::tm
@@ -186,19 +192,20 @@
this)))))
(make-recursion-from-arc elem tm-id start-revision
:document-id document-id
- :xml-base xml-base :xml-lang xml-lang)
+ :parent-xml-base parent-xml-base
+ :parent-xml-lang parent-xml-lang)
this-topic)))))
(defun make-collection (elem tm-id start-revision
&key (document-id *document-id*)
- (xml-base nil) (xml-lang nil))
+ (parent-xml-base nil) (parent-xml-lang nil))
"Creates a collection structure of a node that contains
parseType='Collection."
(declare (dom:element elem))
(with-tm (start-revision document-id tm-id)
- (let ((fn-xml-base (get-xml-base elem :old-base xml-base))
- (fn-xml-lang (get-xml-lang elem :old-lang xml-lang))
+ (let ((xml-base (get-xml-base elem :old-base parent-xml-base))
+ (xml-lang (get-xml-lang elem :old-lang parent-xml-lang))
(UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*)))
(let ((this (make-topic-stub nil nil nil UUID start-revision
xml-importer::tm
@@ -206,8 +213,8 @@
(items (loop for item across (child-nodes-or-text elem :trim t)
collect (import-node item tm-id start-revision
:document-id document-id
- :xml-base fn-xml-base
- :xml-lang fn-xml-lang))))
+ :parent-xml-base xml-base
+ :parent-xml-lang xml-lang))))
(let ((last-blank-node this))
(dotimes (index (length items))
(let ((is-end
@@ -466,10 +473,6 @@
(when lang
(let ((psi-and-topic-id
(concatenate-uri *rdf2tm-scope-prefix* lang)))
- ;(let ((top (get-item-by-id psi-and-topic-id :xtm-id document-id
-; :revision start-revision)))
-; (if top
-; top
(make-topic-stub psi-and-topic-id nil nil nil start-revision
tm :document-id document-id))))
@@ -612,13 +615,13 @@
occurrence))))))
-(defun get-literals-of-node-content (node tm-id xml-base xml-lang)
+(defun get-literals-of-node-content (node tm-id parent-xml-base parent-xml-lang)
"Returns a list of literals that is produced of a node's content."
(declare (dom:element node))
(tm-id-p tm-id "get-literals-of-noode-content")
(let ((properties (child-nodes-or-text node :trim t))
- (fn-xml-base (get-xml-base node :old-base xml-base))
- (fn-xml-lang (get-xml-lang node :old-lang xml-lang)))
+ (xml-base (get-xml-base node :old-base parent-xml-base))
+ (xml-lang (get-xml-lang node :old-lang parent-xml-lang)))
(let ((literals
(when properties
(loop for property across properties
@@ -643,11 +646,11 @@
(string/= parseType "Resource")))
collect (let ((content (child-nodes-or-text property))
(ID (get-absolute-attribute property tm-id
- fn-xml-base "ID"))
+ xml-base "ID"))
(child-xml-lang
- (get-xml-lang property :old-lang fn-xml-lang)))
+ (get-xml-lang property :old-lang xml-lang)))
(let ((full-name (get-type-of-node-name property))
- (datatype (get-datatype property tm-id fn-xml-base))
+ (datatype (get-datatype property tm-id xml-base))
(text
(cond
((= (length content) 0)
@@ -670,18 +673,18 @@
literals)))
-(defun get-types-of-node-content (node tm-id xml-base)
+(defun get-types-of-node-content (node tm-id parent-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 ((xml-base (get-xml-base node :old-base parent-xml-base)))
(let ((attr-type
(if (get-ns-attribute node "type")
(list
(list :topicid (absolutize-value (get-ns-attribute node "type")
- fn-xml-base tm-id)
+ xml-base tm-id)
:psi (absolutize-value (get-ns-attribute node "type")
- fn-xml-base tm-id)
+ xml-base tm-id)
:ID nil))
nil))
(content-types
@@ -691,17 +694,17 @@
(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"))
+ child tm-id xml-base "resource"))
(UUID (get-ns-attribute child "UUID"
:ns-uri *rdf2tm-ns*))
(ID (get-absolute-attribute child tm-id
- fn-xml-base "ID")))
+ xml-base "ID")))
(if (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)))
+ (get-xml-base child :old-base xml-base)))
(let ((refs
(get-node-refs
(child-nodes-or-text child :trim t)
@@ -712,9 +715,9 @@
(remove-if #'null (append attr-type content-types)))))
-(defun get-literals-of-property (property xml-lang)
+(defun get-literals-of-property (property parent-xml-lang)
"Returns a list of attributes that are treated as literal nodes."
- (let ((fn-xml-lang (get-xml-lang property :old-lang xml-lang))
+ (let ((xml-lang (get-xml-lang property :old-lang parent-xml-lang))
(attributes nil))
(dom:map-node-map
#'(lambda(attr)
@@ -737,7 +740,7 @@
(push (list :type l-type
:value l-value
:ID nil
- :lang fn-xml-lang
+ :lang xml-lang
:datatype *xml-string*)
attributes)))
((or (string= attr-ns *xml-ns*)
@@ -749,16 +752,16 @@
(push (list :type l-type
:value l-value
:ID nil
- :lang fn-xml-lang
+ :lang xml-lang
:datatype *xml-string*)
attributes)))))))
(dom:attributes property))
attributes))
-(defun get-literals-of-node (node xml-lang)
+(defun get-literals-of-node (node parent-xml-lang)
"Returns alist of attributes that are treated as literal nodes."
- (let ((fn-xml-lang (get-xml-lang node :old-lang xml-lang))
+ (let ((xml-lang (get-xml-lang node :old-lang parent-xml-lang))
(attributes nil))
(dom:map-node-map
#'(lambda(attr)
@@ -777,7 +780,7 @@
(push (list :type l-type
:value l-value
:ID nil
- :lang fn-xml-lang
+ :lang xml-lang
:datatype *xml-string*)
attributes)))
((or (string= attr-ns *xml-ns*)
@@ -789,19 +792,19 @@
(push (list :type l-type
:value l-value
:ID nil
- :lang fn-xml-lang
+ :lang xml-lang
:datatype *xml-string*)
attributes)))))))
(dom:attributes node))
attributes))
-(defun get-super-classes-of-node-content (node tm-id xml-base)
+(defun get-super-classes-of-node-content (node tm-id parent-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 :trim t))
- (fn-xml-base (get-xml-base node :old-base xml-base)))
+ (xml-base (get-xml-base node :old-base parent-xml-base)))
(when content
(loop for property across content
when (let ((prop-name (get-node-name property))
@@ -809,13 +812,13 @@
(and (string= prop-name "subClassOf")
(string= prop-ns *rdfs-ns*)))
collect (let ((prop-xml-base (get-xml-base property
- :old-base fn-xml-base)))
+ :old-base xml-base)))
(let ((ID (get-absolute-attribute property tm-id
- fn-xml-base "ID"))
+ xml-base "ID"))
(nodeID (get-ns-attribute property "nodeID"))
(resource
(get-absolute-attribute property tm-id
- fn-xml-base "resource"))
+ xml-base "resource"))
(UUID (get-ns-attribute property "UUID"
:ns-uri *rdf2tm-ns*)))
(if (or nodeID resource UUID)
@@ -830,17 +833,17 @@
:ID ID)))))))))
-(defun get-associations-of-node-content (node tm-id xml-base)
+(defun get-associations-of-node-content (node tm-id parent-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 :trim t))
- (fn-xml-base (get-xml-base node :old-base xml-base)))
+ (xml-base (get-xml-base node :old-base parent-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"))
+ xml-base "resource"))
(nodeID (get-ns-attribute property "nodeID"))
(type (get-ns-attribute property "type"))
(parseType (get-ns-attribute property "parseType"))
@@ -858,7 +861,7 @@
(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))
+ :old-base xml-base))
(content (child-nodes-or-text property :trim t))
(parseType (get-ns-attribute property "parseType")))
(let ((resource
@@ -866,12 +869,12 @@
(= (length content) 0))
*rdf-nil*
(get-absolute-attribute property tm-id
- fn-xml-base "resource")))
+ 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"))
+ xml-base "ID"))
(full-name (get-type-of-node-name property)))
(if (or nodeID resource UUID)
(list :type full-name
@@ -889,42 +892,45 @@
(defun make-recursion-from-node (node tm-id start-revision
&key (document-id *document-id*)
- (xml-base nil) (xml-lang nil))
+ (parent-xml-base nil) (parent-xml-lang nil))
"Calls the next function that handles all DOM child elements
of the passed element as arcs."
(declare (dom:element node))
(let ((content (child-nodes-or-text node :trim t))
(err-pref "From make-recursion-from-node(): ")
- (fn-xml-base (get-xml-base node :old-base xml-base))
- (fn-xml-lang (get-xml-lang node :old-lang xml-lang)))
+ (xml-base (get-xml-base node :old-base parent-xml-base))
+ (xml-lang (get-xml-lang node :old-lang parent-xml-lang)))
(when (stringp content)
(error "~aliteral content not allowed here: ~a"
err-pref content))
(loop for arc across content
collect (import-arc arc tm-id start-revision :document-id document-id
- :xml-base fn-xml-base :xml-lang fn-xml-lang))))
+ :parent-xml-base xml-base
+ :parent-xml-lang xml-lang))))
(defun make-recursion-from-arc (arc tm-id start-revision
&key (document-id *document-id*)
- (xml-base nil) (xml-lang nil))
+ (parent-xml-base nil) (parent-xml-lang nil))
"Calls the next function that handles the arcs content nodes/arcs."
(declare (dom:element arc))
- (let ((fn-xml-base (get-xml-base arc :old-base xml-base))
- (fn-xml-lang (get-xml-lang arc :old-lang xml-lang))
+ (let ((xml-base (get-xml-base arc :old-base parent-xml-base))
+ (xml-lang (get-xml-lang arc :old-lang parent-xml-lang))
(content (child-nodes-or-text arc))
(parseType (get-ns-attribute arc "parseType")))
- (let ((datatype (get-absolute-attribute arc tm-id xml-base "datatype"))
- (type (get-absolute-attribute arc tm-id xml-base "type"))
- (resource (get-absolute-attribute arc tm-id xml-base "resource"))
+ (let ((datatype (get-absolute-attribute arc tm-id
+ parent-xml-base "datatype"))
+ (type (get-absolute-attribute arc tm-id parent-xml-base "type"))
+ (resource (get-absolute-attribute arc tm-id
+ parent-xml-base "resource"))
(nodeID (get-ns-attribute arc "nodeID"))
- (literals (get-literals-of-property arc xml-lang)))
+ (literals (get-literals-of-property arc parent-xml-lang)))
(if (and parseType
(string= parseType "Collection"))
(make-collection arc tm-id start-revision
:document-id document-id
- :xml-base xml-base
- :xml-lang xml-lang)
+ :parent-xml-base parent-xml-base
+ :parent-xml-lang parent-xml-lang)
(if (or datatype resource nodeID
(and parseType
(string= parseType "Literal"))
@@ -938,10 +944,10 @@
(loop for item across content
collect (import-arc item tm-id start-revision
:document-id document-id
- :xml-base fn-xml-base
- :xml-lang fn-xml-lang))
+ :parent-xml-base xml-base
+ :parent-xml-lang xml-lang))
(loop for item across content
collect (import-node item tm-id start-revision
:document-id document-id
- :xml-base xml-base
- :xml-lang xml-lang))))))))
\ No newline at end of file
+ :parent-xml-base xml-base
+ :parent-xml-lang xml-lang))))))))
\ 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 Wed Sep 9 03:42:00 2009
@@ -282,21 +282,21 @@
t)
-(defun get-node-refs (nodes tm-id xml-base)
+(defun get-node-refs (nodes tm-id parent-xml-base)
"Returns a list of node references that can be used as topic IDs."
(when (and nodes
(> (length nodes) 0))
(loop for node across nodes
- collect (let ((fn-xml-base (get-xml-base node :old-base xml-base)))
+ collect (let ((xml-base (get-xml-base node :old-base parent-xml-base)))
(parse-node node)
(let ((ID (when (get-ns-attribute node "ID")
(absolutize-id (get-ns-attribute node "ID")
- fn-xml-base tm-id)))
+ xml-base tm-id)))
(nodeID (get-ns-attribute node "nodeID"))
(about (when (get-ns-attribute node "about")
(absolutize-value
(get-ns-attribute node "about")
- fn-xml-base tm-id)))
+ xml-base tm-id)))
(UUID (get-ns-attribute node "UUID" :ns-uri *rdf2tm-ns*)))
(list :topicid (or ID about nodeID UUID)
:psi (or ID about)))))))
@@ -465,29 +465,28 @@
t)
-(defun get-absolute-attribute (elem tm-id xml-base attr-name
+(defun get-absolute-attribute (elem tm-id parent-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)))
+ (xml-base (get-xml-base elem :old-base parent-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)))))
+ (absolutize-id attr xml-base tm-id)
+ (absolutize-value attr xml-base tm-id)))))
-(defun get-datatype (elem tm-id xml-base)
+(defun get-datatype (elem tm-id parent-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*))))
+ (let ((datatype
+ (get-absolute-attribute elem tm-id parent-xml-base "datatype")))
+ (if datatype
+ datatype
+ *xml-string*)))
(defun tm-id-p (tm-id fun-name)
@@ -500,14 +499,13 @@
(defun get-types-of-node (elem tm-id &key (parent-xml-base nil))
"Returns a plist of all node's types of the form
(:topicid <string> :psi <string> :ID <string>)."
- (let ((xml-base (get-xml-base elem :old-base parent-xml-base)))
- (remove-if
- #'null
- (append (unless (string= (get-type-of-node-name elem)
- (concatenate 'string *rdf-ns*
- "Description"))
- (list
- (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 xml-base)))))
\ No newline at end of file
+ (remove-if
+ #'null
+ (append (unless (string= (get-type-of-node-name elem)
+ (concatenate 'string *rdf-ns*
+ "Description"))
+ (list
+ (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 parent-xml-base))))
\ No newline at end of file
More information about the Isidorus-cvs
mailing list