[isidorus-cvs] r343 - in trunk/src: TM-SPARQL base-tools model unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Fri Nov 19 12:22:31 UTC 2010
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>
+ BASE<http://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>
+ BASE<http://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>
+ BASE<http://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 ()
More information about the Isidorus-cvs
mailing list