[isidorus-cvs] r106 - in trunk/src: . unit_tests xml/rdf
Lukas Giessmann
lgiessmann at common-lisp.net
Wed Aug 5 10:53:46 UTC 2009
Author: lgiessmann
Date: Wed Aug 5 06:53:45 2009
New Revision: 106
Log:
added a function that from import-node furhter function to import the entire dom recursively
Modified:
trunk/src/constants.lisp
trunk/src/unit_tests/poems.rdf
trunk/src/unit_tests/rdf_importer_test.lisp
trunk/src/xml/rdf/importer.lisp
trunk/src/xml/rdf/rdf_tools.lisp
Modified: trunk/src/constants.lisp
==============================================================================
--- trunk/src/constants.lisp (original)
+++ trunk/src/constants.lisp Wed Aug 5 06:53:45 2009
@@ -32,8 +32,12 @@
:*rdf-object*
:*rdf-subject*
:*rdf-predicate*
+ :*rdf-nil*
+ :*rdf-first*
+ :*rdf-rest*
:*rdf2tm-object*
- :*rdf2tm-subject*))
+ :*rdf2tm-subject*
+ :*rdf2tm-collection*))
(in-package :constants)
(defparameter *xtm2.0-ns* "http://www.topicmaps.org/xtm/")
@@ -80,6 +84,14 @@
(defparameter *rdf-predicate* "http://www.w3.org/1999/02/22-rdf-syntax-ns#predicate")
+(defparameter *rdf-nil* "http://www.w3.org/1999/02/22-rdf-syntax-ns#nil")
+
+(defparameter *rdf-first* "http://www.w3.org/1999/02/22-rdf-syntax-ns#first")
+
+(defparameter *rdf-rest* "http://www.w3.org/1999/02/22-rdf-syntax-ns#rest")
+
(defparameter *rdf2tm-object* "http://isidorus/rdf2tm_mapping#object")
-(defparameter *rdf2tm-subject* "http://isidorus/rdf2tm_mapping#subject")
\ No newline at end of file
+(defparameter *rdf2tm-subject* "http://isidorus/rdf2tm_mapping#subject")
+
+(defparameter *rdf2tm-collection* "http://isidorus/rdf2tm_mapping#collection")
\ No newline at end of file
Modified: trunk/src/unit_tests/poems.rdf
==============================================================================
--- trunk/src/unit_tests/poems.rdf (original)
+++ trunk/src/unit_tests/poems.rdf Wed Aug 5 06:53:45 2009
@@ -3165,10 +3165,10 @@
<types:Ballad>
<arcs:title rdf:parseType="Literal">Die zwei Gesellen</arcs:title>
<arcs:title rdf:parseType="Literal">Frühlingsfahrt</arcs:title>
- <arcs:daterange rdf:parseType="Resource">
+ <arcs:dateRange rdf:parseType="Resource">
<arcs:start rdf:datatype="http://www.w3.org/2001/XMLSchema#date">01.01.1818</arcs:start>
<arcs:end rdf:datatype="http://www.w3.org/2001/XMLSchema#date">31.12.1818</arcs:end>
- </arcs:daterange>
+ </arcs:dateRange>
<arcs:content rdf:parseType="Literal" xml:lang="de">
<![CDATA[Es zogen zwei rüst’ge Gesellen
Zum erstenmal von Haus,
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 Wed Aug 5 06:53:45 2009
@@ -51,7 +51,8 @@
:test-get-associations-of-node-content
:test-parse-properties-of-node
:test-import-node-1
- :test-import-node-reification))
+ :test-import-node-reification
+ :test-import-dom))
(declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0)))
@@ -1433,6 +1434,46 @@
(elephant:close-store))))))
+(test test-import-dom
+ "Tests the function import-node when used recursively."
+ (let ((db-dir "data_base")
+ (tm-id "http://test-tm/")
+ (revision-1 100)
+ (document-id "doc-id")
+ (doc-1
+ (concatenate 'string "<rdf:RDF xmlns:rdf=\"" *rdf-ns* "\" "
+ "xmlns:arcs=\"http://test/arcs/\" "
+ "xmlns:rdfs=\"" *rdfs-ns* "\">"
+ "<rdf:Description1 rdf:about=\"first-node\">"
+ "<rdf:type rdf:nodeID=\"second-node\"/>"
+ "<arcs:arc1 rdf:resource=\"third-node\"/>"
+ "<arcs:arc2 rdf:datatype=\"long\">123</arcs:arc2>"
+ "<arcs:arc3>"
+ "<rdf:Description3>"
+ "<arcs:arc4 rdf:parseType=\"Collection\">"
+ "<rdf:Description4 rdf:about=\"item-1\"/>"
+ "<rdf:Description5 rdf:about=\"item-2\">"
+ "<arcs:arc5 rdf:parseType=\"Resource\">"
+ "<arcs:arc7 rdf:resource=\"fourth-node\"/>"
+ "<arcs:arc8 rdf:parseType=\"Collection\" />"
+ "</arcs:arc5>"
+ "</rdf:Description5>"
+ "</arcs:arc4>"
+ "</rdf:Description3>"
+ "</arcs:arc3>"
+ "</rdf:Description1>"
+ "<rdf:Description2 rdf:nodeID=\"second-node\" />"
+ "</rdf:RDF>")))
+ (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder))))
+ (is-true dom-1)
+ (is (= (length (dom:child-nodes dom-1)) 1))
+ (rdf-init-db :db-dir db-dir :start-revision revision-1)
+ (let ((rdf-node (elt (dom:child-nodes dom-1) 0)))
+ (is (= (length (dom:child-nodes rdf-node)) 2))
+ (rdf-importer::import-dom rdf-node revision-1 :tm-id tm-id
+ :document-id document-id)))))
+
+
(defun run-rdf-importer-tests()
(it.bese.fiveam:run! 'test-get-literals-of-node)
@@ -1445,4 +1486,5 @@
(it.bese.fiveam:run! 'test-get-associations-of-node-content)
(it.bese.fiveam:run! 'test-parse-properties-of-node)
(it.bese.fiveam:run! 'test-import-node-1)
- (it.bese.fiveam:run! 'test-import-node-reification))
\ No newline at end of file
+ (it.bese.fiveam:run! 'test-import-node-reification)
+ (it.bese.fiveam:run! 'test-import-dom))
\ 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 Wed Aug 5 06:53:45 2009
@@ -78,6 +78,7 @@
(defun import-dom (rdf-dom start-revision
&key (tm-id nil) (document-id *document-id*))
"Imports the entire dom of a rdf-xml-file."
+ (setf *_n-map* nil) ;in case of an failed last call
(tm-id-p tm-id "import-dom")
(let ((xml-base (get-xml-base rdf-dom))
(xml-lang (get-xml-lang rdf-dom))
@@ -85,29 +86,33 @@
(elem-ns (dom:namespace-uri rdf-dom)))
(if (and (string= elem-ns *rdf-ns*)
(string= elem-name "RDF"))
- (let ((children (child-nodes-or-text rdf-dom)))
+ (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))))
+ :xml-base xml-base :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))
- (remove-node-properties-from-*_n-map* elem) ;in case of an failed last call
+ (format t ">> import-node: ~a <<~%" (dom:node-name elem))
(tm-id-p tm-id "import-node")
(parse-node elem)
- (let ((fn-xml-base (get-xml-base elem :old-base xml-base)))
+ ;TODO: handle Collections that are made manually without
+ ; 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 xml-lang)
- (get-literals-of-node-content elem tm-id
- xml-base xml-lang)))
+ (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))
(types (remove-if
#'null
@@ -123,51 +128,164 @@
(get-super-classes-of-node-content elem tm-id xml-base)))
(with-tm (start-revision document-id tm-id)
(elephant:ensure-transaction (:txn-nosync t)
- (let ((topic-stub
+ (let ((this
(make-topic-stub
about ID nodeID UUID start-revision xml-importer::tm
:document-id document-id)))
- (map 'list #'(lambda(literal)
- (make-occurrence topic-stub literal start-revision
- tm-id :document-id document-id))
- literals)
- (map 'list #'(lambda(assoc)
- (make-association topic-stub assoc xml-importer::tm
- start-revision
- :document-id document-id))
- associations)
- (map 'list
- #'(lambda(type)
- (let ((type-topic
- (make-topic-stub (getf type :psi)
- nil
- (getf type :topicid)
- nil start-revision
- xml-importer::tm
- :document-id document-id))
- (ID (getf type :ID)))
- (make-instance-of-association topic-stub type-topic
- ID start-revision
- xml-importer::tm
- :document-id document-id)))
- types)
- (map 'list
- #'(lambda(class)
- (let ((class-topic
- (make-topic-stub (getf class :psi)
- nil
- (getf class :topicid)
- nil start-revision
- xml-importer::tm
- :document-id document-id))
- (ID (getf class :ID)))
- (make-supertype-subtype-association
- topic-stub class-topic ID start-revision
- xml-importer::tm :document-id document-id)))
- super-classes)
-
- ;TODO: start recursion ...
- (remove-node-properties-from-*_n-map* elem)))))))
+ (make-literals this literals tm-id start-revision
+ :document-id document-id)
+ (make-associations this associations xml-importer::tm
+ start-revision :document-id document-id)
+ (make-types this types xml-importer::tm start-revision
+ :document-id document-id)
+ (make-super-classes this super-classes xml-importer::tm
+ 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)
+ (remove-node-properties-from-*_n-map* elem)
+ this))))))
+
+
+(defun import-arc (elem tm-id start-revision
+ &key (document-id *document-id*)
+ (xml-base nil) (xml-lang nil))
+ "Imports a property that is an blank_node and continues the recursion
+ on this element."
+ (declare (dom:element elem))
+ (format t ">> import-arc: ~a <<~%" (dom:node-name elem))
+ (let ((fn-xml-lang (get-xml-lang elem :old-lang xml-lang))
+ (fn-xml-base (get-xml-base elem :old-base xml-base))
+ (UUID (get-ns-attribute elem "UUID" :ns-uri *rdf2tm-ns*))
+ (parseType (get-ns-attribute elem "parseType")))
+ (when (or (not parseType)
+ (and parseType
+ (string/= parseType "Collection")))
+ (when UUID
+ (parse-properties-of-node elem)
+ (with-tm (start-revision document-id tm-id)
+ (let ((this (get-item-by-id UUID :xtm-id document-id
+ :revision start-revision)))
+ (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))
+ (types (get-types-of-node-content elem tm-id fn-xml-base))
+ (super-classes
+ (get-super-classes-of-node-content elem tm-id xml-base)))
+ (make-literals this literals tm-id start-revision
+ :document-id document-id)
+ (make-associations this associations xml-importer::tm
+ start-revision :document-id document-id)
+ (make-types this types xml-importer::tm start-revision
+ :document-id document-id)
+ (make-super-classes this super-classes xml-importer::tm
+ start-revision :document-id document-id))))))
+ (make-recursion-from-arc elem tm-id start-revision
+ :document-id document-id
+ :xml-base xml-base :xml-lang xml-lang)))
+
+
+(defun make-collection (elem owner-top tm-id start-revision
+ &key (document-id *document-id*)
+ (xml-base nil) (xml-lang nil))
+ "Creates a TM association with a subject role containing the collection
+ entry point and as many roles of the type 'object' as items exists."
+ (declare (d:TopicC owner-top))
+ (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))
+ (subject (make-topic-stub *rdf2tm-subject* nil nil nil start-revision
+ xml-importer::tm :document-id document-id))
+ (object (make-topic-stub *rdf2tm-object* nil nil nil start-revision
+ xml-importer::tm :document-id document-id)))
+ (let ((association-type (make-topic-stub *rdf2tm-collection* nil nil nil
+ start-revision xml-importer::tm
+ :document-id document-id))
+ (roles
+ (append
+ (loop for item across (child-nodes-or-text elem :trim t)
+ collect (let ((item-top (import-node item tm-id start-revision
+ :document-id document-id
+ :xml-base fn-xml-base
+ :xml-lang fn-xml-lang)))
+ (list :player item-top
+ :instance-of object)))
+ (list (list :player owner-top
+ :instance-of subject)))))
+ (add-to-topicmap
+ xml-importer::tm
+ (make-construct 'd:AssociationC
+ :start-revision start-revision
+ :instance-of association-type
+ :roles roles))))))
+
+
+(defun make-literals (owner-top literals tm-id start-revision
+ &key (document-id *document-id*))
+ "Creates Topic Maps constructs (occurrences) of the passed
+ named list literals related to the topic owner-top."
+ (declare (d:TopicC owner-top))
+ (map 'list #'(lambda(literal)
+ (make-occurrence owner-top literal start-revision
+ tm-id :document-id document-id))
+ literals))
+
+
+(defun make-associations (owner-top associations tm start-revision
+ &key (document-id *document-id*))
+ "Creates Topic Maps constructs (assocaitions) of the passed
+ named list literals related to the topic owner-top."
+ (declare (d:TopicC owner-top))
+ (map 'list #'(lambda(assoc)
+ (make-association owner-top assoc tm
+ start-revision
+ :document-id document-id))
+ associations))
+
+
+(defun make-types (owner-top types tm start-revision
+ &key (document-id *document-id*))
+ "Creates instance-of associations corresponding to the passed
+ topic owner-top and the passed types."
+ (declare (d:TopicC owner-top))
+ (map 'list
+ #'(lambda(type)
+ (let ((type-topic
+ (make-topic-stub (getf type :psi)
+ nil
+ (getf type :topicid)
+ nil start-revision tm
+ :document-id document-id))
+ (ID (getf type :ID)))
+ (make-instance-of-association owner-top type-topic
+ ID start-revision tm
+ :document-id document-id)))
+ types))
+
+
+(defun make-super-classes (owner-top super-classes tm start-revision
+ &key (document-id *document-id*))
+ "Creates supertype-subtype associations corresponding to the passed
+ topic owner-top and the passed super classes."
+ (declare (d:TopicC owner-top))
+ (map 'list
+ #'(lambda(class)
+ (let ((class-topic
+ (make-topic-stub (getf class :psi)
+ nil
+ (getf class :topicid)
+ nil start-revision tm
+ :document-id document-id))
+ (ID (getf class :ID)))
+ (make-supertype-subtype-association
+ owner-top class-topic ID start-revision tm
+ :document-id document-id)))
+ super-classes))
+
+
(defun make-supertype-subtype-association (sub-top super-top reifier-id
@@ -176,9 +294,15 @@
"Creates an supertype-subtype association."
(declare (TopicC sub-top super-top))
(declare (TopicMapC tm))
- (let ((assoc-type (get-item-by-psi *supertype-subtype-psi*))
- (role-type-1 (get-item-by-psi *supertype-psi*))
- (role-type-2 (get-item-by-psi *subtype-psi*))
+ (let ((assoc-type
+ (make-topic-stub *supertype-subtype-psi* nil nil nil
+ start-revision tm :document-id document-id))
+ (role-type-1
+ (make-topic-stub *supertype-psi* nil nil nil
+ start-revision tm :document-id document-id))
+ (role-type-2
+ (make-topic-stub *subtype-psi* nil nil nil
+ start-revision tm :document-id document-id))
(err-pref "From make-supertype-subtype-association(): "))
(unless assoc-type
(error "~athe association type ~a is missing!"
@@ -210,11 +334,14 @@
(declare (TopicC type-top instance-top))
(declare (TopicMapC tm))
(let ((assoc-type
- (get-item-by-psi *type-instance-psi*))
+ (make-topic-stub *type-instance-psi* nil nil nil
+ start-revision tm :document-id document-id))
(roletype-1
- (get-item-by-psi *type-psi*))
+ (make-topic-stub *type-psi* nil nil nil
+ start-revision tm :document-id document-id))
(roletype-2
- (get-item-by-psi *instance-psi*))
+ (make-topic-stub *instance-psi* nil nil nil
+ start-revision tm :document-id document-id))
(err-pref "From make-instance-of-association(): "))
(unless assoc-type
(error "~athe association type ~a is missing!"
@@ -266,13 +393,15 @@
(make-instance 'PersistentIdC
:uri psi-uri
:start-revision start-revision))))
- (add-to-topicmap
- tm
- (make-construct 'TopicC
- :topicid topic-id
- :psis (when psi (list psi))
- :xtm-id document-id
- :start-revision start-revision))))))))
+ (handler-case (add-to-topicmap
+ tm
+ (make-construct 'TopicC
+ :topicid topic-id
+ :psis (when psi (list psi))
+ :xtm-id document-id
+ :start-revision start-revision))
+ (Condition (err)(error "Creating topic ~a failed: ~a"
+ topic-id err)))))))))
(defun make-lang-topic (lang tm-id start-revision tm
@@ -306,8 +435,12 @@
(let ((player-1 (make-topic-stub player-psi nil player-id nil
start-revision
tm :document-id document-id))
- (role-type-1 (get-item-by-psi *rdf2tm-object*))
- (role-type-2 (get-item-by-psi *rdf2tm-subject*))
+ (role-type-1
+ (make-topic-stub *rdf2tm-object* nil nil nil
+ start-revision tm :document-id document-id))
+ (role-type-2
+ (make-topic-stub *rdf2tm-subject* nil nil nil
+ start-revision tm :document-id document-id))
(type-top (make-topic-stub type nil nil nil start-revision
tm :document-id document-id)))
(let ((roles (list (list :instance-of role-type-1
@@ -324,12 +457,17 @@
(defun make-association-with-nodes (subject-topic object-topic
- associationtype-topic tm start-revision)
+ associationtype-topic tm start-revision
+ &key (document-id *document-id*))
"Creates an association with two roles that contains the given players."
(declare (TopicC subject-topic object-topic associationtype-topic))
(declare (TopicMapC tm))
- (let ((role-type-1 (get-item-by-psi *rdf2tm-subject*))
- (role-type-2 (get-item-by-psi *rdf2tm-object*)))
+ (let ((role-type-1
+ (make-topic-stub *rdf2tm-subject* nil nil nil start-revision
+ tm :document-id document-id))
+ (role-type-2
+ (make-topic-stub *rdf2tm-object* nil nil nil start-revision
+ tm :document-id document-id)))
(let ((roles (list (list :instance-of role-type-1
:player subject-topic)
(list :instance-of role-type-2
@@ -363,12 +501,13 @@
(make-instance-of-association reifier statement nil start-revision tm
:document-id document-id)
(make-association-with-nodes reifier subject subject-arc tm
- start-revision)
+ start-revision :document-id document-id)
(make-association-with-nodes reifier predicate predicate-arc
- tm start-revision)
+ tm start-revision :document-id document-id)
(if (typep object 'd:TopicC)
(make-association-with-nodes reifier object object-arc
- tm start-revision)
+ tm start-revision
+ :document-id document-id)
(make-construct 'd:OccurrenceC
:start-revision start-revision
:topic reifier
@@ -416,7 +555,7 @@
"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-content")
- (let ((properties (child-nodes-or-text node))
+ (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)))
(let ((literals
@@ -486,8 +625,8 @@
:ID nil))
nil))
(content-types
- (when (child-nodes-or-text node)
- (loop for child across (child-nodes-or-text node)
+ (when (child-nodes-or-text node :trim t)
+ (loop for child across (child-nodes-or-text node :trim t)
when (and (string= (dom:namespace-uri child) *rdf-ns*)
(string= (get-node-name child) "type"))
collect (let ((nodeID (get-ns-attribute child "nodeID"))
@@ -505,7 +644,7 @@
(get-xml-base child :old-base fn-xml-base)))
(let ((refs
(get-node-refs
- (child-nodes-or-text child)
+ (child-nodes-or-text child :trim t)
tm-id child-xml-base)))
(list :topicid (getf (first refs) :topicid)
:psi (getf (first refs) :psi)
@@ -601,7 +740,7 @@
"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))
+ (let ((content (child-nodes-or-text node :trim t))
(fn-xml-base (get-xml-base node :old-base xml-base)))
(when content
(loop for property across content
@@ -624,7 +763,7 @@
:psi resource
:ID ID)
(let ((refs (get-node-refs
- (child-nodes-or-text property)
+ (child-nodes-or-text property :trim t)
tm-id prop-xml-base)))
(list :topicid (getf (first refs) :topicid)
:psi (getf (first refs) :psi)
@@ -634,7 +773,7 @@
(defun get-associations-of-node-content (node tm-id 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))
+ (let ((properties (child-nodes-or-text node :trim t))
(fn-xml-base (get-xml-base node :old-base xml-base)))
(loop for property across properties
when (let ((prop-name (get-node-name property))
@@ -675,9 +814,68 @@
:psi resource
:ID ID)
(let ((refs (get-node-refs
- (child-nodes-or-text property)
+ (child-nodes-or-text property :trim t)
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
+ :ID ID))))))))
+
+
+(defun make-recursion-from-node (node tm-id start-revision
+ &key (document-id *document-id*)
+ (xml-base nil) (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)))
+ (when (stringp content)
+ (error "~aliteral content not allowed here: ~a"
+ err-pref content))
+ (loop for arc across content
+ do (import-arc arc tm-id start-revision :document-id document-id
+ :xml-base fn-xml-base :xml-lang fn-xml-lang))))
+
+
+(defun make-recursion-from-arc (arc tm-id start-revision
+ &key (document-id *document-id*)
+ (xml-base nil) (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))
+ (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"))
+ (nodeID (get-ns-attribute arc "nodeID"))
+ (literals (get-literals-of-property arc xml-lang)))
+ (if (and parseType
+ (string= parseType "Collection"))
+ (loop for item across content
+ do (import-node item tm-id start-revision :document-id document-id
+ :xml-base fn-xml-base :xml-lang fn-xml-lang))
+ (if (or datatype resource nodeID
+ (and parseType
+ (string= parseType "Literal"))
+ (and content
+ (stringp content)))
+ t;; do nothing current elem is a literal node that has been
+ ;; already imported as an occurrence
+ (if (or type literals
+ (and parseType
+ (string= parseType "Resource")))
+ (loop for item across content
+ do (import-arc item tm-id start-revision
+ :document-id document-id
+ :xml-base fn-xml-base
+ :xml-lang fn-xml-lang))
+ (loop for item across content
+ do (import-node item tm-id start-revision
+ :document-id document-id
+ :xml-base xml-base
+ :xml-lang xml-lang))))))))
Modified: trunk/src/xml/rdf/rdf_tools.lisp
==============================================================================
--- trunk/src/xml/rdf/rdf_tools.lisp (original)
+++ trunk/src/xml/rdf/rdf_tools.lisp Wed Aug 5 06:53:45 2009
@@ -27,7 +27,11 @@
*rdf2tm-subject*
*supertype-psi*
*subtype-psi*
- *supertype-subtype-psi*)
+ *supertype-subtype-psi*
+ *rdf-nil*
+ *rdf-first*
+ *rdf-rest*
+ *rdf2tm-collection*)
(:import-from :xml-constants
*rdf_core_psis.xtm*)
(:import-from :xml-constants
@@ -132,7 +136,7 @@
(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)))
+ (let ((properties (child-nodes-or-text node :trim t)))
(when properties
(loop for property across properties
do (unset-_n-name property))))
@@ -203,7 +207,7 @@
(or about nodeID))
(error "~awhen rdf:ID is set the attributes rdf:~a is not allowed: ~a!"
err-pref (if about "about" "nodeID") (or about nodeID)))
- (unless (or ID nodeID about)
+ (unless (or ID nodeID about (dom:has-attribute-ns node *rdf2tm-ns* "UUID"))
(dom:set-attribute-ns node *rdf2tm-ns* "UUID" (get-uuid)))
(handler-case (let ((content (child-nodes-or-text node :trim t)))
(when (stringp content)
@@ -320,7 +324,8 @@
(when (and parseType
(or (string= parseType "Resource")
(string= parseType "Collection")))
- (dom:set-attribute-ns property *rdf2tm-ns* "UUID" (get-uuid)))
+ (unless (dom:has-attribute-ns property *rdf2tm-ns* "UUID")
+ (dom:set-attribute-ns property *rdf2tm-ns* "UUID" (get-uuid))))
(when (and parseType (string= parseType "Resource") (stringp content))
(error "~ardf:parseType is set to 'Resource' expecting xml content: ~a!"
err-pref content))
@@ -356,7 +361,8 @@
(> (length literals) 0))
(not (or nodeID resource))
(not content))
- (dom:set-attribute-ns property *rdf2tm-ns* "UUID" (get-uuid)))
+ (unless (dom:has-attribute-ns property *rdf2tm-ns* "UUID")
+ (dom:set-attribute-ns property *rdf2tm-ns* "UUID" (get-uuid))))
(when (or about subClassOf)
(error "~a~a not allowed here!"
err-pref
@@ -366,7 +372,8 @@
(when (and (string= node-name "subClassOf")
(string= node-ns *rdfs-ns*)
(not (or nodeID resource content)))
- (dom:set-attribute-ns property *rdf2tm-ns* "UUID" (get-uuid)))
+ (unless (dom:has-attribute-ns property *rdf2tm-ns* "UUID")
+ (dom:set-attribute-ns property *rdf2tm-ns* "UUID" (get-uuid))))
(when (and (or (and (string= node-name "type")
(string= node-ns *rdf-ns*))
(and (string= node-name "subClassOf")
@@ -393,7 +400,7 @@
"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))
+ (let ((child-nodes (child-nodes-or-text node :trim t))
(_n-counter 0))
(when (get-ns-attribute node "li")
(dom:map-node-map
@@ -436,5 +443,4 @@
(get-absolute-attribute elem tm-id fn-xml-base "datatype")))
(if datatype
datatype
- *xml-string*))))
-
\ No newline at end of file
+ *xml-string*))))
\ No newline at end of file
More information about the Isidorus-cvs
mailing list