Author: lgiessmann Date: Fri Nov 19 07:22:30 2010 New Revision: 343
Log: TM-SPARQL: addded the parsing of variables in the SELECT statement; added some unit-tests
Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_parser.lisp trunk/src/base-tools/base-tools.lisp trunk/src/model/exceptions.lisp trunk/src/unit_tests/sparql_test.lisp
Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Fri Nov 19 07:22:30 2010 @@ -24,17 +24,17 @@ :type String :initform (error (make-condition - 'missing-query-string-error + 'missing-argument-error :message "From TM-Query(): original-query must be set")) :documentation "Containst the original received querry as string") - (prefix-list :initarg :prefix-list - :accessor prefix-list ;this value is only for internal purposes - ;purposes and mustn't be reset - :type List - :initform nil - :documentation "A list of the form - ((:label 'id' :value 'prefix'))") - (base-value :initarg :base-value ;initialy the requester's address + (prefixes :initarg :prefixes + :accessor prefixes ;this value is only for internal purposes + ;purposes and mustn't be reset + :type List + :initform nil + :documentation "A list of the form + ((:label 'id' :value 'prefix'))") + (base-value :initarg :base ;initialy the requester's address :accessor base-value ;this value is only for internal purposes ;purposes and mustn't be reset :type String @@ -44,7 +44,8 @@ :accessor variables ;this value is only for internal purposes ;purposes and mustn't be reset :type List - :documentation "A list of the form ((:variable var-symbol + :initform nil + :documentation "A list of the form ((:variable var-name :value value-object)), that contains tuples for each variable and its result.") (select-statements :initarg :select-statements @@ -52,6 +53,7 @@ ;internal purposes purposes ;and mustn't be reset :type List + :initform nil :documentation "A list of the form ((:statement 'statement' :value value-object))")))
@@ -64,15 +66,30 @@ (let ((existing-tuple (find-if #'(lambda(x) (string= (getf x :label) prefix-label)) - (prefix-list construct)))) + (prefixes construct)))) (if existing-tuple (setf (getf existing-tuple :value) prefix-value) (push (list :label prefix-label :value prefix-value) - (prefix-list construct)))))) - + (prefixes construct)))))) + + +(defgeneric add-variable (construct variable-name variable-value) + (:documentation "Adds a new variable-name with its value to the aexisting list. + If a variable-already exists the existing entry will be + overwritten. An entry is of the form + (:variable string :value any-type).") + (:method ((construct SPARQL-Query) (variable-name String) variable-value) + (let ((existing-tuple + (find-if #'(lambda(x) + (string= (getf x :variable) variable-name)) + (variables construct)))) + (if existing-tuple + (setf (getf existing-tuple :value) variable-value) + (push (list :variable variable-name :value variable-value) + (variables construct))))))
(defmethod initialize-instance :after ((construct SPARQL-Query) &rest args) (declare (ignorable args)) (parser-start construct (original-query construct)) - construct) + construct) \ No newline at end of file
Modified: trunk/src/TM-SPARQL/sparql_parser.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_parser.lisp (original) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Fri Nov 19 07:22:30 2010 @@ -14,9 +14,11 @@ "Creates a spqrql-parser-error object." (declare (String rest-of-query entire-query expected)) (let ((message - (format nil "The query:~%~a bad token on position ~a. Expected: ~a" + (format nil "The query:~%"~a"~%~%has a bad token at position ~a => ~a.~%Expected: ~a" entire-query (- (length entire-query) (length rest-of-query)) + (subseq entire-query (- (length entire-query) + (length rest-of-query))) expected))) (make-condition 'sparql-parser-error :message message)))
@@ -26,14 +28,17 @@ (:method ((construct SPARQL-Query) (query-string String)) (let ((trimmed-query-string (trim-whitespace-left query-string))) (cond ((string-starts-with trimmed-query-string "SELECT") - nil) ;;TODO: implement + (parse-select + construct (string-after trimmed-query-string "SELECT"))) ((string-starts-with trimmed-query-string "PREFIX") - (parse-prefixes construct - (string-after trimmed-query-string "PREFIX"))) + (parse-prefixes + construct (string-after trimmed-query-string "PREFIX"))) ((string-starts-with trimmed-query-string "BASE") (parse-base construct (string-after trimmed-query-string "BASE") #'parser-start)) - ((= (length trimmed-query-string) 0) ;TODO: remove, only for debugging purposes + ((= (length trimmed-query-string) 0) + ;; If there is only a BASE and/or PREFIX statement return an + ;; query-object with the result nil construct) (t (error (make-sparql-parser-condition @@ -41,6 +46,71 @@ "SELECT, PREFIX or BASE")))))))
+(defgeneric parse-select (construct query-string) + (:documentation "The entry-point of the parsing of the select - where + statement.") + (:method ((construct SPARQL-Query) (query-string String)) + (let* ((trimmed-str (trim-whitespace-left query-string)) + (next-query (if (string-starts-with trimmed-str "WHERE") + trimmed-str + (parse-variables construct trimmed-str)))) + (unless (string-starts-with next-query "WHERE") + (error (make-sparql-parser-condition + next-query (original-query construct) "WHERE"))) + (let* ((tripples (string-after next-query "WHERE")) + (query-tail (parse-where construct tripples))) + (or query-tail) ;TODO: process tail-of query, e.g. order by, ... + construct)))) + + +(defgeneric parse-where (construct query-string) + (:documentation "The entry-point for the parsing of the WHERE statement.") + (:method ((construct SPARQL-Query) (query-string String)) + )) + + +(defgeneric parse-variables (construct query-string) + (:documentation "Parses the variables of the SELECT statement + and adds them to the passed construct.") + (:method ((construct SPARQL-Query) (query-string String)) + (let ((trimmed-str (trim-whitespace-left query-string))) + (if (string-starts-with trimmed-str "WHERE") + trimmed-str + (let ((result (parse-variable-name trimmed-str construct))) + (add-variable construct (getf result :value) nil) + (parse-variables construct (getf result :next-query))))))) + + +(defun parse-variable-name (query-string query-object) + "A helper function that parses the first non-whitespace character + in the query. since it must be a variable, it must be prefixed + by a ? or $. The return value is of the form + (:next-query string :value string)." + (declare (String query-string) + (SPARQL-Query query-object)) + (let ((trimmed-str (trim-whitespace-left query-string)) + (delimiters (list " " "?" "$" (string #\newline) (string #\tab)))) + (unless (or (string-starts-with trimmed-str "?") + (string-starts-with trimmed-str "$")) + (make-sparql-parser-condition + trimmed-str (original-query query-object) "? or $")) + (let* ((var-name-end (search-first delimiters (subseq trimmed-str 1))) + (var-name + (if var-name-end + (subseq trimmed-str 0 (+ 1 var-name-end)) + (error (make-sparql-parser-condition + trimmed-str (original-query query-object) + "space, newline, tab, ?, $ or WHERE")))) + (next-query (string-after trimmed-str var-name)) + (normalized-var-name + (if (<= (length var-name) 1) + (error (make-sparql-parser-condition + next-query (original-query query-object) + "a variable name")) + (subseq var-name 1)))) + (list :next-query next-query :value normalized-var-name)))) + + (defgeneric parse-base (construct query-string next-fun) (:documentation "Parses the Base statment and sets the corresponding attribute in the query-construct. Since the BASE statement @@ -48,7 +118,7 @@ call function that calls the next transitions and states.") (:method ((construct SPARQL-Query) (query-string String) (next-fun Function)) (let* ((trimmed-str (trim-whitespace-left query-string)) - (result (parse-bracketed-value trimmed-str construct))) + (result (parse-closed-value trimmed-str construct))) (setf (base-value construct) (getf result :value)) (funcall next-fun construct (getf result :next-query)))))
@@ -59,14 +129,14 @@ (let ((trimmed-string (trim-whitespace-left query-string))) (if (string-starts-with trimmed-string ":") (let ((results - (parse-bracketed-value (subseq trimmed-string 1) construct))) + (parse-closed-value (subseq trimmed-string 1) construct))) (add-prefix construct *empty-label* (getf results :value)) (parser-start construct (getf results :next-query))) (let* ((label-name (trim-whitespace-right (string-until trimmed-string ":"))) (next-query-str (trim-whitespace-left (string-after trimmed-string ":"))) - (results (parse-bracketed-value next-query-str construct))) + (results (parse-closed-value next-query-str construct))) (when (string= label-name trimmed-string) (error (make-sparql-parser-condition trimmed-string (original-query construct) ":"))) @@ -74,7 +144,7 @@ (parser-start construct (getf results :next-query)))))))
-(defun parse-bracketed-value(query-string query-object &key (open "<") (close ">")) +(defun parse-closed-value(query-string query-object &key (open "<") (close ">")) "A helper function that checks the value of a statement within two brackets, i.e. <prefix-value>. A list of the form (:next-query string :value string) is returned."
Modified: trunk/src/base-tools/base-tools.lisp ============================================================================== --- trunk/src/base-tools/base-tools.lisp (original) +++ trunk/src/base-tools/base-tools.lisp Fri Nov 19 07:22:30 2010 @@ -20,7 +20,8 @@ :string-starts-with :string-starts-with-char :string-until - :string-after)) + :string-after + :search-first))
(in-package :base-tools)
@@ -108,4 +109,18 @@ (let ((pos (search prefix str))) (if pos (subseq str (+ pos (length prefix))) - nil))) \ No newline at end of file + nil))) + + +(defun search-first (search-strings main-string) + "Returns the position of one of the search-strings. The returned position + is the one closest to 0. If no search-string is found, nil is returned." + (declare (String main-string) + (List search-strings)) + (let ((positions + (remove-null (map 'list #'(lambda(search-str) + (search search-str main-string)) + search-strings)))) + (let ((sorted-positions (sort positions #'<))) + (when sorted-positions + (first sorted-positions))))) \ No newline at end of file
Modified: trunk/src/model/exceptions.lisp ============================================================================== --- trunk/src/model/exceptions.lisp (original) +++ trunk/src/model/exceptions.lisp Fri Nov 19 07:22:30 2010 @@ -18,18 +18,11 @@ :missing-argument-error :tm-reference-error :bad-type-error - :missing-query-string-error :sparql-parser-error))
(in-package :exceptions)
-(define-condition missing-query-string-error(error) - ((message - :initarg :message - :accessor message))) - - (define-condition sparql-parser-error(error) ((message :initarg :message
Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Fri Nov 19 07:22:30 2010 @@ -10,26 +10,138 @@ (defpackage :sparql-test (:use :cl :it.bese.FiveAM - :TM-SPARQL) + :TM-SPARQL + :exceptions) (:export :run-sparql-tests - :sparql-tests)) + :sparql-tests + :test-prefix-and-base))
(in-package :sparql-test)
-(def-suite sparql-test +(def-suite sparql-tests :description "tests various key functions of the TM-SPARQL module")
-(in-suite sparql-test) +(in-suite sparql-tests)
-;TODO: prefix tests -;PREFIX foaf : http://xmlns.com/foaf/0.1/ -;PREFIX org: http://example.com/ns# -;PREFIX isi:http://isidor.us -;PREFIX :http://some.where -;PREFIX foaf : http://overwrite.foaf" +(test test-prefix-and-base + "Tests the sparql parser when parsing PREFIX and BASE statements." + (let* ((query-1 "PREFIX foaf : http://xmlns.com/foaf/0.1/ + PREFIX org: http://example.com/ns# + PREFIX isi:http://isidor.us + PREFIX :http://some.where + BASE http://base.one + PREFIX foaf : http://overwrite.foaf + BASEhttp://base.two") + (query-2 "PREFIX foaf : http://xmlns.com/foaf/0.1/ + PREFIX org: +http://example.com/ns# + PREFIX isi:http://isidor.us + PREFIX +:http://some.where + BASE http://base.one + PREFIX foaf : http://overwrite.foaf + BASEhttp://base.two") + (query-object-1 (make-instance 'SPARQL-Query :query query-1)) + (query-object-2 (make-instance 'SPARQL-Query :query query-2 + :base "http://any-base"))) + (signals missing-argument-error (make-instance 'SPARQL-Query)) + (is-true query-object-1) + (is-true query-object-2) + (is (string= (TM-SPARQL::base-value query-object-1) "http://base.two")) + (is (string= (TM-SPARQL::base-value query-object-2) "http://base.two")) + (is (= (length (TM-SPARQL::prefixes query-object-1)) 4)) + (is (= (length (TM-SPARQL::prefixes query-object-2)) 4)) + (is-true (find-if #'(lambda(elem) + (and (string= (getf elem :label) "foaf") + (string= (getf elem :value) + "http://overwrite.foaf"))) + (TM-SPARQL::prefixes query-object-1))) + (is-true (find-if #'(lambda(elem) + (and (string= (getf elem :label) "org") + (string= (getf elem :value) + "http://example.com/ns#"))) + (TM-SPARQL::prefixes query-object-1))) + (is-true (find-if #'(lambda(elem) + (and (string= (getf elem :label) "isi") + (string= (getf elem :value) + "http://isidor.us"))) + (TM-SPARQL::prefixes query-object-1))) + (is-true (find-if #'(lambda(elem) + (and (string= (getf elem :label) + TM-SPARQL::*empty-label*) + (string= (getf elem :value) + "http://some.where"))) + (TM-SPARQL::prefixes query-object-1))) + (is-true (find-if #'(lambda(elem) + (and (string= (getf elem :label) "foaf") + (string= (getf elem :value) + "http://overwrite.foaf"))) + (TM-SPARQL::prefixes query-object-2))) + (is-true (find-if #'(lambda(elem) + (and (string= (getf elem :label) "org") + (string= (getf elem :value) + "http://example.com/ns#"))) + (TM-SPARQL::prefixes query-object-2))) + (is-true (find-if #'(lambda(elem) + (and (string= (getf elem :label) "isi") + (string= (getf elem :value) + "http://isidor.us"))) + (TM-SPARQL::prefixes query-object-2))) + (is-true (find-if #'(lambda(elem) + (and (string= (getf elem :label) + TM-SPARQL::*empty-label*) + (string= (getf elem :value) + "http://some.where"))) + (TM-SPARQL::prefixes query-object-2))))) + + +(test test-variable-names + "Tests the sparql parser when parsing variables in the SELECT statement." + (let* ((query-1 "PREFIX foaf : http://xmlns.com/foaf/0.1/ + PREFIX org: http://example.com/ns# + PREFIX isi:http://isidor.us + PREFIX :http://some.where + BASE http://base.one + PREFIX foaf : http://overwrite.foaf + BASEhttp://base.two + SELECT ?var1$var2 +$var3 ?var3 WHERE{}") + (query-2 "SELECT ?var1$var2 $var3 ?var3 WHERE{}") + (query-3 "SELECT ?var1$var2 $var3 ?var3WHERE{}") + (query-object-1 (make-instance 'SPARQL-Query :query query-1)) + (query-object-2 (make-instance 'SPARQL-Query :query query-2))) + (is-true query-object-1) + (is-true query-object-2) + (signals sparql-parser-error (make-instance 'SPARQL-Query :query query-3)) + (is (= (length (TM-SPARQL::variables query-object-1)) 3)) + (is-true (find-if #'(lambda(elem) + (and (string= (getf elem :variable) "var1") + (null (getf elem :value)))) + (TM-SPARQL::variables query-object-1))) + (is-true (find-if #'(lambda(elem) + (and (string= (getf elem :variable) "var2") + (null (getf elem :value)))) + (TM-SPARQL::variables query-object-1))) + (is-true (find-if #'(lambda(elem) + (and (string= (getf elem :variable) "var3") + (null (getf elem :value)))) + (TM-SPARQL::variables query-object-1))) + (is (= (length (TM-SPARQL::variables query-object-2)) 3)) + (is-true (find-if #'(lambda(elem) + (and (string= (getf elem :variable) "var1") + (null (getf elem :value)))) + (TM-SPARQL::variables query-object-2))) + (is-true (find-if #'(lambda(elem) + (and (string= (getf elem :variable) "var2") + (null (getf elem :value)))) + (TM-SPARQL::variables query-object-2))) + (is-true (find-if #'(lambda(elem) + (and (string= (getf elem :variable) "var3") + (null (getf elem :value)))) + (TM-SPARQL::variables query-object-2)))))
(defun run-sparql-tests ()