[isidorus-cvs] r96 - in trunk/src: . unit_tests xml/rdf xml/xtm
Lukas Giessmann
lgiessmann at common-lisp.net
Mon Jul 27 14:31:40 UTC 2009
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#\" "
+ "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/\" "
+ "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))
More information about the Isidorus-cvs
mailing list