[isidorus-cvs] r374 - in trunk/src: TM-SPARQL base-tools unit_tests
Lukas Giessmann
lgiessmann at common-lisp.net
Sat Dec 18 10:45:40 UTC 2010
Author: lgiessmann
Date: Sat Dec 18 05:45:40 2010
New Revision: 374
Log:
TM-SPARQL: added the handling of supported filter function => added unit-tests => fixed several bug with white space characters
Modified:
trunk/src/TM-SPARQL/sparql_filter.lisp
trunk/src/base-tools/base-tools.lisp
trunk/src/unit_tests/sparql_test.lisp
Modified: trunk/src/TM-SPARQL/sparql_filter.lisp
==============================================================================
--- trunk/src/TM-SPARQL/sparql_filter.lisp (original)
+++ trunk/src/TM-SPARQL/sparql_filter.lisp Sat Dec 18 05:45:40 2010
@@ -102,39 +102,89 @@
(filter-string-arithmetic-ops
(set-arithmetic-operators construct filter-string-or-and-ops))
(filter-string-compare-ops
- (set-compare-operators construct filter-string-arithmetic-ops)))
- filter-string-compare-ops)))
+ (set-compare-operators construct filter-string-arithmetic-ops))
+ (filter-string-functions
+ (set-functions construct filter-string-compare-ops)))
+ filter-string-functions)))
;;TODO: implement
- ;; **replace () by (progn )
- ;; **replace ', """, ''' by "
- ;; **replace !x by (not x)
- ;; **replace +x by (one+ x)
- ;; **replace -x by (one- x)
- ;; **||, &&
- ;; **, /
- ;; **+, -
- ;; **=, !=, <, >, <=, >=
- ;; *replace function(x), function(x, y), function(x, y, z)
- ;; by filter-function(x), (filter-function(x, y), filter-function(x, y, z)
;; *check if all functions that will be invoked are allowed
- ;; *embrace the final result uris in <> => unit-tests
+ ;; *implement wrapper functions, also for the operators
+ ;; it would be nice of the self defined operator functions would be in a
+ ;; separate packet, e.g. filter-functions, so =, ... would couse no
+ ;; collisions
+ ;; *embrace the final results uris in <> => unit-tests
;; *create and store this filter object => store the created string and implement
;; a method "invoke-filter(SPARQL-Triple filter-string)" so that the variables
;; are automatically contained in a letafterwards the eval function can be called
;; this method should also have a let with (true t) and (false nil)
-(defvar *tmp* 0)
+(defgeneric set-functions (construct filter-string)
+ (:documentation "Transforms all supported functions of the form
+ function(x, y) to (function x y).")
+ (:method ((construct SPARQL-Query) (filter-string String))
+ (let ((op-pos (find-functions filter-string)))
+ (if (not op-pos)
+ filter-string
+ (let* ((fun-name
+ (return-if-starts-with (subseq filter-string op-pos)
+ *supported-functions*))
+ (left-str (subseq filter-string 0 op-pos))
+ (right-str (subseq filter-string
+ (+ op-pos (length fun-name))))
+ (cleaned-right-str (trim-whitespace-left right-str))
+ (arg-list (bracket-scope cleaned-right-str))
+ (cleaned-arg-list (clean-function-arguments arg-list))
+ (modified-str
+ (concatenate
+ 'string left-str "(" fun-name " " cleaned-arg-list ")"
+ (subseq right-str (+ (- (length right-str)
+ (length cleaned-right-str))
+ (length arg-list))))))
+ (set-functions construct modified-str))))))
+
+
+(defun clean-function-arguments (argument-string)
+ "Transforms all arguments within an argument list of the form
+ (x, y, z, ...) to x y z."
+ (declare (String argument-string))
+ (when (and (string-starts-with argument-string "(")
+ (string-ends-with argument-string ")"))
+ (let ((local-str (subseq argument-string 1 (1- (length argument-string))))
+ (result ""))
+ (dotimes (idx (length local-str) result)
+ (let ((current-char (subseq local-str idx (1+ idx))))
+ (if (and (string= current-char ",")
+ (not (in-literal-string-p local-str idx)))
+ (push-string " " result)
+ (push-string current-char result)))))))
+
+
+(defun find-functions (filter-string)
+ "Returns the idx of the first found 'BOUND', 'isLITERAL', 'STR',
+ 'DATATYPE', or 'REGEX'.
+ It must not be in a literal string or directly after a (."
+ (declare (String filter-string))
+ (let* ((first-pos
+ (search-first-ignore-literals *supported-functions*
+ filter-string)))
+ (when first-pos
+ (let ((left-part (trim-whitespace-right (subseq filter-string 0 first-pos))))
+ (if (not (string-ends-with left-part "("))
+ first-pos
+ (let ((next-pos
+ (find-functions (subseq filter-string (1+ first-pos)))))
+ (when next-pos
+ (+ 1 first-pos next-pos))))))))
+
+
(defgeneric set-compare-operators (construct filter-string)
(:documentation "Transforms the =, !=, <, >, <= and >= operators in the
filter string to the the corresponding lisp functions.")
(:method ((construct SPARQL-Query) (filter-string String))
- (incf *tmp*)
(let ((op-pos (find-compare-operators filter-string)))
- (if (or (not op-pos) (= *tmp* 5))
- (progn
- (setf *tmp* 0)
- filter-string)
+ (if (not op-pos)
+ filter-string
(let* ((op-str (if (string-starts-with-one-of
(subseq filter-string op-pos)
(*2-compare-operators*))
@@ -335,8 +385,8 @@
string to the the corresponding lisp functions.")
(:method ((construct SPARQL-Query) (filter-string String))
(let ((op-pos (find-+--operators filter-string)))
- (if (or (not op-pos) (= *tmp* 5))
- filter-string
+ (if (not op-pos)
+ filter-string
(let* ((op-str (subseq filter-string op-pos (1+ op-pos)))
(left-str (subseq filter-string 0 op-pos))
(right-str (subseq filter-string (1+ op-pos)))
@@ -438,7 +488,7 @@
filter-string
(let* ((op-str (subseq filter-string op-pos (+ 2 op-pos)))
(left-str (subseq filter-string 0 op-pos))
- (right-str (subseq filter-string (+ 2 op-pos)))
+ (right-str (subseq filter-string (+ (length op-str) op-pos)))
(left-scope (find-or-and-left-scope left-str))
(right-scope (find-or-and-right-scope right-str))
(modified-str
@@ -567,8 +617,8 @@
(trim-whitespace-right (subseq filter-string 0 idx))))
(if (or (string= string-before "")
(string-ends-with string-before "(progn")
- (string-ends-with-one-of string-before
- (*supported-operators*)))
+ (string-ends-with-one-of
+ string-before (append (*supported-operators*) (list "("))))
(let ((result (unary-operator-scope filter-string idx)))
(push-string (concatenate 'string "(one" current-char " ")
result-string)
@@ -719,7 +769,7 @@
(progn
(setf idx (- (1- (length str))
(length (getf literal :next-string))))
- (push-string (getf literal :literal) str))
+ (push-string (getf literal :literal) result))
(progn
(setf result nil)
(setf idx (length str))))))
@@ -790,7 +840,13 @@
(error (make-sparql-parser-condition
(subseq query-string idx)
(original-query construct)
- "a valid filter, but the filter is not complete")))
+ (format nil
+ "a valid filter, but the filter is not complete, ~a"
+ (if (> open-brackets 0)
+ (format nil "~a ')' is missing"
+ open-brackets)
+ (format nil "~a '(' is missing"
+ open-brackets))))))
(setf result
(list :next-query (subseq query-string idx)
:filter-string filter-string)))
@@ -804,7 +860,7 @@
represents a (progn) block."
(declare (String query-string)
(Integer idx))
- (let* ((delimiters (append (list " " (string #\Space) (string #\Tab)
+ (let* ((delimiters (append (list " " "," (string #\Space) (string #\Tab)
(string #\Newline) (string #\cr) "(" ")")
(*supported-operators*)))
(string-before (trim-whitespace-right (subseq query-string 0 idx)))
@@ -813,8 +869,9 @@
(fragment-before
(if (and (not fragment-before-idx)
(and (> (length string-before) 0)
- (not (find string-before *supported-functions*
- :test #'string=))))
+ (not (string-ends-with-one-of
+ (trim-whitespace-right string-before)
+ *supported-functions*))))
(error (make-condition
'SPARQL-PARSER-ERROR
:message (format nil "Invalid filter: \"~a\"~%"
@@ -838,16 +895,15 @@
'SPARQL-PARSER-ERROR
:message (format nil "Invalid filter: found \"~a\" but expected ~a"
fragment-before *supported-functions*))))
- (when (not (find fragment-before (append *supported-functions*
- delimiters)
- :test #'string=))
+ (when (not (string-starts-with-one-of
+ fragment-before (append *supported-functions* delimiters)))
(error
(make-condition
'SPARQL-PARSER-ERROR
:message
(format nil "Invalid character: \"~a\", expected characters: ~a"
fragment-before (append *supported-functions* delimiters)))))
- (if (find fragment-before *supported-functions* :test #'string=)
+ (if (string-ends-with-one-of fragment-before *supported-functions*)
nil
t))
(if (find string-before *supported-functions* :test #'string=)
Modified: trunk/src/base-tools/base-tools.lisp
==============================================================================
--- trunk/src/base-tools/base-tools.lisp (original)
+++ trunk/src/base-tools/base-tools.lisp Sat Dec 18 05:45:40 2010
@@ -40,7 +40,8 @@
:in-literal-string-p
:find-literal-end
:get-literal-quotation
- :get-literal))
+ :get-literal
+ :return-if-starts-with))
(in-package :base-tools)
@@ -506,4 +507,17 @@
(when (> closed-brackets 0)
(setf result-idx idx)
(setf idx (length str))))))))
- result-idx))
\ No newline at end of file
+ result-idx))
+
+
+(defun return-if-starts-with (str to-be-matched &key from-end ignore-case)
+ "Returns the string that is contained in to-be-matched and that is the
+ start of the string str."
+ (declare (String str)
+ (List to-be-matched)
+ (Boolean from-end ignore-case))
+ (loop for try in to-be-matched
+ when (if from-end
+ (string-ends-with str try :ignore-case ignore-case)
+ (string-starts-with str try :ignore-case ignore-case))
+ return try))
\ No newline at end of file
Modified: trunk/src/unit_tests/sparql_test.lisp
==============================================================================
--- trunk/src/unit_tests/sparql_test.lisp (original)
+++ trunk/src/unit_tests/sparql_test.lisp Sat Dec 18 05:45:40 2010
@@ -36,7 +36,8 @@
:test-set-or-and-operators
:test-set-*-and-/-operators
:test-set-+-and---operators
- :test-set-compare-operators))
+ :test-set-compare-operators
+ :test-set-functions))
(in-package :sparql-test)
@@ -1236,7 +1237,7 @@
(test test-set-+-and---operators
- "Tests various cases of the function set-*-and-/-operators."
+ "Tests various cases of the function set-+-and---operators."
(let* ((dummy-object (make-instance 'TM-SPARQL::SPARQL-Query :query " "))
(str-1 "x = a + b * c && y = a / 3 + b * 2 || 0 = 12 - 14 + 2 * 3 / 3}")
(str-2 "x = 2 && (2 + 2) * 2 + 12 * 4 / 2 - 10 + 2 * (12 - 3) + (12 * 3)}")
@@ -1319,7 +1320,7 @@
(test test-set-compare-operators
- "Tests various cases of the function set-*-and-/-operators."
+ "Tests various cases of the function set-compare-operators."
(let* ((dummy-object (make-instance 'TM-SPARQL::SPARQL-Query :query " "))
(str-1 "x = a + b * c && y = a / 3 + b * 2 || 0 = 12 - 14 + 2 * 3 / 3}")
(str-2 "x = 2 && (2 + 2) * 2 + 12 * 4 / 2 - 10 + 2 * (12 - 3) + (12 * 3)}")
@@ -1429,6 +1430,104 @@
"(or(progn(progn(>=(+12)3)))(progn(=(progn(+(+(progn(-24))5)6))3)))"))
(is (string= (string-replace result-6-5 " " "")
"(or(progn(!=(<=(>21)0)99))(progntrue))"))))
+
+
+(test test-set-functions
+ "Tests various cases of the function set-functions"
+ (let* ((dummy-object (make-instance 'TM-SPARQL::SPARQL-Query :query " "))
+ (str-1 "BOUND(( (?var) )) || (isLITERAL($var) && ?var = 'abc')}")
+ (str-2
+ "(REGEX(?var1, '''''', ?var3) || (?var1 > ?var3 && (STR( ?var) = \"abc\")))}")
+ (str-3
+ "STR(DATATYPE(?var3,isLITERAL(x, y))) || +?var1 = -?var2 + ?var2 * ?var3}")
+ (str-4 "DATATYPE(?var3) ||isLITERAL(+?var1 = -?var2)}")
+ (str-5 "DATATYPE(?var3) ||(isLITERAL (+?var1 = -?var2))}")
+ (result-1
+ (getf (tm-sparql::set-boundings dummy-object str-1) :filter-string))
+ (result-1-2
+ (tm-sparql::set-or-and-operators dummy-object result-1 result-1))
+ (result-1-3
+ (tm-sparql::set-*-and-/-operators dummy-object result-1-2))
+ (result-1-4
+ (tm-sparql::set-+-and---operators dummy-object result-1-3))
+ (result-1-5
+ (tm-sparql::set-compare-operators dummy-object result-1-4))
+ (result-1-6
+ (tm-sparql::set-functions dummy-object result-1-5))
+ (result-2
+ (getf (tm-sparql::set-boundings dummy-object str-2) :filter-string))
+ (result-2-2
+ (tm-sparql::set-or-and-operators dummy-object result-2 result-2))
+ (result-2-3
+ (tm-sparql::set-*-and-/-operators dummy-object result-2-2))
+ (result-2-4
+ (tm-sparql::set-+-and---operators dummy-object result-2-3))
+ (result-2-5
+ (tm-sparql::set-compare-operators dummy-object result-2-4))
+ (result-2-6
+ (tm-sparql::set-functions dummy-object result-2-5))
+ (result-3
+ (getf (tm-sparql::set-boundings dummy-object str-3) :filter-string))
+ (result-3-2-1
+ (tm-sparql::set-unary-operators dummy-object result-3))
+ (result-3-2
+ (tm-sparql::set-or-and-operators dummy-object result-3-2-1 result-3))
+ (result-3-3
+ (tm-sparql::set-*-and-/-operators dummy-object result-3-2))
+ (result-3-4
+ (tm-sparql::set-+-and---operators dummy-object result-3-3))
+ (result-3-5
+ (tm-sparql::set-compare-operators dummy-object result-3-4))
+ (result-3-6
+ (tm-sparql::set-functions dummy-object result-3-5))
+ (result-4
+ (getf (tm-sparql::set-boundings dummy-object str-4) :filter-string))
+ (result-4-2-1
+ (tm-sparql::set-unary-operators dummy-object result-4))
+ (result-4-2
+ (tm-sparql::set-or-and-operators dummy-object result-4-2-1 result-4-2-1))
+ (result-4-3
+ (tm-sparql::set-*-and-/-operators dummy-object result-4-2))
+ (result-4-4
+ (tm-sparql::set-+-and---operators dummy-object result-4-3))
+ (result-4-5
+ (tm-sparql::set-compare-operators dummy-object result-4-4))
+ (result-4-6
+ (tm-sparql::set-functions dummy-object result-4-5))
+ (result-5
+ (getf (tm-sparql::set-boundings dummy-object str-5) :filter-string))
+ (result-5-2-1
+ (tm-sparql::set-unary-operators dummy-object result-5))
+ (result-5-2
+ (tm-sparql::set-or-and-operators dummy-object result-5-2-1 result-5-2-1))
+ (result-5-3
+ (tm-sparql::set-*-and-/-operators dummy-object result-5-2))
+ (result-5-4
+ (tm-sparql::set-+-and---operators dummy-object result-5-3))
+ (result-5-5
+ (tm-sparql::set-compare-operators dummy-object result-5-4))
+ (result-5-6
+ (tm-sparql::set-functions dummy-object result-5-5)))
+ (is-true result-1) (is-true result-1-2) (is-true result-1-3)
+ (is-true result-1-4) (is-true result-1-5) (is-true result-1-6)
+ (is-true result-2) (is-true result-2-2) (is-true result-2-3)
+ (is-true result-2-4) (is-true result-2-5) (is-true result-2-6)
+ (is-true result-3) (is-true result-3-2) (is-true result-3-3)
+ (is-true result-3-4) (is-true result-3-5) (is-true result-3-6)
+ (is-true result-4) (is-true result-4-2) (is-true result-4-3)
+ (is-true result-4-4) (is-true result-4-5) (is-true result-4-6)
+ (is-true result-5) (is-true result-5-2) (is-true result-5-3)
+ (is-true result-5-4) (is-true result-5-5) (is-true result-5-6)
+ (is (string= (string-replace result-1-6 " " "")
+ "(or(progn(BOUND(progn(progn?var))))(progn(progn(and(progn(isLITERAL$var))(progn(=?var\"abc\"))))))"))
+ (is (string= (string-replace result-2-6 " " "")
+ "(progn(or(progn(REGEX?var1\"\"?var3))(progn(progn(and(progn(>?var1?var3))(progn(progn(=(STR?var)\"abc\"))))))))"))
+ (is (string= (string-replace result-3-6 " " "")
+ "(or(progn(STR(DATATYPE?var3(isLITERALxy))))(progn(=(one+?var1)(+(one-?var2)(*?var2?var3)))))"))
+ (is (string= (string-replace result-4-6 " " "")
+ "(or(progn(DATATYPE?var3))(progn(isLITERAL(=(one+?var1)(one-?var2)))))"))
+ (is (string= (string-replace result-5-6 " " "")
+ "(or(progn(DATATYPE?var3))(progn(progn(isLITERAL(=(one+?var1)(one-?var2))))))"))))
More information about the Isidorus-cvs
mailing list