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