[isidorus-cvs] r114 - in trunk/src: unit_tests xml/xtm
Lukas Giessmann
lgiessmann at common-lisp.net
Thu Aug 13 21:19:32 UTC 2009
Author: lgiessmann
Date: Thu Aug 13 17:19:31 2009
New Revision: 114
Log:
rdf-importer: fixed a bug with xml-base
Modified:
trunk/src/unit_tests/rdf_importer_test.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 Thu Aug 13 17:19:31 2009
@@ -59,7 +59,8 @@
:test-poems-rdf-typing
:test-poems-rdf-topics
:test-empty-collection
- :test-collection))
+ :test-collection
+ :test-xml-base))
(declaim (optimize (debug 3) (speed 0) (safety 3) (space 0) (compilation-speed 0)))
@@ -1755,7 +1756,6 @@
4))
(is (= (length (d:player-in-roles fourth-node)) 1))
(is (= (length (d:player-in-roles fifth-node)) 1))
- (format t "--->")
(let ((col-2
(d:player
(find-if
@@ -2981,6 +2981,73 @@
(d:player-in-roles node))))))))
+(test test-xml-base
+ "Tests the function get-xml-base."
+ (let ((doc-1
+ (concatenate 'string "<rdf:RDF xmlns:rdf=\"" *rdf-ns* "\" "
+ "xmlns:arcs=\"http://test/arcs/\">"
+ " <rdf:Description xml:base=\"http://base-1\"/>"
+ " <rdf:Description xml:base=\"http://base-2#\"/>"
+ " <rdf:Description xml:base=\"http://base-3/\"/>"
+ "</rdf:RDF>")))
+ (let ((dom-1 (cxml:parse doc-1 (cxml-dom:make-dom-builder))))
+ (let ((rdf-node (elt (dom:child-nodes dom-1) 0)))
+ (let ((n-1 (elt (rdf-importer::child-nodes-or-text rdf-node
+ :trim t) 0))
+ (n-2 (elt (rdf-importer::child-nodes-or-text rdf-node
+ :trim t) 1))
+ (n-3 (elt (rdf-importer::child-nodes-or-text rdf-node
+ :trim t) 2)))
+ (is (string= (xml-tools::concatenate-uri
+ (xml-tools:get-xml-base n-1)
+ "test")
+ "http://base-1/test"))
+ (is (string= (xml-tools::concatenate-uri
+ (xml-tools:get-xml-base n-1)
+ "/test")
+ "http://base-1/test"))
+ (is (string= (xml-tools::concatenate-uri
+ (xml-tools:get-xml-base n-1)
+ "#test")
+ "http://base-1#test"))
+ (is (string= (xml-tools::concatenate-uri
+ (xml-tools:get-xml-base n-2)
+ "test")
+ "http://base-2#test"))
+ (is (string= (xml-tools::concatenate-uri
+ (xml-tools:get-xml-base n-2)
+ "#test")
+ "http://base-2#test"))
+ (is (string= (xml-tools::concatenate-uri
+ (xml-tools:get-xml-base n-2)
+ "/test")
+ "http://base-2/test"))
+ (is (string= (xml-tools::concatenate-uri
+ (xml-tools:get-xml-base n-2)
+ "/t/est")
+ "http://base-2/t/est"))
+ (is (string= (xml-tools::concatenate-uri
+ (xml-tools:get-xml-base n-2)
+ "t/est")
+ "http://base-2/t/est"))
+ (signals error (xml-tools::concatenate-uri
+ (xml-tools:get-xml-base n-2) ""))
+ (signals error (xml-tools::concatenate-uri
+ "" "test"))
+ (is (string= (xml-tools::concatenate-uri
+ (xml-tools:get-xml-base n-3)
+ "test")
+ "http://base-3/test"))
+ (is (string= (xml-tools::concatenate-uri
+ (xml-tools:get-xml-base n-3)
+ "#test")
+ "http://base-3/#test"))
+ (is (string= (xml-tools::concatenate-uri
+ (xml-tools:get-xml-base n-3)
+ "/test")
+ "http://base-3/test")))))))
+
+
(defun run-rdf-importer-tests()
(when elephant:*store-controller*
(elephant:close-store))
@@ -3001,4 +3068,5 @@
(it.bese.fiveam:run! 'test-poems-rdf-typing)
(it.bese.fiveam:run! 'test-poems-rdf-topics)
(it.bese.fiveam:run! 'test-empty-collection)
- (it.bese.fiveam:run! 'test-collection))
\ No newline at end of file
+ (it.bese.fiveam:run! 'test-collection)
+ (it.bese.fiveam:run! 'test-xml-base))
\ 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 Thu Aug 13 17:19:31 2009
@@ -44,27 +44,38 @@
"Returns a string conctenated of the absolut namespace an the given value
separated by either '#' or '/'."
(declare (string absolute-ns value))
- (unless (or (> (length absolute-ns) 0)
- (> (length value) 0))
+ (unless (and (> (length absolute-ns) 0)
+ (> (length value) 0))
(error "From concatenate-uri(): absolute-ns and value must be of length > 0"))
(unless (absolute-uri-p absolute-ns)
(error "From concatenate-uri(): absolute-ns has to be an absolute URI: ~a" absolute-ns))
(let ((last-char
- (elt absolute-ns (- (length absolute-ns) 1))))
+ (elt absolute-ns (- (length absolute-ns) 1)))
+ (first-char
+ (elt value 0)))
(let ((separator
(cond
- ((eql last-char #\#)
- "#")
- ((eql last-char #\/)
- "/")
+ ((or (eql first-char #\#)
+ (eql first-char #\/))
+ "")
+ ((or (eql last-char #\#)
+ (eql last-char #\/))
+ "")
(t
- "#")))
- (prep-ns
- (if (or (eql last-char #\#)
- (eql last-char #\/))
- (subseq absolute-ns 0 (- (length absolute-ns) 1))
- absolute-ns)))
- (concatenate 'string prep-ns separator value))))
+ "/"))))
+ (let ((prep-ns
+ (if (and (eql last-char first-char)
+ (or (eql last-char #\#)
+ (eql last-char #\/)))
+ (subseq absolute-ns 0 (- (length absolute-ns) 1))
+ (if (and (eql last-char #\#)
+ (find #\/ value))
+ (progn
+ (when (not (eql first-char #\/))
+ (setf separator "/"))
+ (subseq absolute-ns 0 (- (length absolute-ns) 1)))
+ absolute-ns))))
+ (concatenate 'string prep-ns separator value)))))
(defun absolutize-id (id xml-base tm-id)
@@ -142,9 +153,11 @@
(declare (dom:element elem))
(let ((new-base
(let ((inner-base
- (if (find #\# (get-ns-attribute elem "base" :ns-uri *xml-ns*))
+ (if (> (count #\# (get-ns-attribute elem "base"
+ :ns-uri *xml-ns*))
+ 1)
(error "From get-xml-base(): the base-uri ~a is not valid"
- (get-ns-attribute elem *xml-ns* "base"))
+ (get-ns-attribute elem "base" :ns-uri *xml-ns*))
(when (get-ns-attribute elem "base" :ns-uri *xml-ns*)
(string-trim '(#\Space #\Tab #\Newline)
(get-ns-attribute elem "base" :ns-uri *xml-ns*))))))
@@ -152,7 +165,6 @@
(eql (elt inner-base 0) #\/))
(subseq inner-base 1 (length inner-base))
inner-base))))
-
(if (or (absolute-uri-p new-base)
(not old-base))
new-base
More information about the Isidorus-cvs
mailing list