August 2009 - isidorus-cvs@common-lisp.net

[isidorus-cvs] r107 - in trunk/src: unit_tests xml/rdf
by Lukas Giessmann 05 Aug '09

05 Aug '09

Author: lgiessmann Date: Wed Aug 5 07:58:19 2009 New Revision: 107 Log: fixed a bug in the rdf-importer which occurs when the rdf-file contains a collection Modified: trunk/src/unit_tests/rdf_importer_test.lisp trunk/src/xml/rdf/importer.lisp trunk/src/xml/rdf/rdf_core_psis.xtm 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 Wed Aug 5 07:58:19 2009 @@ -1038,7 +1038,7 @@ (rdf-init-db :db-dir db-dir :start-revision revision-1) (rdf-importer::import-node node tm-id revision-2 :document-id document-id) - (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 20)) + (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 21)) (let ((first-node (get-item-by-id "http://test-tm/first-node" :xtm-id document-id)) (first-type (get-item-by-id "http://test-tm/first-type" @@ -1442,27 +1442,29 @@ (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\">" + "xmlns:arcs=\"http://test/arcs/\">" + "<rdf:Description 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>" + "<rdf:Description>" "<arcs:arc4 rdf:parseType=\"Collection\">" - "<rdf:Description4 rdf:about=\"item-1\"/>" - "<rdf:Description5 rdf:about=\"item-2\">" + "<rdf:Description rdf:about=\"item-1\"/>" + "<rdf:Description rdf:about=\"item-2\">" "<arcs:arc5 rdf:parseType=\"Resource\">" - "<arcs:arc7 rdf:resource=\"fourth-node\"/>" + "<arcs:arc6 rdf:resource=\"fourth-node\"/>" + "<arcs:arc7>" + "<rdf:Description rdf:about=\"fifth-node\"/>" + "</arcs:arc7>" "<arcs:arc8 rdf:parseType=\"Collection\" />" "</arcs:arc5>" - "</rdf:Description5>" + "</rdf:Description>" "</arcs:arc4>" - "</rdf:Description3>" + "</rdf:Description>" "</arcs:arc3>" - "</rdf:Description1>" - "<rdf:Description2 rdf:nodeID=\"second-node\" />" + "</rdf:Description>" + "<rdf:Description rdf:nodeID=\"second-node\" />" "</rdf:RDF>"))) (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))) (is-true dom-1) Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Wed Aug 5 07:58:19 2009 @@ -98,7 +98,7 @@ (defun import-node (elem tm-id start-revision &key (document-id *document-id*) (xml-base nil) (xml-lang nil)) - (format t ">> import-node: ~a <<~%" (dom:node-name elem)) + (format t ">> import-node: ~a <<~%" (dom:node-name elem)) ;TODO: remove (tm-id-p tm-id "import-node") (parse-node elem) ;TODO: handle Collections that are made manually without @@ -154,7 +154,7 @@ "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)) + (format t ">> import-arc: ~a <<~%" (dom:node-name elem)) ;TODO: remove (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*)) @@ -848,7 +848,8 @@ (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"))) + (parseType (get-ns-attribute arc "parseType")) + (UUID (get-ns-attribute arc "UUID" :ns-uri *rdf2tm-ns*))) (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")) @@ -856,9 +857,15 @@ (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)) + (let ((this + (with-tm (start-revision document-id tm-id) + (make-topic-stub nil nil nil UUID start-revision + xml-importer::tm + :document-id document-id)))) + (make-collection arc this tm-id start-revision + :document-id document-id + :xml-base xml-base + :xml-lang xml-lang)) (if (or datatype resource nodeID (and parseType (string= parseType "Literal")) Modified: trunk/src/xml/rdf/rdf_core_psis.xtm ============================================================================== --- trunk/src/xml/rdf/rdf_core_psis.xtm (original) +++ trunk/src/xml/rdf/rdf_core_psis.xtm Wed Aug 5 07:58:19 2009 @@ -23,6 +23,13 @@ <value>object</value> </name> </topic> + + <topic id="collection"> + <subjectIdentifier href="http://isidorus/rdf2tm_mapping#collection"/> + <name> + <value>object</value> + </name> + </topic> <topic id="supertype-subtype"> <subjectIdentifier href="http://psi.topicmaps.org/iso13250/model/supertype-subtype"/> 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 07:58:19 2009 @@ -214,7 +214,7 @@ (error "text-content not allowed here!"))) (condition (err) (error "~a~a" err-pref err))) (when (or resource datatype parseType class subClassOf) - (error "~a~a is not allowed here!" + (error "~a~a is not allowed here (~a)!" err-pref (cond (resource (concatenate 'string "resource(" resource ")")) @@ -224,7 +224,8 @@ parseType ")")) (class (concatenate 'string "Class(" class ")")) (subClassOf (concatenate 'string "subClassOf(" - subClassOf ")"))))) + subClassOf ")"))) + (dom:node-name node))) (dolist (item *rdf-types*) (when (get-ns-attribute node item) (error "~ardf:~a is a type and not allowed here!"

1 0

[isidorus-cvs] r106 - in trunk/src: . unit_tests xml/rdf
by Lukas Giessmann 05 Aug '09

05 Aug '09

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

1 0

[isidorus-cvs] r105 - trunk/src/unit_tests
by Lukas Giessmann 04 Aug '09

04 Aug '09

Author: lgiessmann Date: Tue Aug 4 03:48:16 2009 New Revision: 105 Log: added unit tests for rdf-reification; currently reification is not mapped directly into topic maps, the rdf:id attribute is mapped into special nodes with special arcs, described in rdf/xml which are mapped into topic maps Modified: trunk/src/unit_tests/rdf_importer_test.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 Tue Aug 4 03:48:16 2009 @@ -31,7 +31,8 @@ *rdf2tm-subject* *rdf-subject* *rdf-object* - *rdf-predicate*) + *rdf-predicate* + *rdf-statement*) (:import-from :xml-tools xpath-child-elems-by-qname xpath-single-child-elem-by-qname @@ -1240,8 +1241,196 @@ (rdf-importer::import-node (elt (dom:child-nodes rdf-node) iter) tm-id revision-1 :document-id document-id)) - - )))) + (let ((reification-1 (d:get-item-by-id "http://test-tm#reification-1" + :xtm-id document-id)) + (reification-2 (d:get-item-by-id "http://test-tm#reification-2" + :xtm-id document-id)) + (first-node (d:get-item-by-id "http://test-tm/first-node" + :xtm-id document-id)) + (second-node (d:get-item-by-id "http://test-tm/second-node" + :xtm-id document-id)) + (third-node (d:get-item-by-id "http://test-tm/third-node" + :xtm-id document-id)) + (fourth-node (d:get-item-by-id "fourth-node" + :xtm-id document-id)) + (fifth-node (d:get-item-by-id "http://test-tm/fifth-node" + :xtm-id document-id)) + (arc1 (d:get-item-by-id "http://test/arcs/arc1" + :xtm-id document-id)) + (arc2 (d:get-item-by-id "http://test/arcs/arc2" + :xtm-id document-id)) + (arc3 (d:get-item-by-id "http://test/arcs/arc3" + :xtm-id document-id)) + (arc4 (d:get-item-by-id "http://test/arcs/arc4" + :xtm-id document-id)) + (statement (d:get-item-by-psi *rdf-statement*)) + (object (d:get-item-by-psi *rdf-object*)) + (subject (d:get-item-by-psi *rdf-subject*)) + (predicate (d:get-item-by-psi *rdf-predicate*)) + (type (d:get-item-by-psi *type-psi*)) + (instance (d:get-item-by-psi *instance-psi*)) + (type-instance (d:get-item-by-psi *type-instance-psi*)) + (isi-subject (d:get-item-by-psi *rdf2tm-subject*)) + (isi-object (d:get-item-by-psi *rdf2tm-object*))) + (is (= (length (d:psis reification-1)) 1)) + (is (string= (d:uri (first (d:psis reification-1))) + "http://test-tm#reification-1")) + (is (= (length (d:psis reification-2)) 1)) + (is (string= (d:uri (first (d:psis reification-2))) + "http://test-tm#reification-2")) + (is (= (length (d:psis first-node)) 1)) + (is (string= (d:uri (first (d:psis first-node))) + "http://test-tm/first-node")) + (is (= (length (d:psis second-node)) 1)) + (is (string= (d:uri (first (d:psis second-node))) + "http://test-tm/second-node")) + (is (= (length (d:psis third-node)) 1)) + (is (string= (d:uri (first (d:psis third-node))) + "http://test-tm/third-node")) + (is (= (length (d:psis fourth-node)) 0)) + (is (= (length (d:psis fifth-node)) 1)) + (is (string= (d:uri (first (d:psis fifth-node))) + "http://test-tm/fifth-node")) + (is (= (length (d:psis arc1)) 1)) + (is (string= (d:uri (first (d:psis arc1))) + "http://test/arcs/arc1")) + (is (= (length (d:psis arc2)))) + (is (string= (d:uri (first (d:psis arc2))) + "http://test/arcs/arc2")) + (is (= (length (d:psis arc3)))) + (is (string= (d:uri (first (d:psis arc3))) + "http://test/arcs/arc3")) + (is (= (length (d:psis arc4)))) + (is (string= (d:uri (first (d:psis arc4))) + "http://test/arcs/arc4")) + (is-true statement) + (is-true object) + (is-true subject) + (is-true predicate) + (is-true type) + (is-true instance) + (is-true type-instance) + (is (= (length (d:player-in-roles first-node)) 2)) + (is-true (find-if #'(lambda(x) + (and (eql (d:instance-of x) isi-subject) + (eql (d:instance-of (d:parent x)) arc1))) + (d:player-in-roles first-node))) + (is-true (find-if #'(lambda(x) + (and (eql (d:instance-of x) isi-object) + (eql (d:instance-of (d:parent x)) + subject))) + (d:player-in-roles first-node))) + (is (= (length (d:player-in-roles second-node)) 2)) + (is-true (find-if #'(lambda(x) + (and (eql (d:instance-of x) isi-object) + (eql (d:instance-of (d:parent x)) arc1))) + (d:player-in-roles second-node))) + (is-true (find-if #'(lambda(x) + (and (eql (d:instance-of x) isi-object) + (eql (d:instance-of (d:parent x)) + object))) + (d:player-in-roles second-node))) + (is (= (length (d:player-in-roles statement)) 2)) + (is-true (find-if #'(lambda(x) + (and (eql (d:instance-of x) type) + (eql (d:instance-of (d:parent x)) + type-instance))) + (d:player-in-roles statement))) + (is (= (length (d:player-in-roles arc1)) 1)) + (is-true (find-if #'(lambda(x) + (and (eql (d:instance-of x) isi-object) + (eql (d:instance-of (d:parent x)) + predicate))) + (d:player-in-roles arc1))) + (is (= (length (d:player-in-roles third-node)) 1)) + (is-true (find-if #'(lambda(x) + (and (eql (d:instance-of x) isi-object) + (eql (d:instance-of (d:parent x)) + arc2))) + (d:player-in-roles third-node))) + (is (= (length (d:player-in-roles reification-1)) 5)) + (is-true (find-if #'(lambda(x) + (and (eql (d:instance-of x) isi-subject) + (eql (d:instance-of (d:parent x)) + subject))) + (d:player-in-roles reification-1))) + (is-true (find-if #'(lambda(x) + (and (eql (d:instance-of x) isi-subject) + (eql (d:instance-of (d:parent x)) + object))) + (d:player-in-roles reification-1))) + (is-true (find-if #'(lambda(x) + (and (eql (d:instance-of x) instance) + (eql (d:instance-of (d:parent x)) + type-instance))) + (d:player-in-roles reification-1))) + (is-true (find-if #'(lambda(x) + (and (eql (d:instance-of x) isi-subject) + (eql (d:instance-of (d:parent x)) + object))) + (d:player-in-roles reification-1))) + (is-true (find-if #'(lambda(x) + (and (eql (d:instance-of x) isi-subject) + (eql (d:instance-of (d:parent x)) + predicate))) + (d:player-in-roles reification-1))) + (is-true (find-if #'(lambda(x) + (and (eql (d:instance-of x) isi-subject) + (eql (d:instance-of (d:parent x)) + arc2))) + (d:player-in-roles reification-1))) + (is (= (length (d:occurrences fourth-node)) 1)) + (is (string= (d:charvalue (first (d:occurrences fourth-node))) + "occurrence data")) + (is (string= (d:datatype (first (d:occurrences fourth-node))) + "http://test-tm/dt")) + (is (eql (d:instance-of (first (d:occurrences fourth-node))) + arc3)) + (is (= (length (d:player-in-roles fourth-node)) 1)) + (is-true (find-if #'(lambda(x) + (and (eql (d:instance-of x) isi-object) + (eql (d:instance-of (d:parent x)) + subject))) + (d:player-in-roles fourth-node))) + (is (= (length (d:player-in-roles arc3)) 1)) + (is-true (find-if #'(lambda(x) + (and (eql (d:instance-of x) isi-object) + (eql (d:instance-of (d:parent x)) + predicate))) + (d:player-in-roles arc3))) + (is (= (length (d:player-in-roles fifth-node)) 1)) + (is-true (find-if #'(lambda(x) + (and (eql (d:instance-of x) isi-object) + (eql (d:instance-of (d:parent x)) + arc4))) + (d:player-in-roles fifth-node))) + (is (= (length (d:occurrences reification-2)) 1)) + (is (string= (d:charvalue (first (d:occurrences reification-2))) + "occurrence data")) + (is (string= (d:datatype (first (d:occurrences reification-2))) + "http://test-tm/dt")) + (is (= (length (d:player-in-roles reification-2)) 4)) + (is-true (find-if #'(lambda(x) + (and (eql (d:instance-of x) isi-subject) + (eql (d:instance-of (d:parent x)) + subject))) + (d:player-in-roles reification-2))) + (is-true (find-if #'(lambda(x) + (and (eql (d:instance-of x) isi-subject) + (eql (d:instance-of (d:parent x)) + predicate))) + (d:player-in-roles reification-2))) + (is-true (find-if #'(lambda(x) + (and (eql (d:instance-of x) isi-subject) + (eql (d:instance-of (d:parent x)) + arc4))) + (d:player-in-roles reification-2))) + (is-true (find-if #'(lambda(x) + (and (eql (d:instance-of x) instance) + (eql (d:instance-of (d:parent x)) + type-instance))) + (d:player-in-roles reification-2))) + (elephant:close-store))))))

1 0

[isidorus-cvs] r104 - in trunk/src: unit_tests xml/rdf
by Lukas Giessmann 03 Aug '09

03 Aug '09

Author: lgiessmann Date: Mon Aug 3 15:00:53 2009 New Revision: 104 Log: fixed a bug in the rdf-importer module which affects reification of arcs contains literal content Modified: trunk/src/unit_tests/rdf_importer_test.lisp trunk/src/xml/rdf/importer.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 3 15:00:53 2009 @@ -1203,8 +1203,45 @@ (test test-import-node-reification - - ) + "Tests the function import-node non-recursively. Especially the reification + of association- and occurrence-arcs." + (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:Description rdf:about=\"first-node\">" + "<arcs:arc1 rdf:ID=\"reification-1\">" + "<rdf:Description rdf:about=\"second-node\" />" + "</arcs:arc1>" + "</rdf:Description>" + "<rdf:Description rdf:ID=\"#reification-1\">" + "<arcs:arc2 rdf:resource=\"third-node\"/>" + "</rdf:Description>" + "<rdf:Description rdf:nodeID=\"fourth-node\">" + "<arcs:arc3 rdf:ID=\"reification-2\" rdf:datatype=\"dt\">" + "occurrence data" + "</arcs:arc3>" + "</rdf:Description>" + "<rdf:Description rdf:ID=\"#reification-2\">" + "<arcs:arc4 rdf:resource=\"fifth-node\" />" + "</rdf:Description>" + "</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)) + (let ((rdf-node (elt (dom:child-nodes dom-1) 0))) + (is (= (length (dom:child-nodes rdf-node)) 4)) + (rdf-init-db :db-dir db-dir :start-revision revision-1) + (dotimes (iter (length (dom:child-nodes rdf-node))) + (rdf-importer::import-node (elt (dom:child-nodes rdf-node) iter) + tm-id revision-1 + :document-id document-id)) + + )))) Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Mon Aug 3 15:00:53 2009 @@ -315,7 +315,7 @@ (list :instance-of role-type-2 :player top)))) (when ID - (make-reification ID top type-top player-1 start-revision + (make-reification ID top player-1 type-top start-revision tm :document-id document-id)) (add-to-topicmap tm (make-construct 'AssociationC :start-revision start-revision @@ -348,6 +348,7 @@ (declare ((or OccurrenceC TopicC) object)) (declare (TopicC subject predicate)) (declare (TopicMapC tm)) + (let ((reifier (make-topic-stub reifier-id nil nil nil start-revision tm :document-id document-id)) (predicate-arc (make-topic-stub *rdf-predicate* nil nil nil start-revision @@ -365,10 +366,10 @@ start-revision) (make-association-with-nodes reifier predicate predicate-arc tm start-revision) - (if (typep object 'TopicC) + (if (typep object 'd:TopicC) (make-association-with-nodes reifier object object-arc tm start-revision) - (make-construct 'OccurrenceC + (make-construct 'd:OccurrenceC :start-revision start-revision :topic reifier :themes (themes object) @@ -406,7 +407,7 @@ :charvalue value :datatype datatype))) (when ID - (make-reification ID top type-top occurrence start-revision + (make-reification ID top occurrence type-top start-revision xml-importer::tm :document-id document-id)) occurrence))))))

1 0

[isidorus-cvs] r103 - in trunk/src: unit_tests xml/rdf xml/xtm
by Lukas Giessmann 03 Aug '09

03 Aug '09

Author: lgiessmann Date: Mon Aug 3 13:08:11 2009 New Revision: 103 Log: added some unit tests for the rdf-importer and fixed several bugs Modified: trunk/src/unit_tests/rdf_importer_test.lisp trunk/src/xml/rdf/importer.lisp trunk/src/xml/rdf/rdf_core_psis.xtm 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 Mon Aug 3 13:08:11 2009 @@ -19,7 +19,19 @@ *rdfs-ns* *rdf2tm-ns* *xml-ns* - *xml-string*) + *xml-string* + *instance-psi* + *type-psi* + *type-instance-psi* + *subtype-psi* + *supertype-psi* + *supertype-subtype-psi* + *xml-string* + *rdf2tm-object* + *rdf2tm-subject* + *rdf-subject* + *rdf-object* + *rdf-predicate*) (:import-from :xml-tools xpath-child-elems-by-qname xpath-single-child-elem-by-qname @@ -36,7 +48,9 @@ :test-get-literals-of-content :test-get-super-classes-of-node-content :test-get-associations-of-node-content - :test-parse-properties-of-node)) + :test-parse-properties-of-node + :test-import-node-1 + :test-import-node-reification)) (declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0))) @@ -49,6 +63,16 @@ (in-suite rdf-importer-test) +(defun rdf-init-db (&key (db-dir "data_base") (start-revision (get-revision))) + "Empties the data base files and initializes isidorus for rdf." + (when elephant:*store-controller* + (elephant:close-store)) + (clean-out-db db-dir) + (elephant:open-store (xml-importer:get-store-spec db-dir)) + (xml-importer:init-isidorus start-revision) + (rdf-importer:init-rdf-module start-revision)) + + (test test-get-literals-of-node "Tests the helper function get-literals-of-node." (let ((doc-1 @@ -967,7 +991,221 @@ (rdf-importer::remove-node-properties-from-*_n-map* node) (is (= (length rdf-importer::*_n-map*) 0)))))) + +(test test-import-node-1 + "Tests the function import-node non-recursively." + (let ((db-dir "data_base") + (tm-id "http://test-tm/") + (revision-1 100) + (revision-2 200) + (revision-3 300) + (document-id "doc-id") + (doc-1 + (concatenate 'string "<rdf:RDF xmlns:rdf=\"" *rdf-ns* "\" " + "xmlns:arcs=\"http://test/arcs/\" " + "xmlns:rdfs=\"" *rdfs-ns* "\">" + "<rdf:Description rdf:about=\"first-node\">" + "<rdf:type rdf:resource=\"first-type\" />" + "</rdf:Description>" + "<rdf:Description rdf:type=\"second-type\" " + "rdf:nodeID=\"second-node\">" + "<rdfs:subClassOf>" + "<rdf:Description rdf:ID=\"third-node\" />" + "</rdfs:subClassOf>" + "</rdf:Description>" + "<rdf:Description arcs:arc1=\"arc-1\">" + "<arcs:arc2 rdf:datatype=\"dt\">arc-2</arcs:arc2>" + "</rdf:Description>" + "<rdf:Description rdf:about=\"fourth-node\">" + "<arcs:arc3 rdf:parseType=\"Literal\"><root>" + "<content type=\"anyContent\">content</content>" + "</root></arcs:arc3>" + "</rdf:Description>" + "<rdf:Description rdf:ID=\"fifth-node\">" + "<arcs:arc4 rdf:parseType=\"Resource\">" + "<arcs:arc5 rdf:resource=\"arc-5\" />" + "</arcs:arc4>" + "</rdf:Description>" + "</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)) + (let ((rdf-node (elt (dom:child-nodes dom-1) 0))) + (is (= (length (dom:child-nodes rdf-node)) 5)) + (let ((node (elt (dom:child-nodes rdf-node) 0))) + (rdf-init-db :db-dir db-dir :start-revision revision-1) + (rdf-importer::import-node node tm-id revision-2 + :document-id document-id) + (is (= (length (elephant:get-instances-by-class 'd:TopicC)) 20)) + (let ((first-node (get-item-by-id "http://test-tm/first-node" + :xtm-id document-id)) + (first-type (get-item-by-id "http://test-tm/first-type" + :xtm-id document-id))) + (is-true first-node) + (is (= (length (d::versions first-node)) 1)) + (is (= (d::start-revision (first (d::versions first-node))) + revision-2)) + (is (= (d::end-revision (first (d::versions first-node))) 0)) + (is-true first-type) + (is (= (length (d:player-in-roles first-node)) 1)) + (is (= (length (d:player-in-roles first-type)) 1)) + (let ((instance-role + (first (d:player-in-roles first-node))) + (type-role + (first (d:player-in-roles first-type))) + (type-assoc + (d:parent (first (d:player-in-roles first-node))))) + (is (= (length (d::versions type-assoc)) 1)) + (is (= (d::start-revision (first (d::versions type-assoc))) + revision-2)) + (is (eql (d:instance-of instance-role) + (d:get-item-by-psi *instance-psi*))) + (is (eql (d:instance-of type-role) + (d:get-item-by-psi *type-psi*))) + (is (eql (d:instance-of type-assoc) + (d:get-item-by-psi *type-instance-psi*))) + (is (= (length (d:roles type-assoc)) 2)) + (is (= (length (d:psis first-node)) 1)) + (is (= (length (d:psis first-type)) 1)) + (is (string= (d:uri (first (d:psis first-node))) + "http://test-tm/first-node")) + (is (string= (d:uri (first (d:psis first-type))) + "http://test-tm/first-type")) + (is (= (length (elephant:get-instances-by-class 'd:OccurrenceC)))) + (is (= (length (elephant:get-instances-by-class 'd:NameC)))) + (is (= (length (elephant:get-instances-by-class 'd:VariantC))))) + (dotimes (iter (length (dom:child-nodes rdf-node))) + (rdf-importer::import-node (elt (dom:child-nodes rdf-node) iter) + tm-id revision-3 + :document-id document-id)) + (let ((first-node (get-item-by-id "http://test-tm/first-node" + :xtm-id document-id)) + (first-type (get-item-by-id "http://test-tm/first-type" + :xtm-id document-id)) + (second-node (get-item-by-id "second-node" + :xtm-id document-id)) + (second-type (get-item-by-id "http://test-tm/second-type" + :xtm-id document-id)) + (third-node (get-item-by-id "http://test-tm#third-node" + :xtm-id document-id))) + (is-true second-node) + (is-false (d:psis second-node)) + (is-false (d:occurrences second-node)) + (is-false (d:names second-node)) + (is-true first-node) + (is (= (length (d::versions first-node)) 2)) + (is-true (find-if #'(lambda(x) + (and (= (d::start-revision x) revision-2) + (= (d::end-revision x) revision-3))) + (d::versions first-node))) + (is-true (find-if #'(lambda(x) + (and (= (d::start-revision x) revision-3) + (= (d::end-revision x) 0))) + (d::versions first-node))) + (let ((instance-role + (first (d:player-in-roles first-node))) + (type-role + (first (d:player-in-roles first-type))) + (type-assoc + (d:parent (first (d:player-in-roles first-node)))) + (type-topic (get-item-by-psi *type-psi*)) + (instance-topic (get-item-by-psi *instance-psi*)) + (type-instance-topic (get-item-by-psi *type-instance-psi*)) + (supertype-topic (get-item-by-psi *supertype-psi*)) + (subtype-topic (get-item-by-psi *subtype-psi*)) + (supertype-subtype-topic + (get-item-by-psi *supertype-subtype-psi*)) + (arc2-occurrence (elephant:get-instance-by-value + 'd:OccurrenceC 'd:charvalue "arc-2")) + (arc3-occurrence + (elephant:get-instance-by-value + 'd:OccurrenceC 'd:charvalue + "<root><content type=\"anyContent\">content</content></root>")) + (fifth-node (d:get-item-by-id "http://test-tm#fifth-node" + :xtm-id document-id))) + (is (eql (d:instance-of instance-role) + (d:get-item-by-psi *instance-psi*))) + (is (eql (d:instance-of type-role) + (d:get-item-by-psi *type-psi*))) + (is (eql (d:instance-of type-assoc) + (d:get-item-by-psi *type-instance-psi*))) + (is (= (length (d:roles type-assoc)) 2)) + (is (= (length (d:psis first-node)) 1)) + (is (= (length (d:psis first-type)) 1)) + (is (= (length (d::versions type-assoc)) 1)) + (is (= (length (d:player-in-roles second-node)) 2)) + (is-true (find-if + #'(lambda(x) + (and (eql (d:instance-of x) instance-topic) + (eql (d:instance-of (d:parent x) ) + type-instance-topic))) + (d:player-in-roles second-node))) + (is-true (find-if + #'(lambda(x) + (and (eql (d:instance-of x) subtype-topic) + (eql (d:instance-of (d:parent x) ) + supertype-subtype-topic))) + (d:player-in-roles second-node))) + (is-true (find-if + #'(lambda(x) + (and (eql (d:instance-of x) type-topic) + (eql (d:instance-of (d:parent x) ) + type-instance-topic))) + (d:player-in-roles second-type))) + (is-true (find-if + #'(lambda(x) + (and (eql (d:instance-of x) supertype-topic) + (eql (d:instance-of (d:parent x) ) + supertype-subtype-topic))) + (d:player-in-roles third-node))) + (is-true arc2-occurrence) + (is (string= (d:datatype arc2-occurrence) "http://test-tm/dt")) + (is-false (d:psis (d:topic arc2-occurrence))) + (is (= (length (d::versions (d:topic arc2-occurrence))) 1)) + (is (= (d::start-revision + (first (d::versions (d:topic arc2-occurrence)))) + revision-3)) + (is (= (d::end-revision + (first (d::versions (d:topic arc2-occurrence)))) 0)) + (is-true arc3-occurrence) + (is (= (length (d:psis (d:topic arc3-occurrence))))) + (is (string= (d:uri (first (d:psis (d:topic arc3-occurrence)))) + "http://test-tm/fourth-node")) + (is (string= (d:datatype arc3-occurrence) + *xml-string*)) + (is-true fifth-node) + (is (= (length (d:psis fifth-node)) 1)) + (is (string= (d:uri (first (d:psis fifth-node))) + "http://test-tm#fifth-node")) + (is-false (d:occurrences fifth-node)) + (is-false (d:names fifth-node)) + (is (= (length (d:player-in-roles fifth-node)))) + (let ((assoc (d:parent (first (d:player-in-roles + fifth-node))))) + (is-true assoc) + (let ((object-role + (find-if + #'(lambda(role) + (eql (d:instance-of role) + (d:get-item-by-psi *rdf2tm-object*))) + (d:roles assoc))) + (subject-role + (find-if + #'(lambda(role) + (eql (d:instance-of role) + (d:get-item-by-psi *rdf2tm-subject*))) + (d:roles assoc)))) + (is-true object-role) + (is-true subject-role) + (is (eql (d:player subject-role) fifth-node)) + (is-false (d:psis (d:player object-role)))))))))))) + (elephant:close-store)) + +(test test-import-node-reification + + ) + (defun run-rdf-importer-tests() @@ -979,4 +1217,6 @@ (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) - (it.bese.fiveam:run! 'test-parse-properties-of-node)) \ No newline at end of file + (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 Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Mon Aug 3 13:08:11 2009 @@ -8,7 +8,7 @@ (in-package :rdf-importer) -(defvar *document-id* nil) +(defvar *document-id* "isidorus-rdf-document") (defun setup-rdf-module (rdf-xml-path repository-path @@ -37,15 +37,16 @@ "Imports the file correponding to the given path." (setf *document-id* document-id) (tm-id-p tm-id "rdf-importer") - (unless elephant:*store-controller* - (elephant:open-store - (get-store-spec repository-path))) - (let ((rdf-dom - (dom:document-element (cxml:parse-file - (truename rdf-xml-path) - (cxml-dom:make-dom-builder))))) - (import-dom rdf-dom start-revision :tm-id tm-id :document-id document-id)) - (setf *_n-map* nil)) + (with-writer-lock + (unless elephant:*store-controller* + (elephant:open-store + (get-store-spec repository-path))) + (let ((rdf-dom + (dom:document-element (cxml:parse-file + (truename rdf-xml-path) + (cxml-dom:make-dom-builder))))) + (import-dom rdf-dom start-revision :tm-id tm-id :document-id document-id)) + (setf *_n-map* nil))) (defun init-rdf-module (&optional (revision (get-revision))) @@ -108,61 +109,99 @@ (get-literals-of-node-content elem tm-id xml-base xml-lang))) (associations (get-associations-of-node-content elem tm-id xml-base)) - (types (append (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 fn-xml-base))) + (types (remove-if + #'null + (append (list + (unless (string= (get-type-of-node-name elem) + (concatenate 'string *rdf-ns* + "Description")) + (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))) (with-tm (start-revision document-id tm-id) - (let ((topic-stub - (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) - (getf type :topicid) - nil 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) - - ;TODO: - ;*import standard topics from isidorus' rdf2tm namespace - ; (must be explicitly called by the user) - ;*get-topic by topic id - ;*make psis - ;*if the topic does not exist create one with topic id - ;*add psis - ;*make instance-of associations + reification - ;make super-sub-class associations + reification - ;*make occurrences + reification - ;*make associations + reification - - - ;TODO: start recursion ... - (remove-node-properties-from-*_n-map* elem) - (or super-classes) ;TODO: remove - ))))) + (elephant:ensure-transaction (:txn-nosync t) + (let ((topic-stub + (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))))))) +(defun make-supertype-subtype-association (sub-top super-top reifier-id + start-revision tm + &key (document-id *document-id*)) + "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*)) + (err-pref "From make-supertype-subtype-association(): ")) + (unless assoc-type + (error "~athe association type ~a is missing!" + err-pref *supertype-subtype-psi*)) + (unless (or role-type-1 role-type-2) + (error "~aone of the role types ~a ~a is missing!" + err-pref *supertype-psi* *subtype-psi*)) + (elephant:ensure-transaction (:txn-nosync t) + (let ((a-roles (list (list :instance-of role-type-1 + :player super-top) + (list :instance-of role-type-2 + :player sub-top)))) + (when reifier-id + (make-reification reifier-id sub-top super-top + assoc-type start-revision tm + :document-id document-id)) + (add-to-topicmap + tm + (make-construct 'AssociationC + :start-revision start-revision + :instance-of assoc-type + :roles a-roles)))))) + (defun make-instance-of-association (instance-top type-top reifier-id start-revision tm @@ -175,21 +214,29 @@ (roletype-1 (get-item-by-psi *type-psi*)) (roletype-2 - (get-item-by-psi *instance-psi*))) - (let ((a-roles (list (list :instance-of roletype-1 - :player type-top) - (list :instance-of roletype-2 - :player instance-top)))) - (when reifier-id - (make-reification reifier-id instance-top type-top - assoc-type start-revision tm - :document-id document-id)) - (add-to-topicmap - tm - (make-construct 'AssociationC - :start-revision start-revision - :instance-of assoc-type - :roles a-roles))))) + (get-item-by-psi *instance-psi*)) + (err-pref "From make-instance-of-association(): ")) + (unless assoc-type + (error "~athe association type ~a is missing!" + err-pref *type-instance-psi*)) + (unless (or roletype-1 roletype-2) + (error "~aone of the role types ~a ~a is missing!" + err-pref *type-psi* *instance-psi*)) + (elephant:ensure-transaction (:txn-nosync t) + (let ((a-roles (list (list :instance-of roletype-1 + :player type-top) + (list :instance-of roletype-2 + :player instance-top)))) + (when reifier-id + (make-reification reifier-id instance-top type-top + assoc-type start-revision tm + :document-id document-id)) + (add-to-topicmap + tm + (make-construct 'AssociationC + :start-revision start-revision + :instance-of assoc-type + :roles a-roles)))))) (defun make-topic-stub (about ID nodeId UUID start-revision @@ -200,8 +247,18 @@ (declare (TopicMapC tm)) (let ((topic-id (or about ID nodeID UUID)) (psi-uri (or about ID))) - (let ((top (get-item-by-id topic-id :xtm-id document-id - :revision start-revision))) + (let ((top + ;seems like there is a bug in get-item-by-id: + ;this functions returns an emtpy topic although there is no one + ;witha corresponding topic id and/or version and/or xtm-id + (let ((inner-top + (get-item-by-id topic-id :xtm-id document-id + :revision start-revision))) + (when (and inner-top + (find-if #'(lambda(x) + (= (d::start-revision x) start-revision)) + (d::versions inner-top))) + inner-top)))) (if top top (elephant:ensure-transaction (:txn-nosync t) @@ -245,24 +302,26 @@ (player-id (getf association :topicid)) (player-psi (getf association :psi)) (ID (getf association :ID))) - (let ((player-1 (make-topic-stub player-psi player-id nil 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*)) - (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 - :player player-1) - (list :instance-of role-type-2 - :player top)))) - (when ID - (make-reification ID top type-top player-1 start-revision - tm :document-id document-id)) - (add-to-topicmap tm (make-construct 'AssociationC - :start-revision start-revision - :instance-of type-top - :roles roles)))))) - + (elephant:ensure-transaction (:txn-nosync t) + (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*)) + (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 + :player player-1) + (list :instance-of role-type-2 + :player top)))) + (when ID + (make-reification ID top type-top player-1 start-revision + tm :document-id document-id)) + (add-to-topicmap tm (make-construct 'AssociationC + :start-revision start-revision + :instance-of type-top + :roles roles))))))) + (defun make-association-with-nodes (subject-topic object-topic associationtype-topic tm start-revision) @@ -275,10 +334,11 @@ :player subject-topic) (list :instance-of role-type-2 :player object-topic)))) - (add-to-topicmap tm (make-construct 'AssociationC - :start-revision start-revision - :instance-of associationtype-topic - :roles roles))))) + (elephant:ensure-transaction (:txn-nosync t) + (add-to-topicmap tm (make-construct 'AssociationC + :start-revision start-revision + :instance-of associationtype-topic + :roles roles)))))) (defun make-reification (reifier-id subject object predicate start-revision tm @@ -294,25 +354,27 @@ tm :document-id document-id)) (object-arc (make-topic-stub *rdf-object* nil nil nil start-revision tm :document-id document-id)) - (subject-arc (make-topic-stub *rdf-object* nil nil nil start-revision + (subject-arc (make-topic-stub *rdf-subject* nil nil nil start-revision tm :document-id document-id)) (statement (make-topic-stub *rdf-statement* nil nil nil start-revision tm :document-id document-id))) - (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) - (make-association-with-nodes reifier predicate-arc predicate - tm start-revision) - (if (typep object 'TopicC) - (make-association-with-nodes reifier object object-arc - tm start-revision) - (make-construct 'OccurrenceC - :start-revision start-revision - :topic reifier - :themes (themes object) - :instance-of (instance-of object) - :charvalue (charvalue object) - :datatype (datatype object))))) + (elephant:ensure-transaction (:txn-nosync t) + (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) + (make-association-with-nodes reifier predicate predicate-arc + tm start-revision) + (if (typep object 'TopicC) + (make-association-with-nodes reifier object object-arc + tm start-revision) + (make-construct 'OccurrenceC + :start-revision start-revision + :topic reifier + :themes (themes object) + :instance-of (instance-of object) + :charvalue (charvalue object) + :datatype (datatype object)))))) (defun make-occurrence (top literal start-revision tm-id @@ -327,25 +389,26 @@ (lang (getf literal :lang)) (datatype (getf literal :datatype)) (ID (getf literal :ID))) - (let ((type-top (make-topic-stub type nil nil nil start-revision - xml-importer::tm - :document-id document-id)) - (lang-top (make-lang-topic lang tm-id start-revision - xml-importer::tm - :document-id document-id))) - (let ((occurrence - (make-construct 'OccurrenceC - :start-revision start-revision - :topic top - :themes (when lang-top - (list lang-top)) - :instance-of type-top - :charvalue value - :datatype datatype))) - (when ID - (make-reification ID top type-top occurrence start-revision - xml-importer::tm :document-id document-id)) - occurrence))))) + (elephant:ensure-transaction (:txn-nosync t) + (let ((type-top (make-topic-stub type nil nil nil start-revision + xml-importer::tm + :document-id document-id)) + (lang-top (make-lang-topic lang tm-id start-revision + xml-importer::tm + :document-id document-id))) + (let ((occurrence + (make-construct 'OccurrenceC + :start-revision start-revision + :topic top + :themes (when lang-top + (list lang-top)) + :instance-of type-top + :charvalue value + :datatype datatype))) + (when ID + (make-reification ID top type-top occurrence start-revision + xml-importer::tm :document-id document-id)) + occurrence)))))) (defun get-literals-of-node-content (node tm-id xml-base xml-lang) Modified: trunk/src/xml/rdf/rdf_core_psis.xtm ============================================================================== --- trunk/src/xml/rdf/rdf_core_psis.xtm (original) +++ trunk/src/xml/rdf/rdf_core_psis.xtm Mon Aug 3 13:08:11 2009 @@ -17,11 +17,32 @@ </name> </topic> - <topic id="object"> + <topic id="object"> <subjectIdentifier href="http://isidorus/rdf2tm_mapping#object"/> <name> <value>object</value> </name> </topic> + <topic id="supertype-subtype"> + <subjectIdentifier href="http://psi.topicmaps.org/iso13250/model/supertype-subtype"/> + <name> + <value>supertype-subtype</value> + </name> + </topic> + + <topic id="superclass"> + <subjectIdentifier href="http://psi.topicmaps.org/iso13250/model/supertype"/> + <name> + <value>supertype</value> + </name> + </topic> + + <topic id="subtype"> + <subjectIdentifier href="http://psi.topicmaps.org/iso13250/model/subtype"/> + <name> + <value>subtype</value> + </name> + </topic> + </topicMap> 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 3 13:08:11 2009 @@ -24,7 +24,10 @@ *rdf-subject* *rdf-predicate* *rdf2tm-object* - *rdf2tm-subject*) + *rdf2tm-subject* + *supertype-psi* + *subtype-psi* + *supertype-subtype-psi*) (:import-from :xml-constants *rdf_core_psis.xtm*) (:import-from :xml-constants @@ -59,7 +62,11 @@ with-writer-lock) (:import-from :exceptions missing-reference-error - duplicate-identifier-error)) + duplicate-identifier-error) + (:export :setup-rdf-module + :rdf-importer + :init-rdf-module + :*rdf-core-xtm*)) (in-package :rdf-importer) Modified: trunk/src/xml/xtm/tools.lisp ============================================================================== --- trunk/src/xml/xtm/tools.lisp (original) +++ trunk/src/xml/xtm/tools.lisp Mon Aug 3 13:08:11 2009 @@ -71,6 +71,8 @@ "Returns the passed id as an absolute uri computed with the given base and tm-id." (declare (string id tm-id)) + (when (= (length id) 0) + (error "From absolutize-id(): id must be set to a string with length > 0!")) (let ((prep-id (if (and (> (length id) 0) (eql (elt id 0) #\#)) id @@ -109,7 +111,11 @@ (prep-tm-id (when (> (length tm-id) 0) (string-right-trim "/" tm-id)))) - (concatenate 'string prep-tm-id "/" prep-fragment))))))) + (let ((separator + (if (eql (elt prep-fragment 0) #\#) + "" + "/"))) + (concatenate 'string prep-tm-id separator prep-fragment)))))))) (defun get-xml-lang(elem &key (old-lang nil))

1 0