Author: lgiessmann Date: Mon Jul 27 10:31:40 2009 New Revision: 96
Log: added some basic helpers and a unit test file
Added: trunk/src/unit_tests/rdf_importer_test.lisp Modified: trunk/src/constants.lisp trunk/src/isidorus.asd trunk/src/xml/rdf/importer.lisp trunk/src/xml/rdf/rdf_tools.lisp trunk/src/xml/xtm/tools.lisp
Modified: trunk/src/constants.lisp ============================================================================== --- trunk/src/constants.lisp (original) +++ trunk/src/constants.lisp Mon Jul 27 10:31:40 2009 @@ -25,7 +25,8 @@ :*rdfs-ns* :*xml-ns* :*xmlns-ns* - :*xml-string*)) + :*xml-string* + :*rdf2tm-ns*))
(in-package :constants) (defparameter *xtm2.0-ns* "http://www.topicmaps.org/xtm/") @@ -60,4 +61,6 @@
(defparameter *xmlns-ns* "http://www.w3.org/2000/xmlns/")
-(defparameter *xml-string* "http://www.w3.org/2001/XMLSchema#string") \ No newline at end of file +(defparameter *xml-string* "http://www.w3.org/2001/XMLSchema#string") + +(defparameter *rdf2tm-ns* "http://isidorus/rdf2tm_mapping/") \ No newline at end of file
Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Mon Jul 27 10:31:40 2009 @@ -133,7 +133,8 @@ :depends-on ("fixtures")) (:file "json_test" :depends-on ("fixtures")) - (:file "threading_test")) + (:file "threading_test") + (:file "rdf_importer_test")) :depends-on ("atom" "constants" "model"
Added: trunk/src/unit_tests/rdf_importer_test.lisp ============================================================================== --- (empty file) +++ trunk/src/unit_tests/rdf_importer_test.lisp Mon Jul 27 10:31:40 2009 @@ -0,0 +1,128 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2009 Marc Kuester, Christoph Ludwig, Lukas Giessmann +;;+ +;;+ Isidorus is freely distributable under the LGPL license. +;;+ You can find a detailed description in trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- + + +(defpackage :rdf-importer-test + (:use + :common-lisp + :xml-importer + :datamodel + :it.bese.FiveAM + :unittests-constants + :fixtures) + (:import-from :constants + *rdf-ns* + *rdfs-ns* + *rdf2tm-ns*) + (:import-from :xml-tools + xpath-child-elems-by-qname + xpath-single-child-elem-by-qname + xpath-select-location-path + get-ns-attribute) + (:export :test-get-literals-of-node + :test-parse-node + :run-rdf-importer-tests)) + +(declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0))) + +(in-package :rdf-importer-test) + + +(def-suite importer-test + :description "tests various key functions of the importer") + +(in-suite importer-test) + + +(test test-get-literals-of-node + "Tests the helper function get-literals-of-node." + (let ((doc-1 + (concatenate 'string "<rdf:Description xmlns:rdf="" *rdf-ns* "" " + "xmlns:isi="http://isidorus/test#%5C" " + "rdf:type="rdfType" rdf:ID="rdfID" rdf:nodeID="" + "rdfNodeID" rdf:unknown="rdfUnknown" " + "isi:ID="isiID" isi:arc="isiArc"/>")) + (doc-2 + (concatenate 'string "<rdf:Description xmlns:rdf="" *rdf-ns* "" " + "xmlns:rdfs="" *rdfs-ns* "" " + "rdfs:subClassOf="rdfsSubClassOf" />"))) + (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder))) + (dom-2 (cxml:parse doc-2 (cxml-dom:make-dom-builder)))) + (is (= (length (dom:child-nodes dom-1)) 1)) + (is (= (length (dom:child-nodes dom-2)) 1)) + (let ((literals (rdf-importer::get-literals-of-node + (elt (dom:child-nodes dom-1) 0)))) + (is-true literals) + (is (= (length literals) 3)) + (is-true (find-if #'(lambda(x) + (and + (string= (getf x :value) "rdfUnknown") + (string= (getf x :type) + (concatenate 'string *rdf-ns* "unknown")))) + literals)) + (is-true (find-if #'(lambda(x) + (and + (string= (getf x :value) "isiID") + (string= (getf x :type) + "http://isidorus/test#ID"))) + literals)) + (is-true (find-if #'(lambda(x) + (and + (string= (getf x :value) "isiArc") + (string= (getf x :type) + "http://isidorus/test#arc"))) + literals))) + (signals error (rdf-importer::get-literals-of-node + (elt (dom:child-nodes dom-2) 0)))))) + + +(test test-parse-node + "Tests the parse-node function." + (let ((doc-1 + (concatenate 'string "<rdf:Description xmlns:rdf="" *rdf-ns* "" " + "xmlns:isi="" *rdf2tm-ns* "" " + "xmlns:arcs="http://test/arcs/%5C" " + "rdf:ID="rdfID" xml:base="xmlBase" " + "arcs:arc="arcsArc">" + "arcs:rel" + "<rdf:Element rdf:about="element"/>" + "</arcs:rel>" + "</rdf:Description>"))) + (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder)))) + (is (length (dom:child-nodes dom-1)) 1) + (let ((node (elt (dom:child-nodes dom-1) 0))) + (is-true (rdf-importer::parse-node node)) + (is-false (get-ns-attribute node "UUID" :ns-uri *rdf2tm-ns*)) + (dom:set-attribute-ns node *rdf-ns* "about" "rdfAbout") + (signals error (rdf-importer::parse-node node)) + (dom:set-attribute-ns node *rdf-ns* "nodeID" "rdfNodeID") + (signals error (rdf-importer::parse-node node)) + (dom:remove-attribute-ns node *rdf-ns* "about") + (signals error (rdf-importer::parse-node node)) + (dom:remove-attribute-ns node *rdf-ns* "ID") + (is-true (rdf-importer::parse-node node)) + (dom:set-attribute-ns node *rdf-ns* "about" "rdfAbout") + (signals error (rdf-importer::parse-node node)) + (is-false (get-ns-attribute node "UUID" :ns-uri *rdf2tm-ns*)) + (dom:remove-attribute-ns node *rdf-ns* "about") + (dom:remove-attribute-ns node *rdf-ns* "nodeID") + (is-true (rdf-importer::parse-node node)) + (is-true (get-ns-attribute node "UUID" :ns-uri *rdf2tm-ns*)) + (dom:replace-child node (dom:create-text-node dom-1 "anyText") + (xpath-single-child-elem-by-qname + node "http://test/arcs/" "rel")) + (signals error (rdf-importer::parse-node node)))))) + + + + + + +(defun run-rdf-importer-tests() + (it.bese.fiveam:run! 'test-get-literals-of-node) + (it.bese.fiveam:run! 'test-parse-node)) \ No newline at end of file
Modified: trunk/src/xml/rdf/importer.lisp ============================================================================== --- trunk/src/xml/rdf/importer.lisp (original) +++ trunk/src/xml/rdf/importer.lisp Mon Jul 27 10:31:40 2009 @@ -8,24 +8,51 @@ (in-package :rdf-importer)
-;(defun rdf-importer (rdf-xml-path repository-path -; &key -; (tm-id (error "you must provide a stable identifier (PSI-style) for this TM")) -; (document-id (get-uuid))) -; (unless (absolute-uri-p tm-id) -; (error "From rdf-impoert(): you must provide a stable identifier (PSI-style) for this TM")) -; (let ((rdf-dom -; (dom:document-element (cxml:parse-file -; (truename rdf-xml-path) -; (cxml-dom:make-dom-builder))))) -; (unless elephant:*store-controller* -; (elephant:open-store -; (get-store-spec repository-path))) -; (import-nodes rdf-dom :tm-id tm-id :document-id document-id)) -; (setf *arc-uuids* nil)) - +(defvar *document-id* nil)
+(defun tm-id-p (tm-id fun-name) + "Checks the validity of the passed tm-id." + (unless (absolute-uri-p tm-id) + (error "From ~a(): you must provide a stable identifier (PSI-style) for this TM: ~a!" + fun-name tm-id))) + + +(defun rdf-importer (rdf-xml-path repository-path + &key + (tm-id nil) + (document-id (get-uuid))) + (setf *document-id* document-id) + (tm-id-p tm-id "rdf-importer") + (let ((rdf-dom + (dom:document-element (cxml:parse-file + (truename rdf-xml-path) + (cxml-dom:make-dom-builder))))) + (unless elephant:*store-controller* + (elephant:open-store + (get-store-spec repository-path))) + (import-dom rdf-dom :tm-id tm-id :document-id document-id)))
+(defun import-dom (rdf-dom &key (tm-id nil) (document-id *document-id*)) + (tm-id-p tm-id "import-dom") + (let ((xml-base (get-xml-base rdf-dom)) + (xml-lang (get-xml-lang rdf-dom)) + (elem-name (get-node-name rdf-dom)) + (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))) + (loop for child across children + do (import-node child tm-id :document-id document-id + :xml-base xml-base :xml-lang xml-lang))) + (import-node rdf-dom tm-id :document-id document-id + :xml-base xml-base :xml-lang xml-lang)))) + + +(defun import-node (elem tm-id &key (document-id *document-id*) + (xml-base nil) (xml-lang nil)) + (parse-node elem) + ) \ No newline at end of file
Modified: trunk/src/xml/rdf/rdf_tools.lisp ============================================================================== --- trunk/src/xml/rdf/rdf_tools.lisp (original) +++ trunk/src/xml/rdf/rdf_tools.lisp Mon Jul 27 10:31:40 2009 @@ -13,7 +13,8 @@ *rdfs-ns* *xml-ns* *xmlns-ns* - *xml-string*) + *xml-string* + *rdf2tm-ns*) (:import-from :xml-constants *core_psis.xtm*) (:import-from :xml-tools @@ -55,4 +56,117 @@ (handler-case (let ((int (parse-integer rest))) int) - (condition () nil))))) \ No newline at end of file + (condition () nil))))) + + +(defun parse-node-name (node) + "Parses the given node's name to the known rdf/rdfs nodes and arcs. + If the given name es equal to a property an error is thrown otherwise + there is displayed a warning." + (declare (dom:element node)) + (let ((node-name (get-node-name node)) + (node-ns (dom:namespace-uri node))) + (when (string= node-ns *rdf-ns*) + (when (or (string= node-name "type") + (string= node-name "first") + (string= node-name "rest") + (string= node-name "subject") + (string= node-name "predicate") + (string= node-name "object")) + (error "From parse-node-name(): rdf:~a is a property and not allowed here!" + node-name)) + (when (string= node-name "RDF") + (error "From parse-node-name(): rdf:RDF not allowed here!")) + (unless (or (string= node-name "Description") + (string= node-name "List") + (string= node-name "Alt") + (string= node-name "Bag") + (string= node-name "Seq") + (string= node-name "Statement") + (string= node-name "Property") + (string= node-name "XMLLiteral")) + (format t "From parse-node-name(): Warning: ~a is not a known rdf:type!~%" + node-name))) + (when (string= node-ns *rdfs-ns*) + (when (or (string= node-name "subClassOf") + (string= node-name "subPropertyOf") + (string= node-name "domain") + (string= node-name "range") + (string= node-name "label") + (string= node-name "comment") + (string= node-name "member") + (string= node-name "seeAlso") + (string= node-name "isDefinedBy")) + (error "From parse-node-name(): rdfs:~a is a property and not allowed here!" + node-name)) + (unless (and (string= node-name "Resource") + (string= node-name "Literal") + (string= node-name "Class") + (string= node-name "Datatype") + (string= node-name "Cotnainer") + (string= node-name "ContainerMembershipProperty")) + (format t "From parse-node-name(): Warning: rdfs:~a is not a known rdfs:type!~%" + node-name)))) + t) + + +(defun parse-node(node) + "Parses a node that represents a rdf-resource." + (declare (dom:element node)) + (parse-node-name node) + (let ((ID (get-ns-attribute node "ID")) + (nodeID (get-ns-attribute node "nodeID")) + (about (get-ns-attribute node "about")) + (err-pref "From parse-node(): ")) + (when (and about nodeID) + (error "~ardf:about and rdf:nodeID are not allowed in parallel use: (~a) (~a)!" + err-pref about nodeID)) + (when (and ID + (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) + (dom:set-attribute-ns node *rdf2tm-ns* "UUID" (get-uuid))) + (handler-case (let ((content (child-nodes-or-text node :trim t))) + (when (stringp content) + (error "text-content not allowed here!"))) + (condition (err) (error "~a~a" err-pref err)))) + t) + + + +(defun get-literals-of-node (node) + "Returns alist of attributes that are treated as literal nodes." + (let ((attributes nil)) + (dom:map-node-map + #'(lambda(attr) + (let ((attr-ns (dom:namespace-uri attr)) + (attr-name (get-node-name attr))) + (cond + ((string= attr-ns *rdf-ns*) + (unless (or (string= attr-name "ID") + (string= attr-name "about") + (string= attr-name "nodeID") + (string= attr-name "type")) + (push (list :type (concatenate-uri attr-ns attr-name) + :value (get-ns-attribute node attr-name)) + attributes))) + ((or (string= attr-ns *xml-ns*) + (string= attr-ns *xmlns-ns*)) + nil);;do nothing, all xml-attributes are no literals + ((string= attr-ns *rdfs-ns*) + (if (or (string= attr-name "subClassOf") + (string= attr-name "Class")) + (error "From get-literals-of-node(): rdfs:~a is not allowed here" + attr-name) + (push (list :type (concatenate-uri attr-ns attr-name) + :value (get-ns-attribute node attr-name + :ns-uri attr-ns)) + attributes))) + (t + (push (list :type (concatenate-uri attr-ns attr-name) + :value (get-ns-attribute node attr-name + :ns-uri attr-ns)) + attributes))))) + (dom:attributes node)) + attributes)) \ No newline at end of file
Modified: trunk/src/xml/xtm/tools.lisp ============================================================================== --- trunk/src/xml/xtm/tools.lisp (original) +++ trunk/src/xml/xtm/tools.lisp Mon Jul 27 10:31:40 2009 @@ -9,6 +9,10 @@
(defpackage :xml-tools (:use :cl :cxml) + (:import-from :constants + *xml-ns* + *xmlns-ns* + *rdf-ns*) (:export :get-attribute :xpath-fn-string :xpath-child-elems-by-qname @@ -100,7 +104,7 @@ its value as a string." (declare (dom:element elem)) (let ((new-lang - (get-ns-attribute elem *xml-ns* "lang"))) + (get-ns-attribute elem "lang" :ns-uri *xml-ns*))) (if (dom:has-attribute-ns elem *xml-ns* "lang") new-lang old-lang))) @@ -112,10 +116,10 @@ (declare (dom:element elem)) (let ((new-base (let ((inner-base - (if (find ## (get-ns-attribute elem *xml-ns* "base")) + (if (find ## (get-ns-attribute elem "base" :ns-uri *xml-ns*)) (error "From get-xml-base(): the base-uri ~a is not valid" (get-ns-attribute elem *xml-ns* "base")) - (get-ns-attribute elem *xml-ns* "base")))) + (get-ns-attribute elem "base" :ns-uri *xml-ns*)))) (if (and (> (length inner-base) 0) (eql (elt inner-base 0) #/)) (subseq inner-base 1 (length inner-base)) @@ -300,7 +304,7 @@ ;;(defvar top (elt *topic-list* 501)) ;;(defvar scopes (xpath-select-location-path top '((*xtm-ns* "baseName") (*xtm-ns* "scope"))))
-(defun get-ns-attribute (elem ns-uri name) +(defun get-ns-attribute (elem name &key (ns-uri *rdf-ns*)) "Returns athe attributes value. If the value is a string of the length 0, the return value is nil" (declare (dom:element elem))