December 2010 - isidorus-cvs@common-lisp.net

[isidorus-cvs] r383 - in trunk/src: TM-SPARQL unit_tests
by Lukas Giessmann 21 Dec '10

21 Dec '10

Author: lgiessmann Date: Tue Dec 21 17:57:57 2010 New Revision: 383 Log: TM-SPARQL: fixed a fundamental bug => if a filter uses more than one variable from different triples => currently there is created a cross product of all variable-results in a select-group, afterwards the values that always evaluates to false are removed from the main result. Modified: trunk/src/TM-SPARQL/filter_wrappers.lisp trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_filter.lisp trunk/src/unit_tests/sparql_test.lisp Modified: trunk/src/TM-SPARQL/filter_wrappers.lisp ============================================================================== --- trunk/src/TM-SPARQL/filter_wrappers.lisp (original) +++ trunk/src/TM-SPARQL/filter_wrappers.lisp Tue Dec 21 17:57:57 2010 @@ -129,11 +129,12 @@ (defun filter-functions::regex(str pattern &optional flags) - (let* ((local-flags (filter-functions::normalize-value flags)) + (let* ((local-str (filter-functions::normalize-value str)) + (local-flags (filter-functions::normalize-value flags)) (case-insensitive (when (find #\i local-flags) t)) (multi-line (when (find #\m local-flags) t)) (single-line (when (find #\s local-flags) t)) - (local-pattern + (local-pattern (if (find #\x local-flags) (base-tools:string-replace (base-tools:string-replace @@ -148,7 +149,7 @@ :case-insensitive-mode case-insensitive :multi-line-mode multi-line :single-line-mode single-line))) - (ppcre:scan scanner str))) + (ppcre:scan scanner local-str))) (defun filter-functions::bound(x) Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Tue Dec 21 17:57:57 2010 @@ -234,12 +234,10 @@ value is nil.") (:method ((construct SPARQL-query) (string-with-prefix String)) (loop for entry in (prefixes construct) - when (string-starts-with string-with-prefix - (concatenate 'string (getf entry :label) ":")) + when (string-starts-with string-with-prefix (concat (getf entry :label) ":")) return (concatenate-uri (getf entry :value) - (string-after string-with-prefix - (concatenate 'string (getf entry :label) ":")))))) + (string-after string-with-prefix (concat (getf entry :label) ":")))))) (defgeneric add-variable (construct variable-name) @@ -252,61 +250,173 @@ (push variable-name (variables construct))))) -(defgeneric generate-let-variable-string (construct value) - (:documentation "Returns a list if the form (:string <var-string> - :variable-names (<?var-name-as-string> - <$var-name-as-string>)).") - (:method ((construct SPARQL-Triple-Elem) value) - (when (variable-p construct) - (let* ((var-value (write-to-string value)) - (var-name (value construct)) - (lisp-str - (concatenate 'string "(?" var-name " " var-value ")" - "($" var-name " " var-value ")")) - (vars - (concatenate 'string "?" var-name " $" var-name))) - (list :string lisp-str - :variable-names vars))))) - - -(defgeneric invoke-filter (construct filter-string) - (:documentation "Invokes the passed filter on the construct that - represents a sparql result.") - (:method ((construct SPARQL-Triple) (filter-string String)) - (let ((results nil)) ;a list of the form (:subject x :predicate y :object z) - (dotimes (row-idx (length (subject-result construct))) - (let* ((subj-elem - (generate-let-variable-string - (subject construct) (elt (subject-result construct) row-idx))) - (pred-elem - (generate-let-variable-string - (predicate construct) (elt (predicate-result construct) row-idx))) - (obj-elem - (generate-let-variable-string - (object construct) (elt (object-result construct) row-idx))) - (expression - (concatenate 'string - "(let* ((true t)(false nil)" - (getf subj-elem :string) - (getf pred-elem :string) - (getf obj-elem :string) - "(result " filter-string "))" - "(declare (ignorable true false " - (getf subj-elem :variable-names) " " - (getf pred-elem :variable-names) " " - (getf obj-elem :variable-names) "))" - "result)"))) - (when (eval (read-from-string expression)) - (push (list :subject (elt (subject-result construct) row-idx) - :predicate (elt (predicate-result construct) row-idx) - :object (elt (object-result construct) row-idx)) - results)))) - (setf (subject-result construct) - (map 'list #'(lambda(result) (getf result :subject)) results)) - (setf (predicate-result construct) - (map 'list #'(lambda(result) (getf result :predicate)) results)) - (setf (object-result construct) - (map 'list #'(lambda(result) (getf result :object)) results))))) +(defgeneric make-variable-values(construct variable-name existing-results) + (:documentation "Returns a list of values that are bound to the passed + variable. The first occurrence of the given variable + is evaluated, since all occurrences have the same values, + because reduce-results is called before and makes an + intersection over all triples.") + (:method ((construct SPARQL-Query) (variable-name String) (existing-results List)) + (let* ((found-p nil) + (results + (loop for triple in (select-group construct) + when (and (variable-p (subject triple)) + (string= (value (subject triple)) variable-name)) + return (progn (setf found-p t) + (subject-result triple)) + when (and (variable-p (predicate triple)) + (string= (value (predicate triple)) variable-name)) + return (progn (setf found-p t) + (predicate-result triple)) + when (and (variable-p (object triple)) + (string= (value (object triple)) + variable-name)) + return (progn (setf found-p t) + (object-result triple)))) + (new-results nil)) + (if (not found-p) + existing-results + (if existing-results + (dolist (result results new-results) + (dolist (old-result existing-results) + (push (append old-result (list (list :variable-name variable-name + :variable-value result))) + new-results))) + (map 'list #'(lambda(result) + (list (list :variable-name variable-name + :variable-value result))) + results)))))) + + +(defun to-lisp-code (variable-values filter) + "Concatenates all variable names and elements with the filter expression + in a let statement and returns a string representing the corresponding + lisp code." + (declare (List variable-values)) + (let ((result "(let* ((true t)(false nil)")) + (dolist (var-elem variable-values) + (push-string (concat "(?" (getf var-elem :variable-name) " " + (write-to-string (getf var-elem :variable-value)) ")") + result) + (push-string (concat "($" (getf var-elem :variable-name) " " + (write-to-string (getf var-elem :variable-value)) ")") + result)) + (push-string (concat "(result " filter "))") result) + (push-string "(declare (Ignorable true false " result) + (when variable-values + (dolist (var-elem variable-values) + (push-string (concat "?" (getf var-elem :variable-name) " ") result) + (push-string (concat "$" (getf var-elem :variable-name) " ") result))) + (push-string ")) result)" result) + (concat "(handler-case " result " (condition () nil))"))) + + +(defun return-false-values (all-values true-values) + "Returns a list that contains all values from all-values that + are not contained in true-values." + (let ((local-all-values + (remove-duplicates (reduce #'(lambda(x y) (append x y)) all-values) + :test #'variable-list=)) + (results nil)) + (dolist (value local-all-values) + (when (not (find value true-values :test #'variable-list=)) + (push value results))) + results)) + + +(defun variable-list= (x y) + (and (string= (getf x :variable-name) + (getf y :variable-name)) + (literal= (getf x :variable-value) + (getf y :variable-value)))) + + +(defgeneric process-filters (construct) + (:documentation "Processes all filters by calling invoke-filter.") + (:method ((construct SPARQL-Query)) + (dolist (filter (filters construct)) + (let* ((filter-variable-names + (get-variables-from-filter-string filter)) + (filter-variable-values nil) + (true-values nil)) + (dolist (var-name filter-variable-names) + (setf filter-variable-values + (make-variable-values construct var-name filter-variable-values))) + (dolist (filter (filters construct)) + (dolist (var-elem filter-variable-values) + (when (eval (read-from-string (to-lisp-code var-elem filter))) + (map 'list #'(lambda(list-elem) + (push list-elem true-values)) + var-elem)))) + (let ((values-to-remove + (return-false-values filter-variable-values + (remove-duplicates true-values + :test #'variable-list=)))) + (dolist (to-del values-to-remove) + (delete-rows-by-value construct (getf to-del :variable-name) + (getf to-del :variable-value)))))) + construct)) + + +(defgeneric idx-of (construct variable-name variable-value &key what) + (:documentation "Returns the idx of the variable with the name + variable-name and the value variable-value.") + (:method ((construct SPARQL-Triple) (variable-name String) + variable-value &key (what :subject)) + (declare (Keyword what)) + (let ((result nil) + (local-results + (cond ((eql what :subject) (subject-result construct)) + ((eql what :predicate) (predicate-result construct)) + ((eql what :object) (object-result construct)))) + (is-variable + (cond ((eql what :subject) + (and (variable-p (subject construct)) + (value (subject construct)))) + ((eql what :predicate) + (and (variable-p (predicate construct)) + (value (predicate construct)))) + ((eql what :object) + (and (variable-p (object construct)) + (value (object construct))))))) + (when is-variable + (remove-null + (dotimes (idx (length local-results)) + (when (literal= variable-value (elt local-results idx)) + (push idx result))))) + result))) + + +(defgeneric delete-rows-by-value (construct variable-name value-to-delete) + (:documentation "Deletes all rows that owns a variable with the + given value.") + (:method ((construct SPARQL-Query) (variable-name String) value-to-delete) + (dolist (triple (select-group construct)) + (let* ((subj-delete-idx-lst + (idx-of triple variable-name value-to-delete)) + (pred-delete-idx-lst + (idx-of triple variable-name value-to-delete :what :predicate)) + (obj-delete-idx-lst + (idx-of triple variable-name value-to-delete :what :object)) + (all-idxs (union (union subj-delete-idx-lst + pred-delete-idx-lst) + obj-delete-idx-lst))) + (when all-idxs + (let ((new-values nil)) + (dotimes (idx (length (subject-result triple))) + (when (not (find idx all-idxs)) + (push + (list :subject (elt (subject-result triple) idx) + :predicate (elt (predicate-result triple) idx) + :object (elt (object-result triple) idx)) + new-values))) + (setf (subject-result triple) + (map 'list #'(lambda(elem) (getf elem :subject)) new-values)) + (setf (predicate-result triple) + (map 'list #'(lambda(elem) (getf elem :predicate)) new-values)) + (setf (object-result triple) + (map 'list #'(lambda(elem) (getf elem :object)) new-values)))))) + construct)) (defgeneric set-results (construct &key revision) @@ -333,7 +443,7 @@ "Returns '<'uri-string'>' if uri-string is not a string uri-string is returned as result." (if (typep uri-string 'String) - (concatenate 'string "<" uri-string ">") + (concat "<" uri-string ">") uri-string)) @@ -884,7 +994,7 @@ (defmethod all-variables ((construct SPARQL-Query)) - "Returns all variables that are contained in the select groupt memebers." + "Returns all variables that are contained in the select group memebers." (remove-duplicates (remove-null (loop for triple in (select-group construct) @@ -1054,7 +1164,8 @@ ;; filters all entries that are not important for the result ;; => an intersection is invoked (reduce-results construct (make-result-lists construct)) - (dolist (triple (select-group construct)) - (dolist (filter (filters construct)) - (invoke-filter triple filter))) +; (dolist (triple (select-group construct)) +; (dolist (filter (filters construct)) +; (invoke-filter triple construct filter))) + (process-filters construct) construct) \ No newline at end of file Modified: trunk/src/TM-SPARQL/sparql_filter.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_filter.lisp (original) +++ trunk/src/TM-SPARQL/sparql_filter.lisp Tue Dec 21 17:57:57 2010 @@ -571,6 +571,7 @@ (when inner-value (+ inner-value (1+ (length (name-after-paranthesis (subseq left-string inner-value)))))))) + (start-idx (if first-bracket first-bracket 0))) @@ -949,4 +950,28 @@ t)) (if (find string-before *supported-functions* :test #'string=) nil - t)))) \ No newline at end of file + t)))) + + +(defun get-variables-from-filter-string(filter-string) + "Returns a list of string with all variables that are used in this filter." + (let ((variables nil)) + (dotimes (idx (length filter-string)) + (let ((current-string (subseq filter-string idx))) + (when (and (or (string-starts-with current-string "?") + (string-starts-with current-string "$")) + (not (in-literal-string-p filter-string idx))) + (let ((end-pos + (let ((inner-value + (search-first + (append (list " " "?" "$" "." ",") + (*supported-operators*) + *supported-brackets* + (map 'list #'string (white-space))) + (subseq current-string 1)))) + (if inner-value + (1+ inner-value) + (length current-string))))) + (push (subseq current-string 1 end-pos) variables) + (incf idx end-pos))))) + (remove-duplicates variables :test #'string=))) \ 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 Tue Dec 21 17:57:57 2010 @@ -38,7 +38,8 @@ :test-set-+-and---operators :test-set-compare-operators :test-set-functions - :test-module-1)) + :test-module-1 + :test-module-2)) (in-package :sparql-test) @@ -1599,6 +1600,32 @@ (list "Johann Wolfgang" "von Goethe" "http://de.wikipedia.org/wiki/Johann_Wolfgang_von_Goethe") :test #'string=)))))))) + + +(test test-module-2 + "Tests the entire module." + (with-fixture with-tm-filled-db ("data_base" *poems.xtm*) + (with-revision 0 + (let* ((query-1 + "PREFIX poem:<http://some.where/psis/poem/> + PREFIX author:<http://some.where/psis/author/> + PREFIX main:<http://some.where/base-psis/> + PREFIX tmdm:<http://psi.topicmaps.org/iso13250/model/> + SELECT ?poems WHERE{ + ?poems tmdm:type main:poem . #self as ?x a <y> + ?poems main:title ?titles . + FILTER (REGEX(?titles, '[a-zA-Z]+ [a-zA-Z]+')) }") + (result-1 + (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query query-1)))) + (is-true result-1) + (is (= (length result-1) 1)) + (is (string= (getf (first result-1) :variable) "poems")) + (is-false (set-exclusive-or + (getf (first result-1) :result) + (list "<http://some.where/psis/poem/resignation>" + "<http://some.where/psis/poem/erlkoenig>" + "<http://some.where/psis/poem/zauberlehrling>") + :test #'string=)))))) (defun run-sparql-tests ()

1 0

[isidorus-cvs] r382 - trunk/src/base-tools
by Lukas Giessmann 21 Dec '10

21 Dec '10

Author: lgiessmann Date: Tue Dec 21 15:20:36 2010 New Revision: 382 Log: TM-SPARQL: fixed a bug in search-firstunclosed-paranthesis when the string contains string-literals; added the macro concat which is a shortcut for concatenate 'string ... Modified: trunk/src/base-tools/base-tools.lisp Modified: trunk/src/base-tools/base-tools.lisp ============================================================================== --- trunk/src/base-tools/base-tools.lisp (original) +++ trunk/src/base-tools/base-tools.lisp Tue Dec 21 15:20:36 2010 @@ -11,6 +11,7 @@ (:use :cl) (:nicknames :tools) (:export :push-string + :concat :when-do :string-replace :remove-null @@ -64,6 +65,10 @@ `(setf ,place (concatenate 'string ,place ,obj))) +(defmacro concat (&rest strings) + `(concatenate 'string ,@strings)) + + (defmacro when-do (result-bounding condition-statement do-with-result) "Executes the first statement and stores its result in the variable result. If result isn't nil the second statement is called. @@ -449,15 +454,14 @@ (defun search-first-unclosed-paranthesis (str &key ignore-literals) "Returns the idx of the first ( that is not closed, the search is started from the end of the string. - If ignore-literals is set to t all mparanthesis that are within + If ignore-literals is set to t all paranthesis that are within \", \"\"\", ' and ''' are ignored." (declare (String str) (Boolean ignore-literals)) - (let ((r-str (reverse str)) - (open-brackets 0) + (let ((open-brackets 0) (result-idx nil)) - (dotimes (idx (length r-str)) - (let ((current-char (subseq r-str idx (1+ idx)))) + (do ((idx (1- (length str)))) ((< idx 0)) + (let ((current-char (subseq str idx (1+ idx)))) (cond ((string= current-char ")") (when (or ignore-literals (not (in-literal-string-p str idx))) @@ -468,9 +472,9 @@ (incf open-brackets) (when (> open-brackets 0) (setf result-idx idx) - (setf idx (length r-str)))))))) - (when result-idx - (- (length str) (1+ result-idx))))) + (setf idx 0))))) + (decf idx))) + result-idx)) (defun search-first-unopened-paranthesis (str &key ignore-literals)

1 0

[isidorus-cvs] r381 - in trunk/src: . TM-SPARQL
by Lukas Giessmann 20 Dec '10

20 Dec '10

Author: lgiessmann Date: Mon Dec 20 15:47:48 2010 New Revision: 381 Log: TM-SPARQL: fixed the type-handling in FILTERs when there is given something like 'xyz'^^anyType Modified: trunk/src/TM-SPARQL/filter_wrappers.lisp trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_filter.lisp trunk/src/TM-SPARQL/sparql_parser.lisp trunk/src/isidorus.asd Modified: trunk/src/TM-SPARQL/filter_wrappers.lisp ============================================================================== --- trunk/src/TM-SPARQL/filter_wrappers.lisp (original) +++ trunk/src/TM-SPARQL/filter_wrappers.lisp Mon Dec 20 15:47:48 2010 @@ -13,49 +13,84 @@ (:import-from :cl progn handler-case let)) +(defun filter-functions::normalize-value (value) + "Returns the normalized value, i.e. if a literal + is passed as '12'^^xsd:integer 12 is returned." + (cond ((not (stringp value)) + value) + ((or (base-tools:string-starts-with value "'") + (base-tools:string-starts-with value "\"")) + (let* ((literal-result (tm-sparql::get-literal value)) + (literal-value + (cond ((or (base-tools:string-starts-with + (getf literal-result :literal) "\"\"\"") + (base-tools:string-starts-with + (getf literal-result :literal) "'''")) + (subseq (getf literal-result :literal) 3 + (- (length (getf literal-result :literal)) 3))) + (t + (subseq (getf literal-result :literal) 1 + (- (length (getf literal-result :literal)) 1))))) + (given-datatype + (when (base-tools:string-starts-with + (getf literal-result :next-string) "^^") + (subseq (getf literal-result :next-string) 2)))) + (tm-sparql::cast-literal literal-value given-datatype))) + (t + value))) + + (defun filter-functions::not(x) - (not x)) + (not (filter-functions::normalize-value x))) (defun filter-functions::one+(x) - (1+ x)) + (1+ (filter-functions::normalize-value x))) (defun filter-functions::one-(x) - (1- x)) + (1- (filter-functions::normalize-value x))) (defun filter-functions::+(x y) - (+ x y)) + (+ (filter-functions::normalize-value x) + (filter-functions::normalize-value y))) (defun filter-functions::-(x y) - (- x y)) + (- (filter-functions::normalize-value x) + (filter-functions::normalize-value y))) (defun filter-functions::*(x y) - (* x y)) + (* (filter-functions::normalize-value x) + (filter-functions::normalize-value y))) (defun filter-functions::/(x y) - (/ x y)) + (/ (filter-functions::normalize-value x) + (filter-functions::normalize-value y))) (defun filter-functions::or(x y) - (or x y)) + (or (filter-functions::normalize-value x) + (filter-functions::normalize-value y))) (defun filter-functions::and(x y) - (and x y)) + (and (filter-functions::normalize-value x) + (filter-functions::normalize-value y))) (defun filter-functions::=(x y) - (cond ((and (stringp x) (stringp y)) - (string= x y)) - ((and (numberp x)( numberp y)) - (= x y)) - (t - (eql x y)))) + (let ((local-x (filter-functions::normalize-value x)) + (local-y (filter-functions::normalize-value y))) + (cond ((and (stringp local-x) (stringp local-y)) + (string= local-x local-y)) + ((and (numberp local-x)( numberp local-y)) + (= local-x local-y)) + (t + (eql local-x local-y))))) (defun filter-functions::!=(x y) @@ -64,14 +99,16 @@ (defun filter-functions::<(x y) - (cond ((and (numberp x) (numberp y)) - (< x y)) - ((and (stringp x) (stringp y)) - (string< x y)) - ((and (typep x 'Boolean) (typep y 'Boolean)) - (and (not x) y)) - (t - nil))) + (let ((local-x (filter-functions::normalize-value x)) + (local-y (filter-functions::normalize-value y))) + (cond ((and (numberp local-x) (numberp local-y)) + (< local-x local-y)) + ((and (stringp local-x) (stringp local-y)) + (string< local-x local-y)) + ((and (typep local-x 'Boolean) (typep local-y 'Boolean)) + (and (not local-x) local-y)) + (t + nil)))) (defun filter-functions::>(x y) @@ -92,18 +129,20 @@ (defun filter-functions::regex(str pattern &optional flags) - (declare (Ignorable flags)) - (let* ((case-insensitive (when (find #\i flags) t)) - (multi-line (when (find #\m flags) t)) - (single-line (when (find #\s flags) t)) + (let* ((local-flags (filter-functions::normalize-value flags)) + (case-insensitive (when (find #\i local-flags) t)) + (multi-line (when (find #\m local-flags) t)) + (single-line (when (find #\s local-flags) t)) (local-pattern - (if (find #\x flags) + (if (find #\x local-flags) (base-tools:string-replace (base-tools:string-replace (base-tools:string-replace - (base-tools:string-replace pattern (string #\newline) "") + (base-tools:string-replace + (filter-functions::normalize-value pattern) + (string #\newline) "") (string #\tab) "") (string #\cr) "") " " "") - pattern)) + (filter-functions::normalize-value pattern))) (scanner (ppcre:create-scanner local-pattern :case-insensitive-mode case-insensitive Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Mon Dec 20 15:47:48 2010 @@ -1010,6 +1010,42 @@ values))) +(defun cast-literal (literal-value literal-type) + "A helper function that casts the passed string value of the literal + corresponding to the passed literal-type." + (declare (String literal-value literal-type)) + (cond ((string= literal-type *xml-string*) + literal-value) + ((string= literal-type *xml-boolean*) + (when (and (string/= literal-value "false") + (string/= literal-value "true")) + (error (make-condition + 'sparql-parser-error + :message (format nil "Could not cast from ~a to ~a" + literal-value literal-type)))) + (if (string= literal-value "false") + nil + t)) + ((string= literal-type *xml-integer*) + (handler-case (parse-integer literal-value) + (condition () + (error (make-condition + 'sparql-parser-error + :message (format nil "Could not cast from ~a to ~a" + literal-value literal-type)))))) + ((or (string= literal-type *xml-decimal*) ;;both types are + (string= literal-type *xml-double*)) ;;handled the same way + (let ((value (read-from-string literal-value))) + (unless (numberp value) + (error (make-condition + 'sparql-parser-error + :message (format nil "Could not cast from ~a to ~a" + literal-value literal-type)))) + value)) + (t ; return the value as a string + literal-value))) + + (defmethod initialize-instance :after ((construct SPARQL-Query) &rest args) (declare (ignorable args)) (parser-start construct (original-query construct)) Modified: trunk/src/TM-SPARQL/sparql_filter.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_filter.lisp (original) +++ trunk/src/TM-SPARQL/sparql_filter.lisp Mon Dec 20 15:47:48 2010 @@ -121,10 +121,6 @@ (scan-filter-for-deprecated-calls construct filter-string-functions original-filter-string)) (parse-group construct next-query)))) - ;;TODO: implement - ;; *add ^^datatype to the object-literal-results - ;; *implement to-literal => CharacteristicC => \"...\"^^datatype => use for tm-sparql - ;; *implement str correctly (defgeneric scan-filter-for-deprecated-calls (construct filter-string Modified: trunk/src/TM-SPARQL/sparql_parser.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_parser.lisp (original) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Mon Dec 20 15:47:48 2010 @@ -217,42 +217,6 @@ :value (cast-literal l-value l-type))))) -(defun cast-literal (literal-value literal-type) - "A helper function that casts the passed string value of the literal - corresponding to the passed literal-type." - (declare (String literal-value literal-type)) - (cond ((string= literal-type *xml-string*) - literal-value) - ((string= literal-type *xml-boolean*) - (when (and (string/= literal-value "false") - (string/= literal-value "true")) - (error (make-condition - 'sparql-parser-error - :message (format nil "Could not cast from ~a to ~a" - literal-value literal-type)))) - (if (string= literal-value "false") - nil - t)) - ((string= literal-type *xml-integer*) - (handler-case (parse-integer literal-value) - (condition () - (error (make-condition - 'sparql-parser-error - :message (format nil "Could not cast from ~a to ~a" - literal-value literal-type)))))) - ((or (string= literal-type *xml-decimal*) ;;both types are - (string= literal-type *xml-double*)) ;;handled the same way - (let ((value (read-from-string literal-value))) - (unless (numberp value) - (error (make-condition - 'sparql-parser-error - :message (format nil "Could not cast from ~a to ~a" - literal-value literal-type)))) - value)) - (t ; return the value as a string - literal-value))) - - (defgeneric separate-literal-lang-or-type (construct query-string) (:documentation "A helper function that returns (:next-query string :lang string :type string). Only one of :lang and Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Mon Dec 20 15:47:48 2010 @@ -41,7 +41,8 @@ :depends-on ("constants" "base-tools")) (:module "TM-SPARQL" :components ((:file "sparql") - (:file "filter_wrappers") + (:file "filter_wrappers" + :depends-on ("sparql")) (:file "sparql_filter" :depends-on ("sparql" "filter_wrappers")) (:file "sparql_parser"

1 0

[isidorus-cvs] r380 - in trunk/src: TM-SPARQL unit_tests
by Lukas Giessmann 20 Dec '10

20 Dec '10

Author: lgiessmann Date: Mon Dec 20 14:14:55 2010 New Revision: 380 Log: TM-SPARQL: added some unit-tests that cover the main function 'initialize-instance :around' and 'result' Modified: trunk/src/TM-SPARQL/sparql_filter.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 Mon Dec 20 14:14:55 2010 @@ -124,6 +124,7 @@ ;;TODO: implement ;; *add ^^datatype to the object-literal-results ;; *implement to-literal => CharacteristicC => \"...\"^^datatype => use for tm-sparql + ;; *implement str correctly (defgeneric scan-filter-for-deprecated-calls (construct filter-string Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Mon Dec 20 14:14:55 2010 @@ -1525,41 +1525,80 @@ "(or(progn(DATATYPE?var3))(progn(progn(isLITERAL(=(one+?var1)(one-?var2))))))")))) -;(test test-module-1 -; "Tests the entire module." -; (with-fixture with-tm-filled-db ("data_base" *poems.xtm*) -; (with-revision 0 -; (let* ((query-1 -; "BASE <http://some.where/psis/poem/> -; SELECT $subject ?predicate WHERE{ -; ?subject $predicate <zauberlehrling> . -; FILTER (STR(?predicate) = 'http://some.where/base-psis/written')}") -; (query-2 "SELECT ?object ?subject WHERE{ -; <http://some.where/psis/author/goethe> ?prediate ?object . -; FILTER (isLITERAL(?object) && -; DATATYPE(?object) = -; 'http://www.w3.org/2001/XMLSchema#string')}") -; (query-3 "SELECT ?object ?subject WHERE{ -; <http://some.where/psis/author/goethe> ?prediate ?object . -; FILTER (notAllowed(?subject)}") -; (query-4 "SELECT ?object ?subject WHERE{ -; <http://some.where/psis/author/goethe> ?prediate ?object . -; FILTER ((notAllowed ?subject))}") -; (query-5 "SELECT ?object ?subject WHERE{ -; <http://some.where/psis/author/goethe> ?prediate ?object . -; FILTER(?a && (?b || ?c)}") -; (q-obj-1 (make-instance 'TM-SPARQL:SPARQL-Query :query query-1)) -; (q-obj-2 (make-instance 'TM-SPARQL:SPARQL-Query :query query-2))) -; (is-true q-obj-1) -; (is-true q-obj-2) -; (signals excpetions-sparql-parser-error -; (make-instance 'TM-SPARQL:SPARQL-Query :query query-3)) -; (signals excpetions-sparql-parser-error -; (make-instance 'TM-SPARQL:SPARQL-Query :query query-4)) -; (signals excpetions-sparql-parser-error -; (make-instance 'TM-SPARQL:SPARQL-Query :query query-5)) -; ;;TODO: implement -; )))) +(test test-module-1 + "Tests the entire module." + (with-fixture with-tm-filled-db ("data_base" *poems.xtm*) + (with-revision 0 + (let* ((query-1 + "BASE <http://some.where/psis/poem/> + SELECT $subject ?predicate WHERE{ + ?subject $predicate <zauberlehrling> . + FILTER (STR(?predicate) = 'http://some.where/base-psis/written')}") + (query-2 "SELECT ?object ?subject WHERE{ + <http://some.where/psis/author/goethe> ?predicate ?object . + FILTER (isLITERAL(?object) && + DATATYPE(?object) = + 'http://www.w3.org/2001/XMLSchema#string')}") + (query-3 "SELECT ?object ?subject WHERE{ + <http://some.where/psis/author/goethe> ?predicate ?object . + FILTER (notAllowed(?subject)}") + (query-4 "SELECT ?object ?predicate WHERE{ + <http://some.where/psis/author/goethe> ?predicate ?object . + FILTER ((notAllowed( ?predicate)))}") + (query-5 "SELECT ?object ?subject WHERE{ + <http://some.where/psis/author/goethe> ?predicate ?object . + FILTER(?a && (?b || ?c)}") + (result-1 + (tm-sparql:result + (make-instance 'TM-SPARQL:SPARQL-Query :query query-1))) + (result-2 + (tm-sparql:result + (make-instance 'TM-SPARQL:SPARQL-Query :query query-2)))) + (is-true result-1) + (is-true result-2) + (signals exceptions:sparql-parser-error + (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query query-3))) + (signals exceptions:sparql-parser-error + (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query query-4))) + (signals exceptions:sparql-parser-error + (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query query-5))) + (is (= (length result-1) 2)) + (if (string= (getf (first result-1) :variable) "subject") + (progn + (is (= (length (getf (first result-1) :result)) 1)) + (is (string= (first (getf (first result-1) :result)) + "<http://some.where/psis/author/goethe>")) + (is (string= (getf (second result-1) :variable) "predicate")) + (is (= (length (getf (second result-1) :result)) 1)) + (is (string= (first (getf (second result-1) :result)) + "<http://some.where/base-psis/written>"))) + (progn + (is (= (length (getf (second result-1) :result)) 1)) + (is (string= (first (getf (second result-1) :result)) + "<http://some.where/psis/author/goethe>")) + (is (string= (getf (first result-1) :variable) "predicate")) + (is (= (length (getf (first result-1) :result)) 1)) + (is (string= (first (getf (first result-1) :result)) + "<http://some.where/base-psis/written>")))) + (if (string= (getf (first result-2) :variable) "subject") + (progn + (is (= (length (getf (first result-2) :result)) 0)) + (is (string= (getf (second result-2) :variable) "object")) + (is (= (length (getf (second result-2) :result)) 3)) + (is-false (set-exclusive-or + (getf (second result-2) :result) + (list "Johann Wolfgang" "von Goethe" + "http://de.wikipedia.org/wiki/Johann_Wolfgang_von_Goethe") + :test #'string=))) + (progn + (is (= (length (getf (second result-2) :result)) 0)) + (is (string= (getf (first result-2) :variable) "object")) + (is (= (length (getf (first result-2) :result)) 3)) + (is-false (set-exclusive-or + (getf (first result-2) :result) + (list "Johann Wolfgang" "von Goethe" + "http://de.wikipedia.org/wiki/Johann_Wolfgang_von_Goethe") + :test #'string=)))))))) (defun run-sparql-tests ()

1 0

[isidorus-cvs] r379 - trunk/src/TM-SPARQL
by Lukas Giessmann 20 Dec '10

20 Dec '10

Author: lgiessmann Date: Mon Dec 20 13:28:01 2010 New Revision: 379 Log: TM-SPARQL: fixed a bug when invoking filters => all functions are explicit wrapped in the filter-functions package by using the prefix 'filter-functions::' in the filter stirng. Modified: trunk/src/TM-SPARQL/filter_wrappers.lisp trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_filter.lisp trunk/src/TM-SPARQL/sparql_parser.lisp Modified: trunk/src/TM-SPARQL/filter_wrappers.lisp ============================================================================== --- trunk/src/TM-SPARQL/filter_wrappers.lisp (original) +++ trunk/src/TM-SPARQL/filter_wrappers.lisp Mon Dec 20 13:28:01 2010 @@ -9,7 +9,8 @@ (defpackage :filter-functions - (:use :base-tools :constants :tm-sparql)) + (:use :base-tools :constants :tm-sparql) + (:import-from :cl progn handler-case let)) (defun filter-functions::not(x) Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Mon Dec 20 13:28:01 2010 @@ -252,33 +252,50 @@ (push variable-name (variables construct))))) +(defgeneric generate-let-variable-string (construct value) + (:documentation "Returns a list if the form (:string <var-string> + :variable-names (<?var-name-as-string> + <$var-name-as-string>)).") + (:method ((construct SPARQL-Triple-Elem) value) + (when (variable-p construct) + (let* ((var-value (write-to-string value)) + (var-name (value construct)) + (lisp-str + (concatenate 'string "(?" var-name " " var-value ")" + "($" var-name " " var-value ")")) + (vars + (concatenate 'string "?" var-name " $" var-name))) + (list :string lisp-str + :variable-names vars))))) + + (defgeneric invoke-filter (construct filter-string) (:documentation "Invokes the passed filter on the construct that represents a sparql result.") (:method ((construct SPARQL-Triple) (filter-string String)) (let ((results nil)) ;a list of the form (:subject x :predicate y :object z) (dotimes (row-idx (length (subject-result construct))) - (let* ((subj-var - (when (variable-p (subject construct)) - (concatenate 'string "(" (value (subject construct)) - " " (elt (subject-result construct) row-idx) ")"))) - (pred-var - (when (variable-p (predicate construct)) - (concatenate 'string "(" (value (predicate construct)) - " " (elt (predicate-result construct) row-idx) ")"))) - (obj-var - (when (variable-p (object construct)) - (concatenate 'string "(" (value (object construct)) - " " (elt (object-result construct) row-idx) ")"))) - (var-let - (concatenate 'string "(let ((true t) (false nil) " - subj-var pred-var obj-var ")")) + (let* ((subj-elem + (generate-let-variable-string + (subject construct) (elt (subject-result construct) row-idx))) + (pred-elem + (generate-let-variable-string + (predicate construct) (elt (predicate-result construct) row-idx))) + (obj-elem + (generate-let-variable-string + (object construct) (elt (object-result construct) row-idx))) (expression - (concatenate 'string var-let "(cl:handler-case " - filter-string - "(exception:sparql-parser-error (err) " - "(cl:in-package :cl-user) " - "(error err)))"))) + (concatenate 'string + "(let* ((true t)(false nil)" + (getf subj-elem :string) + (getf pred-elem :string) + (getf obj-elem :string) + "(result " filter-string "))" + "(declare (ignorable true false " + (getf subj-elem :variable-names) " " + (getf pred-elem :variable-names) " " + (getf obj-elem :variable-names) "))" + "result)"))) (when (eval (read-from-string expression)) (push (list :subject (elt (subject-result construct) row-idx) :predicate (elt (predicate-result construct) row-idx) Modified: trunk/src/TM-SPARQL/sparql_filter.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_filter.lisp (original) +++ trunk/src/TM-SPARQL/sparql_filter.lisp Mon Dec 20 13:28:01 2010 @@ -128,20 +128,27 @@ (defgeneric scan-filter-for-deprecated-calls (construct filter-string original-filter) - (:documentation "Returns the passed filter-string or throws a - sparql-parser-error of there is an unallowed - function call.") + (:documentation "Returns the passed filter-string where all functions + are explicit wrapped in the filter-functions package + or throws a sparql-parser-error of there is an + unallowed function call.") (:method ((construct SPARQL-Query) (filter-string String) (original-filter String)) - (dotimes (idx (length filter-string) filter-string) - (when-do fun-name (return-function-name (subseq filter-string idx)) - (unless (string-starts-with-one-of fun-name *supported-functions*) + (let ((result "")) + (dotimes (idx (length filter-string) result) + (let ((fun-name (return-function-name (subseq filter-string idx)))) + (cond ((not fun-name) + (push-string (subseq filter-string idx (1+ idx)) result)) + ((string-starts-with-one-of fun-name *allowed-filter-calls*) + (push-string "(filter-functions::" result) + (push-string fun-name result) + (incf idx (length fun-name))) + (t (error (make-condition 'exceptions:sparql-parser-error - :message (format nil "Invalid filter: the filter \"~a\" evaluated to \"~a\" which contains the depricated function ~a!" - filter-string original-filter fun-name)))))))) - + :message (format nil "Invalid filter: the filter \"~a\" evaluated to \"~a\" which contains the deprecated function ~a!" + filter-string original-filter fun-name)))))))))) (defun return-function-name (filter-string) Modified: trunk/src/TM-SPARQL/sparql_parser.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_parser.lisp (original) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Mon Dec 20 13:28:01 2010 @@ -117,7 +117,7 @@ trimmed-str (original-query construct) "FILTER, BASE, or triple. Grouping is currently no implemented."))) ((string-starts-with trimmed-str "FILTER") - (parse-filter (string-after trimmed-str "FILTER") construct)) + (parse-filter construct (string-after trimmed-str "FILTER"))) ((string-starts-with trimmed-str "OPTIONAL") (error (make-sparql-parser-condition trimmed-str (original-query construct)

1 0

[isidorus-cvs] r378 - in trunk/src: TM-SPARQL unit_tests
by Lukas Giessmann 20 Dec '10

20 Dec '10

Author: lgiessmann Date: Mon Dec 20 11:25:53 2010 New Revision: 378 Log: TM-SPARQL: adapted some unit-tests to the latest changes; fixed a bug when calculating the final result Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_filter.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 Mon Dec 20 11:25:53 2010 @@ -271,9 +271,14 @@ (concatenate 'string "(" (value (object construct)) " " (elt (object-result construct) row-idx) ")"))) (var-let - (concatenate 'string "(let ((true t) (false nil)" + (concatenate 'string "(let ((true t) (false nil) " subj-var pred-var obj-var ")")) - (expression (concatenate 'string var-let filter-string ")"))) + (expression + (concatenate 'string var-let "(cl:handler-case " + filter-string + "(exception:sparql-parser-error (err) " + "(cl:in-package :cl-user) " + "(error err)))"))) (when (eval (read-from-string expression)) (push (list :subject (elt (subject-result construct) row-idx) :predicate (elt (predicate-result construct) row-idx) @@ -945,11 +950,16 @@ (when var-elem (let* ((rows-to-hold (remove-null - (map 'list #'(lambda(val) - (if (stringp val) - (position val var-elem :test #'string=) - (position val var-elem))) - dont-touch-values))) + (map 'list #'(lambda(res) + (when (cond + ((stringp res) + (find res dont-touch-values :test #'string=)) + ((numberp res) + (find res dont-touch-values :test #'=)) + (t + (find res dont-touch-values))) + (position res var-elem))) + var-elem))) (new-result-list (map 'list #'(lambda(row-idx) Modified: trunk/src/TM-SPARQL/sparql_filter.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_filter.lisp (original) +++ trunk/src/TM-SPARQL/sparql_filter.lisp Mon Dec 20 11:25:53 2010 @@ -122,10 +122,6 @@ construct filter-string-functions original-filter-string)) (parse-group construct next-query)))) ;;TODO: implement - ;; *implement wrapper functions, also for the operators - ;; it would be nice when the self defined operator functions would be in a - ;; separate packet, e.g. filter-functions, so =, ... would couse no - ;; collisions ;; *add ^^datatype to the object-literal-results ;; *implement to-literal => CharacteristicC => \"...\"^^datatype => use for tm-sparql Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Mon Dec 20 11:25:53 2010 @@ -37,7 +37,8 @@ :test-set-*-and-/-operators :test-set-+-and---operators :test-set-compare-operators - :test-set-functions)) + :test-set-functions + :test-module-1)) (in-package :sparql-test) @@ -472,7 +473,7 @@ (string= obj-1 "<http://some.where/psis/der_zauberlehrling>"))) (is (or (string= subj-2 "<http://some.where/psis/author/goethe>") (string= subj-2 "<http://some.where/psis/persons/goethe>"))) - (is (string= pred-1 "<http://psi.topicmaps.org/iso13250/model/type>")) + (is (string= pred-1 "<http://psi.topicmaps.org/iso13250/model/instance>")) (is (or (string= obj-2 "<http://some.where/psis/poem/zauberlehrling>") (string= obj-2 "<http://some.where/psis/der_zauberlehrling>")))) (t @@ -867,7 +868,7 @@ (is (= (length (tm-sparql::subject-result (first (tm-sparql::select-group q-obj-3)))) 0)) (is (= (length (tm-sparql::subject-result - (second (tm-sparql::select-group q-obj-3)))) 1)) + (second (tm-sparql::select-group q-obj-3)))) 0)) (is (or (string= "<http://some.where/psis/author/goethe>" (first (tm-sparql::subject-result (first (tm-sparql::select-group q-obj-1))))) @@ -922,18 +923,12 @@ (first (tm-sparql::select-group q-obj-3))))) (is-false (first (tm-sparql::object-result (first (tm-sparql::select-group q-obj-3))))) - (is (or (string= "<http://some.where/psis/author/goethe>" - (first (tm-sparql::subject-result - (second (tm-sparql::select-group q-obj-3))))) - (string= "<http://some.where/psis/persons/goethe>" - (first (tm-sparql::subject-result - (second (tm-sparql::select-group q-obj-3))))))) - (is (string= "<http://some.where/base-psis/last-name>" - (first (tm-sparql::predicate-result - (second (tm-sparql::select-group q-obj-3)))))) - (is (string= "von Goethe" - (first (tm-sparql::object-result - (second (tm-sparql::select-group q-obj-3)))))))))) + (is-false (first (tm-sparql::subject-result + (second (tm-sparql::select-group q-obj-3))))) + (is-false (first (tm-sparql::predicate-result + (second (tm-sparql::select-group q-obj-3))))) + (is-false (first (tm-sparql::object-result + (second (tm-sparql::select-group q-obj-3))))))))) (test test-result @@ -1528,7 +1523,43 @@ "(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))))))")))) - + + +;(test test-module-1 +; "Tests the entire module." +; (with-fixture with-tm-filled-db ("data_base" *poems.xtm*) +; (with-revision 0 +; (let* ((query-1 +; "BASE <http://some.where/psis/poem/> +; SELECT $subject ?predicate WHERE{ +; ?subject $predicate <zauberlehrling> . +; FILTER (STR(?predicate) = 'http://some.where/base-psis/written')}") +; (query-2 "SELECT ?object ?subject WHERE{ +; <http://some.where/psis/author/goethe> ?prediate ?object . +; FILTER (isLITERAL(?object) && +; DATATYPE(?object) = +; 'http://www.w3.org/2001/XMLSchema#string')}") +; (query-3 "SELECT ?object ?subject WHERE{ +; <http://some.where/psis/author/goethe> ?prediate ?object . +; FILTER (notAllowed(?subject)}") +; (query-4 "SELECT ?object ?subject WHERE{ +; <http://some.where/psis/author/goethe> ?prediate ?object . +; FILTER ((notAllowed ?subject))}") +; (query-5 "SELECT ?object ?subject WHERE{ +; <http://some.where/psis/author/goethe> ?prediate ?object . +; FILTER(?a && (?b || ?c)}") +; (q-obj-1 (make-instance 'TM-SPARQL:SPARQL-Query :query query-1)) +; (q-obj-2 (make-instance 'TM-SPARQL:SPARQL-Query :query query-2))) +; (is-true q-obj-1) +; (is-true q-obj-2) +; (signals excpetions-sparql-parser-error +; (make-instance 'TM-SPARQL:SPARQL-Query :query query-3)) +; (signals excpetions-sparql-parser-error +; (make-instance 'TM-SPARQL:SPARQL-Query :query query-4)) +; (signals excpetions-sparql-parser-error +; (make-instance 'TM-SPARQL:SPARQL-Query :query query-5)) +; ;;TODO: implement +; )))) (defun run-sparql-tests ()

1 0

[isidorus-cvs] r377 - trunk/src/TM-SPARQL
by Lukas Giessmann 19 Dec '10

19 Dec '10

Author: lgiessmann Date: Sun Dec 19 17:48:02 2010 New Revision: 377 Log: TM-SPARQL: implemented the handling of filters Modified: trunk/src/TM-SPARQL/filter_wrappers.lisp trunk/src/TM-SPARQL/sparql.lisp Modified: trunk/src/TM-SPARQL/filter_wrappers.lisp ============================================================================== --- trunk/src/TM-SPARQL/filter_wrappers.lisp (original) +++ trunk/src/TM-SPARQL/filter_wrappers.lisp Sun Dec 19 17:48:02 2010 @@ -142,5 +142,10 @@ (defun filter-functions::str(x) - ;TODO: implement - ) \ No newline at end of file + (if (stringp x) + (if (and (base-tools:string-starts-with x "<") + (base-tools:string-ends-with x ">") + (base-tools:absolute-uri-p (subseq x 1 (1- (length x))))) + (subseq x 1 (1- (length x))) + x) + (write-to-string x))) \ No newline at end of file Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Sun Dec 19 17:48:02 2010 @@ -256,32 +256,35 @@ (:documentation "Invokes the passed filter on the construct that represents a sparql result.") (:method ((construct SPARQL-Triple) (filter-string String)) - (dotimes (row-idx (length (subject-result construct))) - (let* ((subj-var - (when (variable-p (subject construct)) - (concatenate 'string "(" (value (subject construct)) - " " (elt (subject-result construct) row-idx) ")"))) - (pred-var - (when (variable-p (predicate construct)) - (concatenate 'string "(" (value (predicate construct)) - " " (elt (predicate-result construct) row-idx) ")"))) - (obj-var - (when (variable-p (object construct)) - (concatenate 'string "(" (value (object construct)) - " " (elt (object-result construct) row-idx) ")"))) - (var-let - (if (or subj-var pred-var obj-var) - (concatenate 'string "(let (" subj-var pred-var obj-var ")") - "(let ()")) - (expression (concatenate 'string var-let filter-string ")"))) - - )) - ;TODO: implement - ;; *implement a method "invoke-filter(SPARQL-Triple filter-string)" so - ;; that the variables are automatically contained in a let afterwards - ;; the eval function can be called this method should also have a let - ;; with (true t) and (false nil) - )) + (let ((results nil)) ;a list of the form (:subject x :predicate y :object z) + (dotimes (row-idx (length (subject-result construct))) + (let* ((subj-var + (when (variable-p (subject construct)) + (concatenate 'string "(" (value (subject construct)) + " " (elt (subject-result construct) row-idx) ")"))) + (pred-var + (when (variable-p (predicate construct)) + (concatenate 'string "(" (value (predicate construct)) + " " (elt (predicate-result construct) row-idx) ")"))) + (obj-var + (when (variable-p (object construct)) + (concatenate 'string "(" (value (object construct)) + " " (elt (object-result construct) row-idx) ")"))) + (var-let + (concatenate 'string "(let ((true t) (false nil)" + subj-var pred-var obj-var ")")) + (expression (concatenate 'string var-let filter-string ")"))) + (when (eval (read-from-string expression)) + (push (list :subject (elt (subject-result construct) row-idx) + :predicate (elt (predicate-result construct) row-idx) + :object (elt (object-result construct) row-idx)) + results)))) + (setf (subject-result construct) + (map 'list #'(lambda(result) (getf result :subject)) results)) + (setf (predicate-result construct) + (map 'list #'(lambda(result) (getf result :predicate)) results)) + (setf (object-result construct) + (map 'list #'(lambda(result) (getf result :object)) results))))) (defgeneric set-results (construct &key revision)

1 0

[isidorus-cvs] r376 - in trunk/src: . TM-SPARQL base-tools
by Lukas Giessmann 19 Dec '10

19 Dec '10

Author: lgiessmann Date: Sun Dec 19 16:00:02 2010 New Revision: 376 Log: TM-SPARQL: implemented all wrapper functions for filters in a separate package Added: trunk/src/TM-SPARQL/filter_wrappers.lisp Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_filter.lisp trunk/src/TM-SPARQL/sparql_parser.lisp trunk/src/base-tools/base-tools.lisp trunk/src/isidorus.asd Added: trunk/src/TM-SPARQL/filter_wrappers.lisp ============================================================================== --- (empty file) +++ trunk/src/TM-SPARQL/filter_wrappers.lisp Sun Dec 19 16:00:02 2010 @@ -0,0 +1,146 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff +;;+ +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- + + +(defpackage :filter-functions + (:use :base-tools :constants :tm-sparql)) + + +(defun filter-functions::not(x) + (not x)) + + +(defun filter-functions::one+(x) + (1+ x)) + + +(defun filter-functions::one-(x) + (1- x)) + + +(defun filter-functions::+(x y) + (+ x y)) + + +(defun filter-functions::-(x y) + (- x y)) + + +(defun filter-functions::*(x y) + (* x y)) + + +(defun filter-functions::/(x y) + (/ x y)) + + +(defun filter-functions::or(x y) + (or x y)) + + +(defun filter-functions::and(x y) + (and x y)) + + +(defun filter-functions::=(x y) + (cond ((and (stringp x) (stringp y)) + (string= x y)) + ((and (numberp x)( numberp y)) + (= x y)) + (t + (eql x y)))) + + +(defun filter-functions::!=(x y) + (filter-functions::not + (filter-functions::= x y))) + + +(defun filter-functions::<(x y) + (cond ((and (numberp x) (numberp y)) + (< x y)) + ((and (stringp x) (stringp y)) + (string< x y)) + ((and (typep x 'Boolean) (typep y 'Boolean)) + (and (not x) y)) + (t + nil))) + + +(defun filter-functions::>(x y) + (filter-functions::not + (filter-functions::< x y))) + + +(defun filter-functions::<=(x y) + (filter-functions::or + (filter-functions::< x y) + (filter-functions::= x y))) + + +(defun filter-functions::>=(x y) + (filter-functions::or + (filter-functions::> x y) + (filter-functions::= x y))) + + +(defun filter-functions::regex(str pattern &optional flags) + (declare (Ignorable flags)) + (let* ((case-insensitive (when (find #\i flags) t)) + (multi-line (when (find #\m flags) t)) + (single-line (when (find #\s flags) t)) + (local-pattern + (if (find #\x flags) + (base-tools:string-replace + (base-tools:string-replace + (base-tools:string-replace + (base-tools:string-replace pattern (string #\newline) "") + (string #\tab) "") (string #\cr) "") " " "") + pattern)) + (scanner + (ppcre:create-scanner local-pattern + :case-insensitive-mode case-insensitive + :multi-line-mode multi-line + :single-line-mode single-line))) + (ppcre:scan scanner str))) + + +(defun filter-functions::bound(x) + (boundp x)) + + +(defun filter-functions::isLITERAL(x) + (or (numberp x) + (not (and (base-tools:string-starts-with x "<") + (base-tools:string-ends-with x ">") + (base-tools:absolute-uri-p x))))) + + +(defun filter-functions::datatype(x) + (let ((type-suffix + (when (and (stringp x) + (or (base-tools:string-starts-with x "'") + (base-tools:string-starts-with x "\""))) + (let* ((result (base-tools:get-literal x)) + (literal-datatype + (when (base-tools:string-starts-with + (getf result :next-string) "^^") + (subseq (getf result :next-string) 2)))) + literal-datatype)))) + (cond (type-suffix type-suffix) + ((integerp x) constants::*xml-integer*) + ((floatp x) constants::*xml-decimal*) + ((numberp x) constants::*xml-double*) + ((stringp x) constants::*xml-string*) + (t (type-of x))))) + + +(defun filter-functions::str(x) + ;TODO: implement + ) \ No newline at end of file Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Sun Dec 19 16:00:02 2010 @@ -132,8 +132,8 @@ ;purposes and mustn't be reset :type List :initform nil - :documentation "A list of the form that contains the variable - names as string.") + :documentation "A list of that contains the variable + names as strings.") (prefixes :initarg :prefixes :accessor prefixes ;this value is only for internal purposes ;purposes and mustn't be reset @@ -154,15 +154,31 @@ :type List :initform nil :documentation "Contains a SPARQL-Group that represents - the entire inner select-where statement.")) + the entire inner select-where statement.") + (filters :initarg filters + :accessor filters ;this value is only for internal purposes + ;purposes and mustn't be reset + :type List ;a list of strings + :initform nil + :documentation "Contains strings, each string represents a filter + that was transformed to lisp code and can be evoked + on each triple in the list select-group.")) (:documentation "This class represents the entire request.")) (defgeneric *-p (construct) (:documentation "Returns t if the user selected all variables with *.") (:method ((construct SPARQL-Query)) - (and (= (length (variables construct)) 1) - (string= (first (variables construct)) "*")))) + (loop for var in (variables construct) + when (string= var "*") + return t))) + + +(defgeneric add-filter (construct filter) + (:documentation "Pushes the filter string to the corresponding list in + the construct.") + (:method ((construct SPARQL-Query) (filter String)) + (push filter (filters construct)))) (defmethod variables ((construct SPARQL-Triple)) @@ -236,6 +252,38 @@ (push variable-name (variables construct))))) +(defgeneric invoke-filter (construct filter-string) + (:documentation "Invokes the passed filter on the construct that + represents a sparql result.") + (:method ((construct SPARQL-Triple) (filter-string String)) + (dotimes (row-idx (length (subject-result construct))) + (let* ((subj-var + (when (variable-p (subject construct)) + (concatenate 'string "(" (value (subject construct)) + " " (elt (subject-result construct) row-idx) ")"))) + (pred-var + (when (variable-p (predicate construct)) + (concatenate 'string "(" (value (predicate construct)) + " " (elt (predicate-result construct) row-idx) ")"))) + (obj-var + (when (variable-p (object construct)) + (concatenate 'string "(" (value (object construct)) + " " (elt (object-result construct) row-idx) ")"))) + (var-let + (if (or subj-var pred-var obj-var) + (concatenate 'string "(let (" subj-var pred-var obj-var ")") + "(let ()")) + (expression (concatenate 'string var-let filter-string ")"))) + + )) + ;TODO: implement + ;; *implement a method "invoke-filter(SPARQL-Triple filter-string)" so + ;; that the variables are automatically contained in a let afterwards + ;; the eval function can be called this method should also have a let + ;; with (true t) and (false nil) + )) + + (defgeneric set-results (construct &key revision) (:documentation "Calculates the result of a triple and set all the values in the passed object.") @@ -766,18 +814,16 @@ (defgeneric result (construct) (:documentation "Returns the result of the entire query.") (:method ((construct SPARQL-Query)) - (let ((result-lists (make-result-lists construct))) - (reduce-results construct result-lists) - (let* ((response-variables - (reverse (if (*-p construct) - (all-variables construct) - (variables construct)))) - (cleaned-results (make-result-lists construct))) - (map 'list #'(lambda(response-variable) - (list :variable response-variable - :result (variable-intersection response-variable - cleaned-results))) - response-variables))))) + (let* ((response-variables + (reverse (if (*-p construct) + (all-variables construct) + (variables construct)))) + (cleaned-results (make-result-lists construct))) + (map 'list #'(lambda(response-variable) + (list :variable response-variable + :result (variable-intersection response-variable + cleaned-results))) + response-variables)))) (defgeneric make-result-lists (construct) @@ -939,4 +985,10 @@ (parser-start construct (original-query construct)) (dolist (triple (select-group construct)) (set-results triple :revision (revision construct))) + ;; filters all entries that are not important for the result + ;; => an intersection is invoked + (reduce-results construct (make-result-lists construct)) + (dolist (triple (select-group construct)) + (dolist (filter (filters construct)) + (invoke-filter triple filter))) construct) \ No newline at end of file Modified: trunk/src/TM-SPARQL/sparql_filter.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_filter.lisp (original) +++ trunk/src/TM-SPARQL/sparql_filter.lisp Sun Dec 19 16:00:02 2010 @@ -117,18 +117,17 @@ (set-compare-operators construct filter-string-arithmetic-ops)) (filter-string-functions (set-functions construct filter-string-compare-ops))) - (list :next-query next-query - :filter-string (scan-filter-for-deprecated-calls - construct filter-string-functions original-filter-string))))) + (add-filter construct + (scan-filter-for-deprecated-calls + construct filter-string-functions original-filter-string)) + (parse-group construct next-query)))) ;;TODO: implement ;; *implement wrapper functions, also for the operators - ;; it would be nice of the self defined operator functions would be in a + ;; it would be nice when the self defined operator functions would be in a ;; separate packet, e.g. filter-functions, so =, ... would couse no ;; collisions - ;; *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) + ;; *add ^^datatype to the object-literal-results + ;; *implement to-literal => CharacteristicC => \"...\"^^datatype => use for tm-sparql (defgeneric scan-filter-for-deprecated-calls (construct filter-string @@ -677,10 +676,8 @@ (push-string current-char result-string)))) ((or (string= current-char "'") (string= current-char "\"")) - (let* ((sub-str (subseq filter-string idx)) - (quotation (get-literal-quotation sub-str)) - (literal - (get-literal (subseq filter-string idx) :quotation quotation))) + (let ((literal + (get-literal (subseq filter-string idx)))) (if literal (progn (setf idx (- (1- (length filter-string)) @@ -710,7 +707,7 @@ (list :next-query (string-after cleaned-str result) :scope result))) ((string-starts-with cleaned-str "\"") - (let ((result (get-literal cleaned-str))) + (let ((result (get-literal cleaned-str :quotation "\""))) (list :next-query (getf result :next-string) :scope (getf result :literal)))) ((string-starts-with-digit cleaned-str) @@ -807,10 +804,7 @@ (let ((current-char (subseq str idx (1+ idx)))) (cond ((or (string= "'" current-char) (string= "\"" current-char)) - (let* ((sub-str (subseq str idx)) - (quotation (get-literal-quotation sub-str)) - (literal - (get-literal (subseq str idx) :quotation quotation))) + (let ((literal (get-literal (subseq str idx)))) (if literal (progn (setf idx (- (1- (length str)) @@ -861,7 +855,8 @@ (push-string current-char filter-string)) ((or (string= "'" current-char) (string= "\"" current-char)) - (let ((result (get-literal (subseq query-string idx)))) + (let ((result + (get-literal (subseq query-string idx) :quotation "\""))) (unless result (error (make-sparql-parser-condition (subseq query-string idx) Modified: trunk/src/TM-SPARQL/sparql_parser.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_parser.lisp (original) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Sun Dec 19 16:00:02 2010 @@ -95,7 +95,9 @@ (error (make-sparql-parser-condition trimmed-str (original-query construct) "{"))) (let ((query-tail (parse-group construct (subseq trimmed-str 1)))) - ;TODO: process query-tail + (when (> (length (trim-whitespace query-tail)) 0) + (make-sparql-parser-condition + query-tail (original-query construct) "end of query, solution sequences and modifiers are not supported")) query-tail)))) @@ -125,7 +127,6 @@ trimmed-str (original-query construct) "FILTER, BASE, or triple. Grouping is currently no implemented."))) ((string-starts-with trimmed-str "}") ;ending of this group - ;TODO: invoke filters with all results on construct in initialize :after (subseq trimmed-str 1)) (t (parse-triple construct trimmed-str :last-subject last-subject)))))) @@ -249,9 +250,7 @@ literal-value literal-type)))) value)) (t ; return the value as a string - (if (stringp literal-value) - literal-value - (write-to-string literal-value))))) + literal-value))) (defgeneric separate-literal-lang-or-type (construct query-string) Modified: trunk/src/base-tools/base-tools.lisp ============================================================================== --- trunk/src/base-tools/base-tools.lisp (original) +++ trunk/src/base-tools/base-tools.lisp Sun Dec 19 16:00:02 2010 @@ -294,49 +294,37 @@ "\""))) -(defun get-literal (query-string &key (quotation "\"")) +(defun get-literal (query-string &key (quotation nil)) "Returns a list of the form (:next-string <string> :literal <string> where next-query is the query after the found literal and literal is the literal string." (declare (String query-string) - (String quotation)) - (cond ((or (string-starts-with query-string "\"\"\"") - (string-starts-with query-string "'''")) - (let ((literal-end - (find-literal-end (subseq query-string 3) (subseq query-string 0 3)))) - (when literal-end - (list :next-string (subseq query-string (+ 3 literal-end)) - :literal (concatenate 'string quotation - (subseq query-string 3 literal-end) - quotation))))) - ((or (string-starts-with query-string "\"") - (string-starts-with query-string "'")) - (let ((literal-end - (find-literal-end (subseq query-string 1) - (subseq query-string 0 1)))) - (when literal-end - (let ((literal - (escape-string (subseq query-string 1 literal-end) "\""))) - (list :next-string (subseq query-string (+ 1 literal-end)) - :literal (concatenate 'string quotation literal - quotation)))))))) - - -;(defun search-first-ignore-literals (search-strings main-string) -; (declare (String main-string) -; (List search-strings)) -; (let ((first-pos (search-first search-strings main-string))) -; (when first-pos -; (if (not (in-literal-string-p main-string first-pos)) -; first-pos -; (let* ((literal-start (search-first (list "\"" "'") main-string)) -; (sub-str (subseq main-string literal-start)) -; (literal-result (get-literal sub-str)) -; (next-str (getf literal-result :next-string))) -; (let ((next-pos -; (search-first-ignore-literals search-strings next-str))) -; (when next-pos -; (+ (- (length main-string) (length next-str)) next-pos)))))))) + (type (or Null String) quotation)) + (let ((local-quotation quotation)) + (cond ((or (string-starts-with query-string "\"\"\"") + (string-starts-with query-string "'''")) + (unless local-quotation + (setf local-quotation (subseq query-string 0 3))) + (let ((literal-end + (find-literal-end (subseq query-string 3) (subseq query-string 0 3)))) + (when literal-end + (list :next-string (subseq query-string (+ 3 literal-end)) + :literal (concatenate 'string quotation + (subseq query-string 3 literal-end) + quotation))))) + ((or (string-starts-with query-string "\"") + (string-starts-with query-string "'")) + (unless local-quotation + (setf local-quotation (subseq query-string 0 1))) + (let ((literal-end + (find-literal-end (subseq query-string 1) + (subseq query-string 0 1)))) + (when literal-end + (let ((literal + (escape-string (subseq query-string 1 literal-end) "\""))) + (list :next-string (subseq query-string (+ 1 literal-end)) + :literal (concatenate 'string local-quotation literal + local-quotation))))))))) (defun search-first-ignore-literals (search-strings main-string &key from-end) Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Sun Dec 19 16:00:02 2010 @@ -1,4 +1,3 @@ -;;-*- mode: lisp -*- ;;+----------------------------------------------------------------------------- ;;+ Isidorus ;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff @@ -42,8 +41,9 @@ :depends-on ("constants" "base-tools")) (:module "TM-SPARQL" :components ((:file "sparql") + (:file "filter_wrappers") (:file "sparql_filter" - :depends-on ("sparql")) + :depends-on ("sparql" "filter_wrappers")) (:file "sparql_parser" :depends-on ("sparql" "sparql_filter"))) :depends-on ("constants" "base-tools" "model"))

1 0

[isidorus-cvs] r375 - in trunk/src: TM-SPARQL base-tools unit_tests
by Lukas Giessmann 19 Dec '10

19 Dec '10

Author: lgiessmann Date: Sun Dec 19 10:18:30 2010 New Revision: 375 Log: TM-SPARQL: added the scanning of function in sparql-filters that are not allowed, so not authorized calls, e.g. of drop-instance or another lisp functions are detected and therefore not evaluated; changed the form of the return values of sparql-triples, now an uri is embraced in <> => adapt the corresponding unit-tests. Modified: trunk/src/TM-SPARQL/sparql.lisp 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.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Sun Dec 19 10:18:30 2010 @@ -256,6 +256,14 @@ results))))) +(defun embrace-uri(uri-string) + "Returns '<'uri-string'>' if uri-string is not a string uri-string + is returned as result." + (if (typep uri-string 'String) + (concatenate 'string "<" uri-string ">") + uri-string)) + + (defgeneric filter-by-given-object (construct &key revision) (:documentation "Returns a list representing a triple that is the result of a given object.") @@ -319,8 +327,8 @@ (pred (when-do top (instance-of char :revision revision) (any-id top :revision revision)))) (when (and subj pred) - (list :subject subj - :predicate pred + (list :subject (embrace-uri subj) + :predicate (embrace-uri pred) :object (charvalue char) :literal-datatyp literal-datatype)))) ;;elephant returns names, occurences, and variants if any string @@ -355,9 +363,9 @@ (when-do plr (player orole :revision revision) (any-id plr :revision revision)))) (when (and obj-uri pred-uri subj-uri) - (list :subject subj-uri - :predicate pred-uri - :object obj-uri)))) + (list :subject (embrace-uri subj-uri) + :predicate (embrace-uri pred-uri) + :object (embrace-uri obj-uri))))) roles-by-oplayer))))) @@ -421,9 +429,9 @@ (when-do plr (player orole :revision revision) (any-id plr :revision revision)))) (when (and subj-uri pred-uri obj-uri) - (list :subject subj-uri - :predicate pred-uri - :object obj-uri)))) + (list :subject (embrace-uri subj-uri) + :predicate (embrace-uri pred-uri) + :object (embrace-uri obj-uri))))) roles-by-player)))))) @@ -469,8 +477,8 @@ (when-do top (instance-of name :revision revision) (any-id top :revision revision)))) (when (and subj pred) - (list :subject subj - :predicate pred + (list :subject (embrace-uri subj) + :predicate (embrace-uri pred) :object (charvalue name) :literal-datatype *xml-string*)))) names-by-literal)))))) @@ -509,8 +517,8 @@ (when-do top (instance-of occ :revision revision) (any-id top :revision revision)))) (when (and subj pred) - (list :subject subj - :predicate pred + (list :subject (embrace-uri subj) + :predicate (embrace-uri pred) :object (charvalue occ) :literal-datatype (datatype occ))))) all-occs)))))) @@ -641,15 +649,17 @@ #'(lambda(occ) (filter-occ-by-value occ literal-value literal-datatype)) occs-by-type))) - (subj-uri (any-id construct :revision revision))) + (subj-uri (when-do top-uri (any-id construct :revision revision) + top-uri))) (remove-null (map 'list #'(lambda(occ) (let ((pred-uri - (when-do type-top (instance-of occ :revision revision) + (when-do type-top + (instance-of occ :revision revision) (any-id type-top :revision revision)))) (when pred-uri - (list :subject subj-uri - :predicate pred-uri + (list :subject (embrace-uri subj-uri) + :predicate (embrace-uri pred-uri) :object (charvalue occ) :literal-datatype (datatype occ))))) all-occs))))) @@ -681,8 +691,8 @@ (when-do type-top (instance-of name :revision revision) (any-id type-top :revision revision)))) (when pred-uri - (list :subject subj-uri - :predicate pred-uri + (list :subject (embrace-uri subj-uri) + :predicate (embrace-uri pred-uri) :object (charvalue name) :literal-datatype *xml-string*)))) all-names))))) @@ -747,9 +757,9 @@ :revision revision) (any-id player-top :revision revision))))) (when (and pred-uri obj-uri) - (list :subject subj-uri - :predicate pred-uri - :object obj-uri))))) + (list :subject (embrace-uri subj-uri) + :predicate (embrace-uri pred-uri) + :object (embrace-uri obj-uri)))))) assocs))))) Modified: trunk/src/TM-SPARQL/sparql_filter.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_filter.lisp (original) +++ trunk/src/TM-SPARQL/sparql_filter.lisp Sun Dec 19 10:18:30 2010 @@ -24,7 +24,9 @@ (defparameter *supported-compare-operators* - (list "!=" "<=" ">=" "=" "<" ">") ;not the order is important! + (list "!=" "<=" ">=" "=" "<" ">") ;note the order is important! + ;the operators with length = 2 + ;must be listed first "Contains all supported binary operators.") @@ -36,6 +38,12 @@ (list "!" "+" "-") "Contains all supported unary operators") +(defparameter *allowed-filter-calls* + (append (list "one+" "one-" "progn" "or" "and" "not" "/=" "=" + ">" ">=" "<" "<=" "+" "-" "*" "/") + *supported-functions*)) + + (defun *2-compare-operators* () (remove-null (map 'list #'(lambda(op) @@ -88,37 +96,75 @@ (defgeneric parse-filter (construct query-string) (:documentation "A helper functions that returns a filter and the next-query - string in the form (:next-query string :filter object).") + string in the form (:next-query string + :filter-string object).") (:method ((construct SPARQL-Query) (query-string String)) ;note the order of the invacations is important! (let* ((result-set-boundings (set-boundings construct query-string)) (filter-string (getf result-set-boundings :filter-string)) (next-query (getf result-set-boundings :next-query)) + (original-filter-string + (subseq query-string 0 (- (length query-string) + (length next-query)))) (filter-string-unary-ops (set-unary-operators construct filter-string)) (filter-string-or-and-ops (set-or-and-operators construct filter-string-unary-ops - filter-string-unary-ops)) + original-filter-string)) (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-functions (set-functions construct filter-string-compare-ops))) - filter-string-functions))) + (list :next-query next-query + :filter-string (scan-filter-for-deprecated-calls + construct filter-string-functions original-filter-string))))) ;;TODO: implement - ;; *check if all functions that will be invoked are allowed ;; *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) +(defgeneric scan-filter-for-deprecated-calls (construct filter-string + original-filter) + (:documentation "Returns the passed filter-string or throws a + sparql-parser-error of there is an unallowed + function call.") + (:method ((construct SPARQL-Query) (filter-string String) + (original-filter String)) + (dotimes (idx (length filter-string) filter-string) + (when-do fun-name (return-function-name (subseq filter-string idx)) + (unless (string-starts-with-one-of fun-name *supported-functions*) + (error + (make-condition + 'exceptions:sparql-parser-error + :message (format nil "Invalid filter: the filter \"~a\" evaluated to \"~a\" which contains the depricated function ~a!" + filter-string original-filter fun-name)))))))) + + + +(defun return-function-name (filter-string) + "If the string starts with ( there is returned the function name + that is placed directly after the (." + (declare (String filter-string)) + (when (string-starts-with filter-string "(") + (let ((local-str (trim-whitespace-left (subseq filter-string 1))) + (whitespaces (map 'list #'string (white-space))) + (result "")) + (dotimes (idx (length local-str) result) + (let ((current-char (subseq local-str idx (1+ idx)))) + (if (string-starts-with-one-of + current-char (append whitespaces *supported-brackets*)) + (setf idx (length local-str)) + (push-string current-char result))))))) + + (defgeneric set-functions (construct filter-string) (:documentation "Transforms all supported functions of the form function(x, y) to (function x y).") @@ -695,7 +741,7 @@ (defun function-scope (str) - "If str starts with a supported function it there is given the entire substr + "If str starts with a supported function there is given the entire substr that is the scope of the function, i.e. the function name and all its variable including the closing )." (declare (String str)) Modified: trunk/src/base-tools/base-tools.lisp ============================================================================== --- trunk/src/base-tools/base-tools.lisp (original) +++ trunk/src/base-tools/base-tools.lisp Sun Dec 19 10:18:30 2010 @@ -510,14 +510,18 @@ result-idx)) -(defun return-if-starts-with (str to-be-matched &key from-end ignore-case) +(defun return-if-starts-with (str to-be-matched &key from-end ignore-case + ignore-leading-whitespace) "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 + (Boolean from-end ignore-case ignore-leading-whitespace)) + (let ((cleaned-str (if ignore-leading-whitespace + (trim-whitespace-left str) + str))) + (loop for try in to-be-matched + when (if from-end + (string-ends-with cleaned-str try :ignore-case ignore-case) + (string-starts-with cleaned-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 Sun Dec 19 10:18:30 2010 @@ -457,24 +457,24 @@ (first (tm-sparql::select-group q-obj-2))))) (obj-2 (second (tm-sparql::object-result (first (tm-sparql::select-group q-obj-2)))))) - (cond ((or (string= subj-1 "http://some.where/psis/author/goethe") - (string= subj-1 "http://some.where/psis/persons/goethe")) - (is (string= pred-1 "http://some.where/base-psis/written")) - (is (or (string= obj-1 "http://some.where/psis/poem/zauberlehrling") - (string= obj-1 "http://some.where/psis/der_zauberlehrling"))) - (is (string= subj-2 "http://some.where/base-psis/poem")) - (is (string= pred-2 "http://psi.topicmaps.org/iso13250/model/instance")) - (is (or (string= obj-2 "http://some.where/psis/poem/zauberlehrling") - (string= obj-2 "http://some.where/psis/der_zauberlehrling")))) - ((string= subj-1 "http://some.where/base-psis/poem") - (is (string= pred-2 "http://some.where/base-psis/written")) - (is (or (string= obj-1 "http://some.where/psis/poem/zauberlehrling") - (string= obj-1 "http://some.where/psis/der_zauberlehrling"))) - (is (or (string= subj-2 "http://some.where/psis/author/goethe") - (string= subj-2 "http://some.where/psis/persons/goethe"))) - (is (string= pred-1 "http://psi.topicmaps.org/iso13250/model/type")) - (is (or (string= obj-2 "http://some.where/psis/poem/zauberlehrling") - (string= obj-2 "http://some.where/psis/der_zauberlehrling")))) + (cond ((or (string= subj-1 "<http://some.where/psis/author/goethe>") + (string= subj-1 "<http://some.where/psis/persons/goethe>")) + (is (string= pred-1 "<http://some.where/base-psis/written>")) + (is (or (string= obj-1 "<http://some.where/psis/poem/zauberlehrling>") + (string= obj-1 "<http://some.where/psis/der_zauberlehrling>"))) + (is (string= subj-2 "<http://some.where/base-psis/poem>")) + (is (string= pred-2 "<http://psi.topicmaps.org/iso13250/model/instance>")) + (is (or (string= obj-2 "<http://some.where/psis/poem/zauberlehrling>") + (string= obj-2 "<http://some.where/psis/der_zauberlehrling>")))) + ((string= subj-1 "<http://some.where/base-psis/poem>") + (is (string= pred-2 "<http://some.where/base-psis/written>")) + (is (or (string= obj-1 "<http://some.where/psis/poem/zauberlehrling>") + (string= obj-1 "<http://some.where/psis/der_zauberlehrling>"))) + (is (or (string= subj-2 "<http://some.where/psis/author/goethe>") + (string= subj-2 "<http://some.where/psis/persons/goethe>"))) + (is (string= pred-1 "<http://psi.topicmaps.org/iso13250/model/type>")) + (is (or (string= obj-2 "<http://some.where/psis/poem/zauberlehrling>") + (string= obj-2 "<http://some.where/psis/der_zauberlehrling>")))) (t (is-true nil)))) (is (= (length (tm-sparql::subject-result @@ -485,13 +485,13 @@ (first (tm-sparql::select-group q-obj-3)))) 1)) (is (or (string= (first (tm-sparql::subject-result (first (tm-sparql::select-group q-obj-3)))) - "http://some.where/psis/author/goethe") + "<http://some.where/psis/author/goethe>") (string= (first (tm-sparql::subject-result (first (tm-sparql::select-group q-obj-3)))) - "http://some.where/psis/persons/goethe"))) + "<http://some.where/psis/persons/goethe>"))) (is (string= (first (tm-sparql::predicate-result (first (tm-sparql::select-group q-obj-3)))) - "http://some.where/base-psis/first-name")) + "<http://some.where/base-psis/first-name>")) (is (string= (first (tm-sparql::object-result (first (tm-sparql::select-group q-obj-3)))) "Johann Wolfgang")))))) @@ -547,27 +547,27 @@ (first (tm-sparql::select-group q-obj-1))))) (o-4 (fourth (tm-sparql::object-result (first (tm-sparql::select-group q-obj-1)))))) - (is (string= p-1 "http://some.where/base-psis/written")) - (is (string= p-2 "http://some.where/base-psis/written")) - (is (string= p-3 "http://some.where/base-psis/written")) - (is (string= p-4 "http://some.where/base-psis/written")) + (is (string= p-1 "<http://some.where/base-psis/written>")) + (is (string= p-2 "<http://some.where/base-psis/written>")) + (is (string= p-3 "<http://some.where/base-psis/written>")) + (is (string= p-4 "<http://some.where/base-psis/written>")) (is (or (not (set-exclusive-or - (list "http://some.where/psis/author/eichendorff" - "http://some.where/psis/author/schiller" - "http://some.where/psis/author/goethe") + (list "<http://some.where/psis/author/eichendorff>" + "<http://some.where/psis/author/schiller>" + "<http://some.where/psis/author/goethe>") (list s-1 s-2 s-3 s-4) :test #'string=)) (not (set-exclusive-or - (list "http://some.where/psis/author/eichendorff" - "http://some.where/psis/author/schiller" - "http://some.where/psis/persons/goethe") + (list "<http://some.where/psis/author/eichendorff>" + "<http://some.where/psis/author/schiller>" + "<http://some.where/psis/persons/goethe>") (list s-1 s-2 s-3 s-4) :test #'string=)))) (is-false (set-exclusive-or - (list "http://some.where/psis/poem/mondnacht" - "http://some.where/psis/poem/resignation" - "http://some.where/psis/poem/erlkoenig" - "http://some.where/psis/poem/zauberlehrling") + (list "<http://some.where/psis/poem/mondnacht>" + "<http://some.where/psis/poem/resignation>" + "<http://some.where/psis/poem/erlkoenig>" + "<http://some.where/psis/poem/zauberlehrling>") (list o-1 o-2 o-3 o-4) :test #'string=))) (is-true q-obj-2) @@ -595,47 +595,47 @@ (first (tm-sparql::select-group q-obj-2))))) (o-3 (third (tm-sparql::object-result (first (tm-sparql::select-group q-obj-2)))))) - (string= p-1 "http://some.where/base-psis/first-name") - (string= p-2 "http://some.where/base-psis/first-name") - (string= p-3 "http://some.where/base-psis/first-name") + (string= p-1 "<http://some.where/base-psis/first-name>") + (string= p-2 "<http://some.where/base-psis/first-name>") + (string= p-3 "<http://some.where/base-psis/first-name>") (cond ((string= o-1 "Johann Christoph Friedrich") - (is (string= s-1 "http://some.where/psis/author/schiller")) + (is (string= s-1 "<http://some.where/psis/author/schiller>")) (cond ((string= o-2 "Johann Wolfgang") - (is (or (string= s-2 "http://some.where/psis/author/goethe") - (string= s-2 "http://some.where/psis/persons/goethe"))) - (is (string= s-3 "http://some.where/psis/author/eichendorff")) + (is (or (string= s-2 "<http://some.where/psis/author/goethe>") + (string= s-2 "<http://some.where/psis/persons/goethe>"))) + (is (string= s-3 "<http://some.where/psis/author/eichendorff>")) (is (string= o-3 "Joseph Karl Benedikt"))) ((string= o-2 "Joseph Karl Benedikt") - (is (string= s-2 "http://some.where/psis/author/eichendorff")) - (is (or (string= s-3 "http://some.where/psis/author/goethe") - (string= s-3 "http://some.where/psis/persons/goethe"))) + (is (string= s-2 "<http://some.where/psis/author/eichendorff>")) + (is (or (string= s-3 "<http://some.where/psis/author/goethe>") + (string= s-3 "<http://some.where/psis/persons/goethe>"))) (is (string= o-3 "Johann Wolfgang"))) (t (is-true nil)))) ((string= o-1 "Johann Wolfgang") - (is (or (string= s-1 "http://some.where/psis/author/goethe") - (string= s-1 "http://some.where/psis/persons/goethe"))) + (is (or (string= s-1 "<http://some.where/psis/author/goethe>") + (string= s-1 "<http://some.where/psis/persons/goethe>"))) (cond ((string= o-2 "Johann Christoph Friedrich") - (is (string= s-2 "http://some.where/psis/author/schiller")) - (is (string= s-3 "http://some.where/psis/author/eichendorff")) + (is (string= s-2 "<http://some.where/psis/author/schiller>")) + (is (string= s-3 "<http://some.where/psis/author/eichendorff>")) (is (string= o-3 "Joseph Karl Benedikt"))) ((string= o-2 "Joseph Karl Benedikt") - (is (string= s-2 "http://some.where/psis/author/eichendorff")) - (is (string= s-3 "http://some.where/psis/author/schiller")) + (is (string= s-2 "<http://some.where/psis/author/eichendorff>")) + (is (string= s-3 "<http://some.where/psis/author/schiller>")) (is (string= o-3 "Johann Christoph Friedrich"))) (t (is-true nil)))) ((string= o-1 "Joseph Karl Benedikt") - (is (string= s-1 "http://some.where/psis/author/eichendorff")) + (is (string= s-1 "<http://some.where/psis/author/eichendorff>")) (cond ((string= o-2 "Johann Wolfgang") - (is (or (string= s-2 "http://some.where/psis/author/goethe") - (string= s-2 "http://some.where/psis/persons/goethe"))) - (is (string= s-3 "http://some.where/psis/author/schiller")) + (is (or (string= s-2 "<http://some.where/psis/author/goethe>") + (string= s-2 "<http://some.where/psis/persons/goethe>"))) + (is (string= s-3 "<http://some.where/psis/author/schiller>")) (is (string= o-3 "Johann Christoph Friedrich"))) ((string= o-2 "Johann Christoph Friedrich") - (is (string= s-2 "http://some.where/psis/author/schiller")) - (is (or (string= s-3 "http://some.where/psis/author/goethe") - (string= s-3 "http://some.where/psis/persons/goethe"))) + (is (string= s-2 "<http://some.where/psis/author/schiller>")) + (is (or (string= s-3 "<http://some.where/psis/author/goethe>") + (string= s-3 "<http://some.where/psis/persons/goethe>"))) (is (string= o-3 "Johann Wolfgang"))) (t (is-true nil)))) @@ -651,16 +651,16 @@ (first (tm-sparql::select-group q-obj-3)))) 1)) (is (or (string= (first (tm-sparql::subject-result (first (tm-sparql::select-group q-obj-3)))) - "http://some.where/psis/author/goethe") + "<http://some.where/psis/author/goethe>") (string= (first (tm-sparql::subject-result (first (tm-sparql::select-group q-obj-3)))) - "http://some.where/psis/persons/goethe"))) + "<http://some.where/psis/persons/goethe>"))) (is (string= (first (tm-sparql::predicate-result (first (tm-sparql::select-group q-obj-3)))) - "http://some.where/base-psis/written")) + "<http://some.where/base-psis/written>")) (is (string= (first (tm-sparql::object-result (first (tm-sparql::select-group q-obj-3)))) - "http://some.where/psis/poem/zauberlehrling")))))) + "<http://some.where/psis/poem/zauberlehrling>")))))) (test test-set-result-3 @@ -700,25 +700,25 @@ (first (tm-sparql::select-group q-obj-3)))) 0)) (is (or (string= (first (tm-sparql::subject-result (first (tm-sparql::select-group q-obj-1)))) - "http://some.where/psis/author/goethe") + "<http://some.where/psis/author/goethe>") (string= (first (tm-sparql::subject-result (first (tm-sparql::select-group q-obj-1)))) - "http://some.where/psis/persons/goethe"))) + "<http://some.where/psis/persons/goethe>"))) (is (string= (first (tm-sparql::predicate-result (first (tm-sparql::select-group q-obj-1)))) - "http://some.where/base-psis/author-info")) + "<http://some.where/base-psis/author-info>")) (is (string= (first (tm-sparql::object-result (first (tm-sparql::select-group q-obj-1)))) "http://de.wikipedia.org/wiki/Johann_Wolfgang_von_Goethe")) (is (string= (first (tm-sparql::subject-result (first (tm-sparql::select-group q-obj-4)))) - "http://some.where/psis/author/schiller")) + "<http://some.where/psis/author/schiller>")) (is (string= (first (tm-sparql::predicate-result (first (tm-sparql::select-group q-obj-4)))) - "http://some.where/base-psis/written")) + "<http://some.where/base-psis/written>")) (is (string= (first (tm-sparql::object-result (first (tm-sparql::select-group q-obj-4)))) - "http://some.where/psis/poem/resignation")))))) + "<http://some.where/psis/poem/resignation>")))))) (test test-set-result-4 @@ -749,91 +749,91 @@ (is (= (length (tm-sparql::subject-result (first (tm-sparql::select-group q-obj-3)))) 1)) (is-true (or (null (set-exclusive-or - (list "http://some.where/psis/author/goethe") + (list "<http://some.where/psis/author/goethe>") (tm-sparql::subject-result (first (tm-sparql::select-group q-obj-1))) :test #'string=)) (null (set-exclusive-or - (list "http://some.where/psis/persons/goethe") + (list "<http://some.where/psis/persons/goethe>") (tm-sparql::subject-result (first (tm-sparql::select-group q-obj-1))) :test #'string=)))) (let ((predicates (tm-sparql::predicate-result (first (tm-sparql::select-group q-obj-1))))) - (is (= (count "http://some.where/base-psis/written" predicates + (is (= (count "<http://some.where/base-psis/written>" predicates :test #'string=) 2)) - (is (= (count "http://some.where/base-psis/place" predicates + (is (= (count "<http://some.where/base-psis/place>" predicates :test #'string=) 1)) - (is (= (count "http://some.where/base-psis/first-name" predicates + (is (= (count "<http://some.where/base-psis/first-name>" predicates :test #'string=) 1)) - (is (= (count "http://some.where/base-psis/last-name" predicates + (is (= (count "<http://some.where/base-psis/last-name>" predicates :test #'string=) 1)) - (is (= (count "http://some.where/base-psis/author-info" predicates + (is (= (count "<http://some.where/base-psis/author-info>" predicates :test #'string=) 1)) - (is (= (count "http://psi.topicmaps.org/iso13250/model/type" predicates + (is (= (count "<http://psi.topicmaps.org/iso13250/model/type>" predicates :test #'string=) 1))) (let ((objects (tm-sparql::object-result (first (tm-sparql::select-group q-obj-1))))) - (is (= (count "http://some.where/psis/poem/erlkoenig" objects + (is (= (count "<http://some.where/psis/poem/erlkoenig>" objects :test #'string=) 1)) - (is (or (= (count "http://some.where/psis/poem/der_zauberlehrling" + (is (or (= (count "<http://some.where/psis/poem/der_zauberlehrling>" objects :test #'string=) 1) - (= (count "http://some.where/psis/poem/zauberlehrling" objects + (= (count "<http://some.where/psis/poem/zauberlehrling>" objects :test #'string=) 1))) - (is (or (= (count "http://some.where/base-psis/author" objects + (is (or (= (count "<http://some.where/base-psis/author>" objects :test #'string=) 1) - (= (count "http://some.where/base-psis/author-psi" objects + (= (count "<http://some.where/base-psis/author-psi>" objects :test #'string=) 1))) (is (= (count "http://de.wikipedia.org/wiki/Johann_Wolfgang_von_Goethe" objects :test #'string=) 1)) (is (= (count "von Goethe" objects :test #'string=) 1)) (is (= (count "Johann Wolfgang" objects :test #'string=) 1)) - (is (= (count "http://some.where/psis/region/frankfurt_am_main" + (is (= (count "<http://some.where/psis/region/frankfurt_am_main>" objects :test #'string=) 1))) (is-true (or (null (set-exclusive-or - (list "http://some.where/psis/poem/der_zauberlehrling") + (list "<http://some.where/psis/poem/der_zauberlehrling>") (tm-sparql::subject-result (first (tm-sparql::select-group q-obj-2))) :test #'string=)) (null (set-exclusive-or - (list "http://some.where/psis/poem/zauberlehrling") + (list "<http://some.where/psis/poem/zauberlehrling>") (tm-sparql::subject-result (first (tm-sparql::select-group q-obj-2))) :test #'string=)))) (let ((predicates (tm-sparql::predicate-result (first (tm-sparql::select-group q-obj-2))))) - (is (= (count "http://some.where/base-psis/writer" predicates + (is (= (count "<http://some.where/base-psis/writer>" predicates :test #'string=) 1)) - (is (= (count "http://some.where/base-psis/title" predicates + (is (= (count "<http://some.where/base-psis/title>" predicates :test #'string=) 1)) - (is (= (count "http://some.where/base-psis/poem-content" predicates + (is (= (count "<http://some.where/base-psis/poem-content>" predicates :test #'string=) 1)) - (is (= (count "http://psi.topicmaps.org/iso13250/model/type" predicates + (is (= (count "<http://psi.topicmaps.org/iso13250/model/type>" predicates :test #'string=) 1))) (let ((objects (tm-sparql::object-result (first (tm-sparql::select-group q-obj-2))))) - (is (or (= (count "http://some.where/psis/author/goethe" objects + (is (or (= (count "<http://some.where/psis/author/goethe>" objects :test #'string=) 1) - (= (count "http://some.where/psis/persons/goethe" objects + (= (count "<http://some.where/psis/persons/goethe>" objects :test #'string=) 1))) (is (= (count "Der Zauberlehrling" objects :test #'string=) 1)) - (is (= (count "http://some.where/base-psis/poem" + (is (= (count "<http://some.where/base-psis/poem>" objects :test #'string=) 1)) ;do not check the entire poem content => too long ) - (is (or (string= "http://some.where/psis/author/goethe" + (is (or (string= "<http://some.where/psis/author/goethe>" (first (tm-sparql::subject-result (first (tm-sparql::select-group q-obj-3))))) - (string= "http://some.where/psis/persons/goethe" + (string= "<http://some.where/psis/persons/goethe>" (first (tm-sparql::subject-result (first (tm-sparql::select-group q-obj-3))))))) - (is (string= "http://some.where/base-psis/written" + (is (string= "<http://some.where/base-psis/written>" (first (tm-sparql::predicate-result (first (tm-sparql::select-group q-obj-3)))))) - (is (or (string= "http://some.where/psis/poem/der_zauberlehrling" + (is (or (string= "<http://some.where/psis/poem/der_zauberlehrling>" (first (tm-sparql::object-result (first (tm-sparql::select-group q-obj-3))))) - (string= "http://some.where/psis/poem/zauberlehrling" + (string= "<http://some.where/psis/poem/zauberlehrling>" (first (tm-sparql::object-result (first (tm-sparql::select-group q-obj-3))))))))))) @@ -868,52 +868,52 @@ (first (tm-sparql::select-group q-obj-3)))) 0)) (is (= (length (tm-sparql::subject-result (second (tm-sparql::select-group q-obj-3)))) 1)) - (is (or (string= "http://some.where/psis/author/goethe" + (is (or (string= "<http://some.where/psis/author/goethe>" (first (tm-sparql::subject-result (first (tm-sparql::select-group q-obj-1))))) - (string= "http://some.where/psis/persons/goethe" + (string= "<http://some.where/psis/persons/goethe>" (first (tm-sparql::subject-result (first (tm-sparql::select-group q-obj-1))))))) - (is (string= "http://some.where/base-psis/first-name" + (is (string= "<http://some.where/base-psis/first-name>" (first (tm-sparql::predicate-result (first (tm-sparql::select-group q-obj-1)))))) (is (string= "Johann Wolfgang" (first (tm-sparql::object-result (first (tm-sparql::select-group q-obj-1)))))) - (is (or (string= "http://some.where/psis/author/goethe" + (is (or (string= "<http://some.where/psis/author/goethe>" (first (tm-sparql::subject-result (first (tm-sparql::select-group q-obj-2))))) - (string= "http://some.where/psis/persons/goethe" + (string= "<http://some.where/psis/persons/goethe>" (first (tm-sparql::subject-result (first (tm-sparql::select-group q-obj-2))))))) - (is (string= "http://some.where/base-psis/written" + (is (string= "<http://some.where/base-psis/written>" (first (tm-sparql::predicate-result (first (tm-sparql::select-group q-obj-2)))))) - (is (or (string= "http://some.where/psis/poem/zauberlehrling" + (is (or (string= "<http://some.where/psis/poem/zauberlehrling>" (first (tm-sparql::object-result (first (tm-sparql::select-group q-obj-2))))) - (string= "http://some.where/psis/poem/der_zauberlehrling" + (string= "<http://some.where/psis/poem/der_zauberlehrling>" (first (tm-sparql::object-result (first (tm-sparql::select-group q-obj-2))))) - (string= "http://some.where/psis/poem/erlkoenig" + (string= "<http://some.where/psis/poem/erlkoenig>" (first (tm-sparql::object-result (first (tm-sparql::select-group q-obj-2))))))) - (is (or (string= "http://some.where/psis/author/goethe" + (is (or (string= "<http://some.where/psis/author/goethe>" (second (tm-sparql::subject-result (first (tm-sparql::select-group q-obj-2))))) - (string= "http://some.where/psis/persons/goethe" + (string= "<http://some.where/psis/persons/goethe>" (second (tm-sparql::subject-result (first (tm-sparql::select-group q-obj-2))))))) - (is (string= "http://some.where/base-psis/written" + (is (string= "<http://some.where/base-psis/written>" (second (tm-sparql::predicate-result (first (tm-sparql::select-group q-obj-2)))))) - (is (or (string= "http://some.where/psis/poem/zauberlehrling" + (is (or (string= "<http://some.where/psis/poem/zauberlehrling>" (second (tm-sparql::object-result (first (tm-sparql::select-group q-obj-2))))) - (string= "http://some.where/psis/poem/der_zauberlehrling" + (string= "<http://some.where/psis/poem/der_zauberlehrling>" (second (tm-sparql::object-result (first (tm-sparql::select-group q-obj-2))))) - (string= "http://some.where/psis/poem/erlkoenig" + (string= "<http://some.where/psis/poem/erlkoenig>" (second (tm-sparql::object-result (first (tm-sparql::select-group q-obj-2))))))) (is-false (first (tm-sparql::subject-result @@ -922,13 +922,13 @@ (first (tm-sparql::select-group q-obj-3))))) (is-false (first (tm-sparql::object-result (first (tm-sparql::select-group q-obj-3))))) - (is (or (string= "http://some.where/psis/author/goethe" + (is (or (string= "<http://some.where/psis/author/goethe>" (first (tm-sparql::subject-result (second (tm-sparql::select-group q-obj-3))))) - (string= "http://some.where/psis/persons/goethe" + (string= "<http://some.where/psis/persons/goethe>" (first (tm-sparql::subject-result (second (tm-sparql::select-group q-obj-3))))))) - (is (string= "http://some.where/base-psis/last-name" + (is (string= "<http://some.where/base-psis/last-name>" (first (tm-sparql::predicate-result (second (tm-sparql::select-group q-obj-3)))))) (is (string= "von Goethe" @@ -965,22 +965,22 @@ (progn (is (= (length (getf (first (result q-obj-1)) :result)) 1)) (is (or (string= (first (getf (first (result q-obj-1)) :result)) - "http://some.where/psis/author/goethe") + "<http://some.where/psis/author/goethe>") (string= (first (getf (first (result q-obj-1)) :result)) - "http://some.where/psis/persons/goethe"))) + "<http://some.where/psis/persons/goethe>"))) (is (= (length (getf (second (result q-obj-1)) :result)) 1)) (is (string= (first (getf (second (result q-obj-1)) :result)) - "http://some.where/psis/poem/erlkoenig")) - (is (string= (getf (second (result q-obj-1)) :variable) "poems"))) + "<http://some.where/psis/poem/erlkoenig>")) + (is (string= (getf (second (result q-obj-1)) :variable) "<poems"))) (progn (is (= (length (getf (second (result q-obj-1)) :result)) 1)) (is (or (string= (first (getf (second (result q-obj-1)) :result)) - "http://some.where/psis/author/goethe") + "<http://some.where/psis/author/goethe>") (string= (first (getf (second (result q-obj-1)) :result)) - "http://some.where/psis/persons/goethe"))) + "<http://some.where/psis/persons/goethe>"))) (is (= (length (getf (first (result q-obj-1)) :result)) 1)) (is (string= (first (getf (first (result q-obj-1)) :result)) - "http://some.where/psis/poem/erlkoenig")) + "<http://some.where/psis/poem/erlkoenig>")) (is (string= (getf (first (result q-obj-1)) :variable) "poems")))) (is (= (length (result q-obj-2)) 2)) (if (string= (getf (first (result q-obj-2)) :variable) "titles") @@ -1000,19 +1000,19 @@ (getf (first (result q-obj-2)) :result) :test #'string=)) (string= (getf (second (result q-obj-2)) :variable) "poems") (is-true - (find "http://some.where/psis/poem/mondnacht" + (find "<http://some.where/psis/poem/mondnacht>" (getf (second (result q-obj-2)) :result) :test #'string=)) (is-true - (find "http://some.where/psis/poem/resignation" + (find "<http://some.where/psis/poem/resignation>" (getf (second (result q-obj-2)) :result) :test #'string=)) (is-true - (find "http://some.where/psis/poem/erlkoenig" + (find "<http://some.where/psis/poem/erlkoenig>" (getf (second (result q-obj-2)) :result) :test #'string=)) (is-true (or - (find "http://some.where/psis/poem/zauberlehrling" + (find "<http://some.where/psis/poem/zauberlehrling>" (getf (second (result q-obj-2)) :result) :test #'string=) - (find "http://some.where/psis/poem/der_zauberlehrling" + (find "<http://some.where/psis/poem/der_zauberlehrling>" (getf (second (result q-obj-2)) :result) :test #'string=)))) (progn (is (= (length (getf (second (result q-obj-2)) :result)) 4)) @@ -1030,19 +1030,19 @@ (getf (second (result q-obj-2)) :result) :test #'string=)) (string= (getf (first (result q-obj-2)) :variable) "poems") (is-true - (find "http://some.where/psis/poem/mondnacht" + (find "<http://some.where/psis/poem/mondnacht>" (getf (first (result q-obj-2)) :result) :test #'string=)) (is-true - (find "http://some.where/psis/poem/resignation" + (find "<http://some.where/psis/poem/resignation>" (getf (first (result q-obj-2)) :result) :test #'string=)) (is-true - (find "http://some.where/psis/poem/erlkoenig" + (find "<http://some.where/psis/poem/erlkoenig>" (getf (first (result q-obj-2)) :result) :test #'string=)) (is-true (or - (find "http://some.where/psis/poem/zauberlehrling" + (find "<http://some.where/psis/poem/zauberlehrling>" (getf (first (result q-obj-2)) :result) :test #'string=) - (find "http://some.where/psis/poem/der_zauberlehrling" + (find "<http://some.where/psis/poem/der_zauberlehrling>" (getf (first (result q-obj-2)) :result) :test #'string=)))))))))

1 0

[isidorus-cvs] r374 - in trunk/src: TM-SPARQL base-tools unit_tests
by Lukas Giessmann 18 Dec '10

18 Dec '10

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))))))"))))

1 0

[isidorus-cvs] r373 - trunk/src/unit_tests
by Lukas Giessmann 18 Dec '10

18 Dec '10

Author: lgiessmann Date: Sat Dec 18 00:43:43 2010 New Revision: 373 Log: TM-SPARQL: added unit-tests for all compare-operators Modified: trunk/src/unit_tests/sparql_test.lisp 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 00:43:43 2010 @@ -35,7 +35,8 @@ :test-set-unary-operators :test-set-or-and-operators :test-set-*-and-/-operators - :test-set-+-and---operators)) + :test-set-+-and---operators + :test-set-compare-operators)) (in-package :sparql-test) @@ -1315,6 +1316,119 @@ "(and(prognisLITERAL((/(progn(*(progn(+1\"(13+4*5))\"))3))4)))(progn(progn(or(progn12=(+13(*1415)))(progn(*23)=1)))))")) (is (string= (string-replace result-5-4 " " "") "(or(progn(progn(+12)>=3))(progn(progn(+(+(progn(-24))5)6))=3))")))) + + +(test test-set-compare-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)}") + (str-3 "(x < a || ( a = 4 && 4 = x / y + (+1)) && -1)}") + (str-4 "isLITERAL(((1 + '(13+4*5))') * 3) / 4) && (12 = 13 + 14 * 15 || 2 * 3 = 1)}") + (str-5 "(1 + 2 >= 3) || ((2 - 4) + 5 + 6) = 3}") + (str-6 "2 > 1 <= 0 != 99 || true}") + (result-1 + (getf (tm-sparql::set-boundings dummy-object str-1) :filter-string)) + (result-1-1 + (tm-sparql::set-unary-operators dummy-object result-1)) + (result-1-2 + (tm-sparql::set-or-and-operators dummy-object result-1-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-2 + (getf (tm-sparql::set-boundings dummy-object str-2) :filter-string)) + (result-2-1 + (tm-sparql::set-unary-operators dummy-object result-2)) + (result-2-2 + (tm-sparql::set-or-and-operators dummy-object result-2-1 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-3 + (getf (tm-sparql::set-boundings dummy-object str-3) :filter-string)) + (result-3-1 + (tm-sparql::set-unary-operators dummy-object result-3)) + (result-3-2 + (tm-sparql::set-or-and-operators dummy-object result-3-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-4 + (getf (tm-sparql::set-boundings dummy-object str-4) :filter-string)) + (result-4-1 + (tm-sparql::set-unary-operators dummy-object result-4)) + (result-4-2 + (tm-sparql::set-or-and-operators dummy-object result-4-1 result-4)) + (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-5 + (getf (tm-sparql::set-boundings dummy-object str-5) :filter-string)) + (result-5-1 + (tm-sparql::set-unary-operators dummy-object result-5)) + (result-5-2 + (tm-sparql::set-or-and-operators dummy-object result-5-1 result-5)) + (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-6 + (getf (tm-sparql::set-boundings dummy-object str-6) :filter-string)) + (result-6-1 + (tm-sparql::set-unary-operators dummy-object result-6)) + (result-6-2 + (tm-sparql::set-or-and-operators dummy-object result-6-1 result-6)) + (result-6-3 + (tm-sparql::set-*-and-/-operators dummy-object result-6-2)) + (result-6-4 + (tm-sparql::set-+-and---operators dummy-object result-6-3)) + (result-6-5 + (tm-sparql::set-compare-operators dummy-object result-6-4))) + (is-true result-1) (is-true result-1-1) + (is-true result-1-2) (is-true result-1-3) + (is-true result-2) (is-true result-2-1) + (is-true result-2-2) (is-true result-2-3) + (is-true result-3) (is-true result-3-1) + (is-true result-3-2) (is-true result-3-3) + (is-true result-4) (is-true result-4-1) + (is-true result-4-2) (is-true result-4-3) + (is-true result-1-4) (is-true result-2-4) + (is-true result-3-4) (is-true result-4-4) + (is-true result-5) (is-true result-5-1) + (is-true result-5-2) (is-true result-5-3) + (is-true result-5-4) (is-true result-1-5) + (is-true result-2-5) (is-true result-3-5) + (is-true result-4-5) (is-true result-5-5) + (is-true result-6-1) (is-true result-6-2) + (is-true result-6-3) (is-true result-6-4) + (is-true result-6-5) + (is (string= (string-replace result-1-5 " " "") + "(or(progn(and(progn(=x(+a(*bc))))(progn(=y(+(/a3)(*b2))))))(progn(=0(+(-1214)(/(*23)3)))))")) + (is (string= (string-replace result-2-5 " " "") + "(and(progn(=x2))(progn(+(+(-(+(*(progn(+22))2)(/(*124)2))10)(*2(progn(-123))))(progn(*123)))))")) + (is (string= (string-replace result-3-4 " " "") + "(progn(and(progn(or(prognx<a)(progn(progn(and(progna=4)(progn4=(+(/xy)(progn(one+1)))))))))(progn(one-1))))")) + (is (string= (string-replace result-4-5 " " "") + "(and(prognisLITERAL((/(progn(*(progn(+1\"(13+4*5))\"))3))4)))(progn(progn(or(progn(=12(+13(*1415))))(progn(=(*23)1))))))")) + (is (string= (string-replace result-5-5 " " "") + "(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))"))))

1 0

[isidorus-cvs] r372 - trunk/src/TM-SPARQL
by Lukas Giessmann 18 Dec '10

18 Dec '10

Author: lgiessmann Date: Sat Dec 18 00:22:09 2010 New Revision: 372 Log: TM-SPARQL: added the handling of the >, <, >=, <=, = and != operators Modified: trunk/src/TM-SPARQL/sparql_filter.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 00:22:09 2010 @@ -24,7 +24,7 @@ (defparameter *supported-compare-operators* - (list "=" "!=" "<" "<=" ">" ">=") + (list "!=" "<=" ">=" "=" "<" ">") ;not the order is important! "Contains all supported binary operators.") @@ -36,6 +36,22 @@ (list "!" "+" "-") "Contains all supported unary operators") +(defun *2-compare-operators* () + (remove-null + (map 'list #'(lambda(op) + (when (= (length op) 2) + op)) + *supported-compare-operators*))) + + +(defun *1-compare-operators* () + (remove-null + (map 'list #'(lambda(op) + (when (= (length op) 1) + op)) + *supported-compare-operators*))) + + (defun *supported-arithmetic-operators* () (append *supported-primary-arithmetic-operators* *supported-secundary-arithmetic-operators*)) @@ -74,19 +90,20 @@ (:documentation "A helper functions that returns a filter and the next-query string in the form (:next-query string :filter object).") (:method ((construct SPARQL-Query) (query-string String)) + ;note the order of the invacations is important! (let* ((result-set-boundings (set-boundings construct query-string)) (filter-string (getf result-set-boundings :filter-string)) (next-query (getf result-set-boundings :next-query)) (filter-string-unary-ops (set-unary-operators construct filter-string)) - ;;TODO: encapsulate all binary operator mehtod in the method set-binary-ops (filter-string-or-and-ops (set-or-and-operators construct filter-string-unary-ops filter-string-unary-ops)) (filter-string-arithmetic-ops (set-arithmetic-operators construct filter-string-or-and-ops)) - ) - filter-string-arithmetic-ops))) + (filter-string-compare-ops + (set-compare-operators construct filter-string-arithmetic-ops))) + filter-string-compare-ops))) ;;TODO: implement ;; **replace () by (progn ) ;; **replace ', """, ''' by " @@ -95,8 +112,8 @@ ;; **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 @@ -107,6 +124,106 @@ ;; this method should also have a let with (true t) and (false nil) +(defvar *tmp* 0) +(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) + (let* ((op-str (if (string-starts-with-one-of + (subseq filter-string op-pos) + (*2-compare-operators*)) + (subseq filter-string op-pos (+ 2 op-pos)) + (subseq filter-string op-pos (1+ op-pos)))) + (left-str (subseq filter-string 0 op-pos)) + (right-str (subseq filter-string (+ (length op-str) op-pos))) + (left-scope (find-compare-left-scope left-str)) + (right-scope (find-compare-right-scope right-str)) + (modified-str + (concatenate + 'string (subseq left-str 0 (- (length left-str) + (length left-scope))) + "(" op-str " " left-scope " " right-scope ")" + (subseq right-str (length right-scope))))) + (set-compare-operators construct modified-str)))))) + + +(defun find-compare-operators (filter-string) + "Returns the idx of the first found =, !=, <, >, <= or >= operator. + It must not be in a literal string or directly after a (." + (declare (String filter-string)) + (let* ((first-pos + (search-first-ignore-literals *supported-compare-operators* + filter-string)) + (delta (if first-pos + (if (string-starts-with-one-of + (subseq filter-string first-pos) + (*2-compare-operators*)) + 2 + 1) + 1))) + (when first-pos + (let ((left-part (trim-whitespace-right (subseq filter-string 0 first-pos)))) + (if (not (string-ends-with-one-of + left-part (append (*1-compare-operators*) (list "(")))) + first-pos + (let ((next-pos + (find-compare-operators (subseq filter-string (+ delta first-pos))))) + (when next-pos + (+ delta first-pos next-pos)))))))) + + +(defun find-compare-left-scope (left-string) + "Returns the string that is the left part of the binary scope." + (declare (String left-string)) + (let* ((first-bracket + (let ((inner-value (search-first-unclosed-paranthesis left-string))) + (when inner-value + (+ inner-value (1+ (length (name-after-paranthesis + (subseq left-string inner-value)))))))) + (paranthesis-pair-idx + (let* ((cleaned-str (trim-whitespace-right left-string)) + (bracket-scope (reverse-bracket-scope cleaned-str))) + (when bracket-scope + (- (- (length left-string) + (- (length left-string) (length cleaned-str))) + (length bracket-scope))))) + (start-idx (or first-bracket paranthesis-pair-idx 0))) + (subseq left-string start-idx))) + + +(defun find-compare-right-scope (right-string) + "Returns the string that is the right part of the binary scope." + (declare (String right-string)) + (let* ((first-pos + (search-first-ignore-literals *supported-compare-operators* + right-string)) + (first-bracket + (let ((inner-value (search-first-unopened-paranthesis right-string))) + (when inner-value (1+ inner-value)))) + (paranthesis-pair-idx + (let* ((cleaned-str (trim-whitespace-left right-string)) + (bracket-scope (bracket-scope cleaned-str))) + (when bracket-scope + (+ (- (length right-string) (length cleaned-str)) + (length bracket-scope))))) + (end-idx (cond (paranthesis-pair-idx + paranthesis-pair-idx) + ((and first-pos first-bracket) + (min first-pos first-bracket)) + (first-pos first-pos) + (first-bracket first-bracket) + (t (if (= (length right-string) 0) + 0 + (length right-string)))))) + (subseq right-string 0 end-idx))) + + (defgeneric set-arithmetic-operators (construct filter-string) (:documentation "Transforms the +, -, *, / operators in the filter string to the the corresponding lisp functions.") @@ -237,7 +354,6 @@ (defun find-+--left-scope (left-string) "Returns the string that is the left part of the binary scope." (declare (String left-string)) - ;TODO: adapt (let* ((first-bracket (let ((inner-value (search-first-unclosed-paranthesis left-string))) (when inner-value @@ -245,10 +361,8 @@ (subseq left-string inner-value)))))))) (other-anchor (let ((inner-value - (search-first-ignore-literals - (append *supported-secundary-arithmetic-operators* - *supported-compare-operators*) - left-string :from-end t))) + (search-first-ignore-literals *supported-compare-operators* + left-string :from-end t))) (when inner-value (1+ inner-value)))) (paranthesis-pair-idx @@ -271,7 +385,6 @@ (defun find-+--right-scope (right-string) "Returns the string that is the right part of the binary scope." (declare (String right-string)) - ;TODO: adapt (let* ((first-pos (search-first-ignore-literals (append (*supported-arithmetic-operators*) *supported-compare-operators*)

1 0

[isidorus-cvs] r371 - in trunk/src: TM-SPARQL unit_tests
by Lukas Giessmann 18 Dec '10

18 Dec '10

Author: lgiessmann Date: Fri Dec 17 22:55:28 2010 New Revision: 371 Log: TM-SPARQL: added some unit-tests for the binary + and - operators Modified: trunk/src/TM-SPARQL/sparql_filter.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 Fri Dec 17 22:55:28 2010 @@ -95,7 +95,7 @@ ;; **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) @@ -231,9 +231,6 @@ (length left-scope))) "(" op-str " " left-scope " " right-scope ")" (subseq right-str (length right-scope))))) - ;(format t "fs:_~a_~%os:_~a_~%ls:_~a_~%lc:_~a_~%rs:_~a_~%rc:_~a_~%ms:_~a_~%~%" - ;filter-string op-str left-str left-scope right-str right-scope - ;modified-str) (set-+-and---operators construct modified-str)))))) Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Fri Dec 17 22:55:28 2010 @@ -34,7 +34,8 @@ :test-set-boundings :test-set-unary-operators :test-set-or-and-operators - :test-set-*-and-/-operators)) + :test-set-*-and-/-operators + :test-set-+-and---operators)) (in-package :sparql-test) @@ -1231,6 +1232,89 @@ "(progn(and(progn(or(prognx<a)(progn(progn(and(progna=4)(progn4=(/xy)+(progn(one+1))))))))(progn(one-1))))")) (is (string= (string-replace result-4-3 " " "") "(and(prognisLITERAL((/(progn(*(progn1+\"(13+4*5))\")3))4)))(progn(progn(or(progn12=13+(*1415))(progn(*23)=1)))))")))) + + +(test test-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)}") + (str-3 "(x < a || ( a = 4 && 4 = x / y + (+1)) && -1)}") + (str-4 "isLITERAL(((1 + '(13+4*5))') * 3) / 4) && (12 = 13 + 14 * 15 || 2 * 3 = 1)}") + (str-5 "(1 + 2 >= 3) || ((2 - 4) + 5 + 6) = 3}") + (result-1 + (getf (tm-sparql::set-boundings dummy-object str-1) :filter-string)) + (result-1-1 + (tm-sparql::set-unary-operators dummy-object result-1)) + (result-1-2 + (tm-sparql::set-or-and-operators dummy-object result-1-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-2 + (getf (tm-sparql::set-boundings dummy-object str-2) :filter-string)) + (result-2-1 + (tm-sparql::set-unary-operators dummy-object result-2)) + (result-2-2 + (tm-sparql::set-or-and-operators dummy-object result-2-1 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-3 + (getf (tm-sparql::set-boundings dummy-object str-3) :filter-string)) + (result-3-1 + (tm-sparql::set-unary-operators dummy-object result-3)) + (result-3-2 + (tm-sparql::set-or-and-operators dummy-object result-3-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-4 + (getf (tm-sparql::set-boundings dummy-object str-4) :filter-string)) + (result-4-1 + (tm-sparql::set-unary-operators dummy-object result-4)) + (result-4-2 + (tm-sparql::set-or-and-operators dummy-object result-4-1 result-4)) + (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-5 + (getf (tm-sparql::set-boundings dummy-object str-5) :filter-string)) + (result-5-1 + (tm-sparql::set-unary-operators dummy-object result-5)) + (result-5-2 + (tm-sparql::set-or-and-operators dummy-object result-5-1 result-5)) + (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))) + (is-true result-1) (is-true result-1-1) + (is-true result-1-2) (is-true result-1-3) + (is-true result-2) (is-true result-2-1) + (is-true result-2-2) (is-true result-2-3) + (is-true result-3) (is-true result-3-1) + (is-true result-3-2) (is-true result-3-3) + (is-true result-4) (is-true result-4-1) + (is-true result-4-2) (is-true result-4-3) + (is-true result-1-4) (is-true result-2-4) + (is-true result-3-4) (is-true result-4-4) + (is-true result-5) (is-true result-5-1) + (is-true result-5-2) (is-true result-5-3) + (is-true result-5-4) + (is (string= (string-replace result-1-4 " " "") + "(or(progn(and(prognx=(+a(*bc)))(progny=(+(/a3)(*b2)))))(progn0=(+(-1214)(/(*23)3))))")) + (is (string= (string-replace result-2-4 " " "") + "(and(prognx=2)(progn(+(+(-(+(*(progn(+22))2)(/(*124)2))10)(*2(progn(-123))))(progn(*123)))))")) + (is (string= (string-replace result-3-4 " " "") + "(progn(and(progn(or(prognx<a)(progn(progn(and(progna=4)(progn4=(+(/xy)(progn(one+1)))))))))(progn(one-1))))")) + (is (string= (string-replace result-4-4 " " "") + "(and(prognisLITERAL((/(progn(*(progn(+1\"(13+4*5))\"))3))4)))(progn(progn(or(progn12=(+13(*1415)))(progn(*23)=1)))))")) + (is (string= (string-replace result-5-4 " " "") + "(or(progn(progn(+12)>=3))(progn(progn(+(+(progn(-24))5)6))=3))"))))

1 0

[isidorus-cvs] r370 - trunk/src/TM-SPARQL
by Lukas Giessmann 18 Dec '10

18 Dec '10

Author: lgiessmann Date: Fri Dec 17 22:30:41 2010 New Revision: 370 Log: TM-SPARQL: added the handling of the binary + and - operators Modified: trunk/src/TM-SPARQL/sparql_filter.lisp Modified: trunk/src/TM-SPARQL/sparql_filter.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_filter.lisp (original) +++ trunk/src/TM-SPARQL/sparql_filter.lisp Fri Dec 17 22:30:41 2010 @@ -119,7 +119,9 @@ "Returns the idx of the first found * or / operator. It must not be in a literal string or directly after a (." (declare (String filter-string)) - (let ((first-pos (search-first-ignore-literals (list "*" "/") filter-string))) + (let ((first-pos + (search-first-ignore-literals *supported-primary-arithmetic-operators* + filter-string))) (when first-pos (let ((left-part (trim-whitespace-right (subseq filter-string 0 first-pos)))) (if (not (string-ends-with left-part "(")) @@ -162,8 +164,7 @@ (other-anchor (let ((inner-value (search-first-ignore-literals - (append *supported-join-operators* - *supported-secundary-arithmetic-operators* + (append *supported-secundary-arithmetic-operators* *supported-compare-operators*) left-string :from-end t))) (when inner-value @@ -189,8 +190,7 @@ "Returns the string that is the right part of the binary scope." (declare (String right-string)) (let* ((first-pos (search-first-ignore-literals - (append *supported-join-operators* - (*supported-arithmetic-operators*) + (append (*supported-arithmetic-operators*) *supported-compare-operators*) right-string)) (first-bracket @@ -217,8 +217,104 @@ (:documentation "Transforms the +, - operators in the filter string to the the corresponding lisp functions.") (:method ((construct SPARQL-Query) (filter-string String)) - ;TODO: implement - filter-string)) + (let ((op-pos (find-+--operators filter-string))) + (if (or (not op-pos) (= *tmp* 5)) + 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))) + (left-scope (find-+--left-scope left-str)) + (right-scope (find-+--right-scope right-str)) + (modified-str + (concatenate + 'string (subseq left-str 0 (- (length left-str) + (length left-scope))) + "(" op-str " " left-scope " " right-scope ")" + (subseq right-str (length right-scope))))) + ;(format t "fs:_~a_~%os:_~a_~%ls:_~a_~%lc:_~a_~%rs:_~a_~%rc:_~a_~%ms:_~a_~%~%" + ;filter-string op-str left-str left-scope right-str right-scope + ;modified-str) + (set-+-and---operators construct modified-str)))))) + + +(defun find-+--left-scope (left-string) + "Returns the string that is the left part of the binary scope." + (declare (String left-string)) + ;TODO: adapt + (let* ((first-bracket + (let ((inner-value (search-first-unclosed-paranthesis left-string))) + (when inner-value + (+ inner-value (1+ (length (name-after-paranthesis + (subseq left-string inner-value)))))))) + (other-anchor + (let ((inner-value + (search-first-ignore-literals + (append *supported-secundary-arithmetic-operators* + *supported-compare-operators*) + left-string :from-end t))) + (when inner-value + (1+ inner-value)))) + (paranthesis-pair-idx + (let* ((cleaned-str (trim-whitespace-right left-string)) + (bracket-scope (reverse-bracket-scope cleaned-str))) + (when bracket-scope + (- (- (length left-string) + (- (length left-string) (length cleaned-str))) + (length bracket-scope))))) + (start-idx (cond (paranthesis-pair-idx + paranthesis-pair-idx) + ((and first-bracket other-anchor) + (max first-bracket other-anchor)) + ((or first-bracket other-anchor) + (or first-bracket other-anchor)) + (t 0)))) + (subseq left-string start-idx))) + + +(defun find-+--right-scope (right-string) + "Returns the string that is the right part of the binary scope." + (declare (String right-string)) + ;TODO: adapt + (let* ((first-pos (search-first-ignore-literals + (append (*supported-arithmetic-operators*) + *supported-compare-operators*) + right-string)) + (first-bracket + (let ((inner-value (search-first-unopened-paranthesis right-string))) + (when inner-value (1+ inner-value)))) + (paranthesis-pair-idx + (let* ((cleaned-str (trim-whitespace-left right-string)) + (bracket-scope (bracket-scope cleaned-str))) + (when bracket-scope + (+ (- (length right-string) (length cleaned-str)) + (length bracket-scope))))) + (end-idx (cond (paranthesis-pair-idx + paranthesis-pair-idx) + ((and first-pos first-bracket) + (min first-pos first-bracket)) + (first-pos first-pos) + (first-bracket first-bracket) + (t (if (= (length right-string) 0) + (1- (length right-string))))))) + (subseq right-string 0 end-idx))) + + +(defun find-+--operators (filter-string) + "Returns the idx of the first found + or - operator. + It must not be in a literal string or directly after a (." + (declare (String filter-string)) + (let ((first-pos + (search-first-ignore-literals *supported-secundary-arithmetic-operators* + filter-string))) + (when first-pos + (let ((left-part (trim-whitespace-right (subseq filter-string 0 first-pos)))) + (if (and (not (string-ends-with left-part "(one")) + (not (string-ends-with left-part "("))) + first-pos + (let ((next-pos + (find-+--operators (subseq filter-string (1+ first-pos))))) + (when next-pos + (+ 1 first-pos next-pos)))))))) (defgeneric set-or-and-operators (construct filter-string original-filter-string)

1 0

[isidorus-cvs] r369 - in trunk/src: TM-SPARQL base-tools unit_tests
by Lukas Giessmann 18 Dec '10

18 Dec '10

Author: lgiessmann Date: Fri Dec 17 19:53:11 2010 New Revision: 369 Log: added the handling of * and / => added some unit-tests; fixed a bug with right-scope of && and || operators 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 Fri Dec 17 19:53:11 2010 @@ -15,17 +15,40 @@ "Contains all supported SPARQL-functions") -(defparameter *supported-binary-operators* - (list "||" "&&" "=" "!=" "<" "<=" ">" ">=" "+" "-" "*" "/") +(defparameter *supported-primary-arithmetic-operators* + (list "*" "/") "Contains all supported arithmetic operators.") + + +(defparameter *supported-secundary-arithmetic-operators* + (list "+" "-") "Contains all supported arithmetic operators.") + + +(defparameter *supported-compare-operators* + (list "=" "!=" "<" "<=" ">" ">=") "Contains all supported binary operators.") +(defparameter *supported-join-operators* + (list "||" "&&") "Contains all supported join operators.") + + (defparameter *supported-unary-operators* (list "!" "+" "-") "Contains all supported unary operators") +(defun *supported-arithmetic-operators* () + (append *supported-primary-arithmetic-operators* + *supported-secundary-arithmetic-operators*)) + + +(defun *supported-binary-operators* () + (append (*supported-arithmetic-operators*) + *supported-compare-operators* + *supported-join-operators*)) + + (defun *supported-operators* () - (union *supported-binary-operators* *supported-unary-operators* + (union (*supported-binary-operators*) *supported-unary-operators* :test #'string=)) @@ -56,37 +79,146 @@ (next-query (getf result-set-boundings :next-query)) (filter-string-unary-ops (set-unary-operators construct filter-string)) + ;;TODO: encapsulate all binary operator mehtod in the method set-binary-ops (filter-string-or-and-ops (set-or-and-operators construct filter-string-unary-ops filter-string-unary-ops)) - (filter-string-binary-ops - (set-binary-operators construct filter-string-or-and-ops)) - - )))) + (filter-string-arithmetic-ops + (set-arithmetic-operators construct filter-string-or-and-ops)) + ) + filter-string-arithmetic-ops))) ;;TODO: implement ;; **replace () by (progn ) ;; **replace ', """, ''' by " ;; **replace !x by (not x) - ;; **replace +x by (1+ x) - ;; **replace -x by (1- 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 - ;; *add a let with all variables that are used: every variable with $ and ? prefix - ;; *add a let with (true t) and (false nil) ;; *embrace the final result uris in <> => unit-tests - ;; *create and store this filter object + ;; *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) + + +(defgeneric set-arithmetic-operators (construct filter-string) + (:documentation "Transforms the +, -, *, / operators in the filter + string to the the corresponding lisp functions.") + (:method ((construct SPARQL-Query) (filter-string String)) + (let ((filter-string-*/ (set-*-and-/-operators construct filter-string))) + (set-+-and---operators construct filter-string-*/)))) + + +(defun find-*/-operators (filter-string) + "Returns the idx of the first found * or / operator. + It must not be in a literal string or directly after a (." + (declare (String filter-string)) + (let ((first-pos (search-first-ignore-literals (list "*" "/") 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-*/-operators (subseq filter-string (1+ first-pos))))) + (when next-pos + (+ 1 first-pos next-pos)))))))) + + +(defgeneric set-*-and-/-operators (construct filter-string) + (:documentation "Transforms the *, / operators in the filter + string to the the corresponding lisp functions.") + (:method ((construct SPARQL-Query) (filter-string String)) + (let ((op-pos (find-*/-operators 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))) + (left-scope (find-*/-left-scope left-str)) + (right-scope (find-*/-right-scope right-str)) + (modified-str + (concatenate + 'string (subseq left-str 0 (- (length left-str) + (length left-scope))) + "(" op-str " " left-scope " " right-scope ")" + (subseq right-str (length right-scope))))) + (set-*-and-/-operators construct modified-str)))))) + + +(defun find-*/-left-scope (left-string) + "Returns the string that is the left part of the binary scope." + (declare (String left-string)) + (let* ((first-bracket + (let ((inner-value (search-first-unclosed-paranthesis left-string))) + (when inner-value + (+ inner-value (1+ (length (name-after-paranthesis + (subseq left-string inner-value)))))))) + (other-anchor + (let ((inner-value + (search-first-ignore-literals + (append *supported-join-operators* + *supported-secundary-arithmetic-operators* + *supported-compare-operators*) + left-string :from-end t))) + (when inner-value + (1+ inner-value)))) + (paranthesis-pair-idx + (let* ((cleaned-str (trim-whitespace-right left-string)) + (bracket-scope (reverse-bracket-scope cleaned-str))) + (when bracket-scope + (- (- (length left-string) + (- (length left-string) (length cleaned-str))) + (length bracket-scope))))) + (start-idx (cond (paranthesis-pair-idx + paranthesis-pair-idx) + ((and first-bracket other-anchor) + (max first-bracket other-anchor)) + ((or first-bracket other-anchor) + (or first-bracket other-anchor)) + (t 0)))) + (subseq left-string start-idx))) + + +(defun find-*/-right-scope (right-string) + "Returns the string that is the right part of the binary scope." + (declare (String right-string)) + (let* ((first-pos (search-first-ignore-literals + (append *supported-join-operators* + (*supported-arithmetic-operators*) + *supported-compare-operators*) + right-string)) + (first-bracket + (let ((inner-value (search-first-unopened-paranthesis right-string))) + (when inner-value (1+ inner-value)))) + (paranthesis-pair-idx + (let* ((cleaned-str (trim-whitespace-left right-string)) + (bracket-scope (bracket-scope cleaned-str))) + (when bracket-scope + (+ (- (length right-string) (length cleaned-str)) + (length bracket-scope))))) + (end-idx (cond (paranthesis-pair-idx + paranthesis-pair-idx) + ((and first-pos first-bracket) + (min first-pos first-bracket)) + (first-pos first-pos) + (first-bracket first-bracket) + (t (if (= (length right-string) 0) + (1- (length right-string))))))) + (subseq right-string 0 end-idx))) -(defgeneric set-binary-operators (construct filter-string) - (:documentation "Transforms the =, !=, <, >, <=, >=, +, -, *, / operators - in the filter string to the the lisp =, /=, <, >, <=, >=, - +, -, * and / functions.") +(defgeneric set-+-and---operators (construct filter-string) + (:documentation "Transforms the +, - operators in the filter + string to the the corresponding lisp functions.") (:method ((construct SPARQL-Query) (filter-string String)) ;TODO: implement - )) + filter-string)) (defgeneric set-or-and-operators (construct filter-string original-filter-string) @@ -94,7 +226,8 @@ the the lisp or and and functions.") (:method ((construct SPARQL-Query) (filter-string String) (original-filter-string String)) - (let ((op-pos (search-first-ignore-literals (list "||" "&&") filter-string))) + (let ((op-pos (search-first-ignore-literals + *supported-join-operators* filter-string))) (if (not op-pos) filter-string (let* ((op-str (subseq filter-string op-pos (+ 2 op-pos))) @@ -122,7 +255,7 @@ (remove-null (map 'list #'(lambda(op-string) (when (= (length op-string) 2) op-string)) - *supported-binary-operators*))) + (*supported-binary-operators*)))) (operator-str (subseq filter-string idx))) (if (string-starts-with-one-of operator-str 2-ops) (subseq operator-str 0 2) @@ -169,22 +302,43 @@ (defun find-or-and-right-scope (right-string) "Returns the string that is the right part of the binary scope." (declare (String right-string)) - (let* ((first-pos (search-first-ignore-literals (list "||" "&&") right-string)) + (let* ((first-pos (search-first-ignore-literals + *supported-join-operators* right-string)) (first-bracket (let ((inner-value (search-first-unopened-paranthesis right-string))) (when inner-value (1+ inner-value)))) - (end-idx (cond ((and first-pos first-bracket) - (min first-pos first-bracket)) - (first-pos first-pos) - (first-bracket first-bracket) - (t (if (= (length right-string) 0) - (1- (length right-string))))))) + (paranthesis-pair-idx + (let* ((cleaned-str (trim-whitespace-left right-string)) + (bracket-scope (bracket-scope cleaned-str))) + (when bracket-scope + (+ (- (length right-string) (length cleaned-str)) + (length bracket-scope))))) + (end-idx + (cond ((and first-pos first-bracket) + (if (< first-pos first-bracket) + (if paranthesis-pair-idx + (if (< first-pos paranthesis-pair-idx) + paranthesis-pair-idx + first-pos) + first-pos) + first-bracket)) + (first-bracket first-bracket) + (first-pos + (if paranthesis-pair-idx + (if (< first-pos paranthesis-pair-idx) + paranthesis-pair-idx + first-pos) + first-pos)) + (t + (if (= (length right-string) 0) + 0 + (length right-string)))))) (subseq right-string 0 end-idx))) (defgeneric set-unary-operators (construct filter-string) (:documentation "Transforms the unary operators !, +, - to (not ), - (1+ ) and (1- ). The return value is a modified filter + (one+ ) and (one- ). The return value is a modified filter string.") (:method ((construct SPARQL-Query) (filter-string String)) (let ((result-string "")) @@ -210,7 +364,7 @@ (string-ends-with-one-of string-before (*supported-operators*))) (let ((result (unary-operator-scope filter-string idx))) - (push-string (concatenate 'string "(1" current-char " ") + (push-string (concatenate 'string "(one" current-char " ") result-string) (push-string (set-unary-operators construct (getf result :scope)) @@ -317,6 +471,29 @@ str)))) +(defun reverse-bracket-scope (str &key (open-bracket "(") (close-bracket ")")) + "If str ends with close-bracket there will be returned the substring until + the matching open-bracket is found. Otherwise the return value is nil." + (declare (String str open-bracket close-bracket)) + (when (string-ends-with str close-bracket) + (let ((local-str (subseq str 0 (1- (length str)))) + (result ")") + (close-brackets 1)) + (do ((idx (1- (length local-str)))) ((< idx 0)) + (let ((current-char (subseq local-str idx (1+ idx)))) + (push-string current-char result) + (cond ((string= current-char open-bracket) + (when (not (in-literal-string-p local-str idx)) + (decf close-brackets)) + (when (= close-brackets 0) + (setf idx 0))) + ((string= current-char close-bracket) + (when (not (in-literal-string-p local-str idx)) + (incf close-brackets))))) + (decf idx)) + (reverse result)))) + + (defun bracket-scope (str &key (open-bracket "(") (close-bracket ")")) "If str starts with open-bracket there will be returned the substring until the matching close-bracket is found. Otherwise the return value is nil." Modified: trunk/src/base-tools/base-tools.lisp ============================================================================== --- trunk/src/base-tools/base-tools.lisp (original) +++ trunk/src/base-tools/base-tools.lisp Fri Dec 17 19:53:11 2010 @@ -321,19 +321,48 @@ quotation)))))))) -(defun search-first-ignore-literals (search-strings main-string) +;(defun search-first-ignore-literals (search-strings main-string) +; (declare (String main-string) +; (List search-strings)) +; (let ((first-pos (search-first search-strings main-string))) +; (when first-pos +; (if (not (in-literal-string-p main-string first-pos)) +; first-pos +; (let* ((literal-start (search-first (list "\"" "'") main-string)) +; (sub-str (subseq main-string literal-start)) +; (literal-result (get-literal sub-str)) +; (next-str (getf literal-result :next-string))) +; (let ((next-pos +; (search-first-ignore-literals search-strings next-str))) +; (when next-pos +; (+ (- (length main-string) (length next-str)) next-pos)))))))) + + +(defun search-first-ignore-literals (search-strings main-string &key from-end) (declare (String main-string) - (List search-strings)) - (let ((first-pos (search-first search-strings main-string))) + (List search-strings) + (Boolean from-end)) + (let ((first-pos + (search-first search-strings main-string :from-end from-end))) (when first-pos (if (not (in-literal-string-p main-string first-pos)) first-pos - (let* ((literal-start (search-first (list "\"" "'") main-string)) - (sub-str (subseq main-string literal-start)) - (literal-result (get-literal sub-str)) - (next-str (getf literal-result :next-string))) + (let* ((literal-start + (search-first (list "\"" "'") (subseq main-string 0 first-pos) + :from-end from-end)) + (next-str + (if from-end + + + (subseq main-string 0 literal-start) + + + (let* ((sub-str (subseq main-string literal-start)) + (literal-result (get-literal sub-str))) + (getf literal-result :next-string))))) (let ((next-pos - (search-first-ignore-literals search-strings next-str))) + (search-first-ignore-literals search-strings next-str + :from-end from-end))) (when next-pos (+ (- (length main-string) (length next-str)) next-pos)))))))) @@ -417,7 +446,7 @@ (next-idx (when l-result (- (length filter-string) - (length (getf l-result :next-query)))))) + (length (getf l-result :next-string)))))) (when (and next-idx (< pos next-idx)) (setf result t) (setf idx (length filter-string))) @@ -468,7 +497,8 @@ (cond ((string= current-char "(") (when (or ignore-literals (not (in-literal-string-p str idx))) - (decf closed-brackets))) + (decf closed-brackets) + (setf result-idx nil))) ((string= current-char ")") (when (or ignore-literals (not (in-literal-string-p str idx))) Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Fri Dec 17 19:53:11 2010 @@ -33,7 +33,8 @@ :test-result :test-set-boundings :test-set-unary-operators - :test-set-or-and-operators)) + :test-set-or-and-operators + :test-set-*-and-/-operators)) (in-package :sparql-test) @@ -1122,20 +1123,22 @@ (is-true result-6-1) (is (string= result-1-1 - "BOUND(?var1)||(progn (not (progn (1+ (progn (1- (progn ?var1)))))))")) + "BOUND(?var1)||(progn (not (progn (one+ (progn (one- (progn ?var1)))))))")) (is (string= result-2-1 "(not BOUND(?var1)) = false")) - (is (string= result-3-1 "(1+ ?var1)=(1- $var2)")) - (is (string= result-4-1 "(not \"a\\\"b\\\"c\") && (progn (1+ 12) = (1- 14))")) - (is (string= result-5-1 "(not \"a(+c)\") && (progn (1+ 12) = (1- 14))")) + (is (string= result-3-1 "(one+ ?var1)=(one- $var2)")) + (is (string= result-4-1 "(not \"a\\\"b\\\"c\") && (progn (one+ 12) = (one- 14))")) + (is (string= result-5-1 "(not \"a(+c)\") && (progn (one+ 12) = (one- 14))")) (is (string= result-6-1 "(not \"abc)def\")")))) (test test-set-or-and-operators - "Tests various cases of the function set-unary-operators." + "Tests various cases of the function set-or-and-operators." (let* ((dummy-object (make-instance 'TM-SPARQL::SPARQL-Query :query " ")) (str-1 "isLITERAL(STR(?var))||?var = 12 && true}") (str-2 "(true != false || !false ) && 12 < 14 || !isLITERAL(?var)}") (str-3 "isLITERAL('a(bc||def') && 'abc)def'}") + (str-4 "(a && (b || c))}") + (str-5 "(b || c) && a}") (result-1 (getf (tm-sparql::set-boundings dummy-object str-1) :filter-string)) (result-1-1 (tm-sparql::set-or-and-operators dummy-object result-1 result-1)) @@ -1144,19 +1147,91 @@ (result-2-1 (tm-sparql::set-or-and-operators dummy-object result-2 result-2)) (result-3 (getf (tm-sparql::set-boundings dummy-object str-3) :filter-string)) - (result-3-1 (tm-sparql::set-or-and-operators dummy-object result-3 result-3))) + (result-3-1 (tm-sparql::set-or-and-operators dummy-object result-3 result-3)) + (result-4 + (getf (tm-sparql::set-boundings dummy-object str-4) :filter-string)) + (result-4-1 (tm-sparql::set-or-and-operators dummy-object result-4 result-4)) + (result-5 + (getf (tm-sparql::set-boundings dummy-object str-5) :filter-string)) + (result-5-1 (tm-sparql::set-or-and-operators dummy-object result-5 result-5))) (is-true result-1) (is-true result-1-1) (is-true result-2) (is-true result-2-1) (is-true result-3) (is-true result-3-1) + (is-true result-4) + (is-true result-4-1) + (is-true result-5) + (is-true result-5-1) (is (string= (string-replace result-1-1 " " "") "(and(progn(or(prognisLITERAL(STR(?var)))(progn?var=12)))(progntrue))")) (is (string= (string-replace result-2-1 " " "") "(or(progn(and(progn(progn(or(progntrue!=false)(progn!false))))(progn12<14)))(progn!isLITERAL(?var)))")) (is (string= (string-replace result-3-1 " " "") - "(and(prognisLITERAL(\"a(bc||def\"))(progn\"abc)def\"))")))) + "(and(prognisLITERAL(\"a(bc||def\"))(progn\"abc)def\"))")) + (is (string= (string-replace result-4-1 " " "") + "(progn(and(progna)(progn(progn(or(prognb)(prognc))))))")) + (is (string= (string-replace result-5-1 " " "") + "(and(progn(progn(or(prognb)(prognc))))(progna))")))) + + +(test test-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)}") + (str-3 "(x < a || ( a = 4 && 4 = x / y + (+1)) && -1)}") + (str-4 "isLITERAL(((1 + '(13+4*5))') * 3) / 4) && (12 = 13 + 14 * 15 || 2 * 3 = 1)}") + (result-1 + (getf (tm-sparql::set-boundings dummy-object str-1) :filter-string)) + (result-1-1 + (tm-sparql::set-unary-operators dummy-object result-1)) + (result-1-2 + (tm-sparql::set-or-and-operators dummy-object result-1-1 result-1)) + (result-1-3 + (tm-sparql::set-*-and-/-operators dummy-object result-1-2)) + (result-2 + (getf (tm-sparql::set-boundings dummy-object str-2) :filter-string)) + (result-2-1 + (tm-sparql::set-unary-operators dummy-object result-2)) + (result-2-2 + (tm-sparql::set-or-and-operators dummy-object result-2-1 result-2)) + (result-2-3 + (tm-sparql::set-*-and-/-operators dummy-object result-2-2)) + (result-3 + (getf (tm-sparql::set-boundings dummy-object str-3) :filter-string)) + (result-3-1 + (tm-sparql::set-unary-operators dummy-object result-3)) + (result-3-2 + (tm-sparql::set-or-and-operators dummy-object result-3-1 result-3)) + (result-3-3 + (tm-sparql::set-*-and-/-operators dummy-object result-3-2)) + (result-4 + (getf (tm-sparql::set-boundings dummy-object str-4) :filter-string)) + (result-4-1 + (tm-sparql::set-unary-operators dummy-object result-4)) + (result-4-2 + (tm-sparql::set-or-and-operators dummy-object result-4-1 result-4)) + (result-4-3 + (tm-sparql::set-*-and-/-operators dummy-object result-4-2))) + (is-true result-1) (is-true result-1-1) + (is-true result-1-2) (is-true result-1-3) + (is-true result-2) (is-true result-2-1) + (is-true result-2-2) (is-true result-2-3) + (is-true result-3) (is-true result-3-1) + (is-true result-3-2) (is-true result-3-3) + (is-true result-4) (is-true result-4-1) + (is-true result-4-2) (is-true result-4-3) + (is (string= (string-replace result-1-3 " " "") + "(or(progn(and(prognx=a+(*bc))(progny=(/a3)+(*b2))))(progn0=12-14+(/(*23)3)))")) + (is (string= (string-replace result-2-3 " " "") + "(and(prognx=2)(progn(*(progn2+2)2)+(/(*124)2)-10+(*2(progn12-3))+(progn(*123))))")) + (is (string= (string-replace result-3-3 " " "") + "(progn(and(progn(or(prognx<a)(progn(progn(and(progna=4)(progn4=(/xy)+(progn(one+1))))))))(progn(one-1))))")) + (is (string= (string-replace result-4-3 " " "") + "(and(prognisLITERAL((/(progn(*(progn1+\"(13+4*5))\")3))4)))(progn(progn(or(progn12=13+(*1415))(progn(*23)=1)))))")))) + (defun run-sparql-tests ()

1 0

[isidorus-cvs] r368 - in trunk/src: TM-SPARQL base-tools unit_tests
by Lukas Giessmann 17 Dec '10

17 Dec '10

Author: lgiessmann Date: Fri Dec 17 06:55:25 2010 New Revision: 368 Log: TM-SPARQL: fixed a bug with ||, &&, \!, unary + and - operators => when these operators are contained within literal-strings they are not evaluated anymore => extended the corresponding unit-tests. 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 Fri Dec 17 06:55:25 2010 @@ -57,7 +57,11 @@ (filter-string-unary-ops (set-unary-operators construct filter-string)) (filter-string-or-and-ops - (set-or-and-operators construct filter-string-unary-ops)) + (set-or-and-operators construct filter-string-unary-ops + filter-string-unary-ops)) + (filter-string-binary-ops + (set-binary-operators construct filter-string-or-and-ops)) + )))) ;;TODO: implement ;; **replace () by (progn ) @@ -76,11 +80,21 @@ ;; *create and store this filter object -(defgeneric set-or-and-operators (construct filter-string) +(defgeneric set-binary-operators (construct filter-string) + (:documentation "Transforms the =, !=, <, >, <=, >=, +, -, *, / operators + in the filter string to the the lisp =, /=, <, >, <=, >=, + +, -, * and / functions.") + (:method ((construct SPARQL-Query) (filter-string String)) + ;TODO: implement + )) + + +(defgeneric set-or-and-operators (construct filter-string original-filter-string) (:documentation "Transforms the || and && operators in the filter string to the the lisp or and and functions.") - (:method ((construct SPARQL-Query) (filter-string String)) - (let ((op-pos (search-first (list "||" "&&") filter-string))) + (:method ((construct SPARQL-Query) (filter-string String) + (original-filter-string String)) + (let ((op-pos (search-first-ignore-literals (list "||" "&&") filter-string))) (if (not op-pos) filter-string (let* ((op-str (subseq filter-string op-pos (+ 2 op-pos))) @@ -94,7 +108,12 @@ "(" (if (string= op-str "||") "or" "and") " " "(progn " left-scope ")" "(progn " right-scope ")) " (subseq right-str (length right-scope))))) - (set-or-and-operators construct modified-str)))))) + (when (or (= (length (trim-whitespace left-scope)) 0) + (= (length (trim-whitespace right-scope)) 0)) + (error (make-condition + 'sparql-parser-error + :message (format nil "Invalid filter: \"~a\", expect an RDF term after and before: \"~a\"" original-filter-string op-str)))) + (set-or-and-operators construct modified-str original-filter-string)))))) (defun find-binary-op-string (filter-string idx) @@ -150,7 +169,7 @@ (defun find-or-and-right-scope (right-string) "Returns the string that is the right part of the binary scope." (declare (String right-string)) - (let* ((first-pos (search-first (list "||" "&&") right-string)) + (let* ((first-pos (search-first-ignore-literals (list "||" "&&") right-string)) (first-bracket (let ((inner-value (search-first-unopened-paranthesis right-string))) (when inner-value (1+ inner-value)))) @@ -200,6 +219,18 @@ (setf idx (- (1- (length filter-string)) (length (getf result :next-query))))) (push-string current-char result-string)))) + ((or (string= current-char "'") + (string= current-char "\"")) + (let* ((sub-str (subseq filter-string idx)) + (quotation (get-literal-quotation sub-str)) + (literal + (get-literal (subseq filter-string idx) :quotation quotation))) + (if literal + (progn + (setf idx (- (1- (length filter-string)) + (length (getf literal :next-string)))) + (push-string (getf literal :literal) result-string)) + (push-string current-char result-string)))) (t (push-string current-char result-string))))) result-string))) @@ -224,7 +255,7 @@ :scope result))) ((string-starts-with cleaned-str "\"") (let ((result (get-literal cleaned-str))) - (list :next-query (getf result :next-query) + (list :next-query (getf result :next-string) :scope (getf result :literal)))) ((string-starts-with-digit cleaned-str) (let ((result (separate-leading-digits cleaned-str))) @@ -298,21 +329,13 @@ (cond ((or (string= "'" current-char) (string= "\"" current-char)) (let* ((sub-str (subseq str idx)) - (quotation - (cond ((string-starts-with sub-str "'''") - "'''") - ((string-starts-with sub-str "\"\"\"") - "\"\"\"") - ((string-starts-with sub-str "'") - "'") - ((string-starts-with sub-str "\"") - "\""))) + (quotation (get-literal-quotation sub-str)) (literal (get-literal (subseq str idx) :quotation quotation))) (if literal (progn (setf idx (- (1- (length str)) - (length (getf literal :next-query)))) + (length (getf literal :next-string)))) (push-string (getf literal :literal) str)) (progn (setf result nil) @@ -366,7 +389,7 @@ (original-query construct) "a closing character for the given literal"))) (setf idx (- (1- (length query-string)) - (length (getf result :next-query)))) + (length (getf result :next-string)))) (push-string (getf result :literal) filter-string))) ((string= "#" current-char) (let ((comment-string @@ -446,50 +469,4 @@ t)) (if (find string-before *supported-functions* :test #'string=) nil - t)))) - - -(defun get-literal (query-string &key (quotation "\"")) - "Returns a list of the form (:next-query <string> :literal <string> - where next-query is the query after the found literal and literal - is the literal string." - (declare (String query-string) - (String quotation)) - (cond ((or (string-starts-with query-string "\"\"\"") - (string-starts-with query-string "'''")) - (let ((literal-end - (find-literal-end (subseq query-string 3) (subseq query-string 0 3)))) - (when literal-end - (list :next-query (subseq query-string (+ 3 literal-end)) - :literal (concatenate 'string quotation - (subseq query-string 3 literal-end) - quotation))))) - ((or (string-starts-with query-string "\"") - (string-starts-with query-string "'")) - (let ((literal-end - (find-literal-end (subseq query-string 1) - (subseq query-string 0 1)))) - (when literal-end - (let ((literal - (escape-string (subseq query-string 1 literal-end) "\""))) - (list :next-query (subseq query-string (+ 1 literal-end)) - :literal (concatenate 'string quotation literal - quotation)))))))) - - -(defun find-literal-end (query-string delimiter &optional (overall-pos 0)) - "Returns the end of the literal corresponding to the passed delimiter - string. The query-string must start after the opening literal delimiter. - The return value is an int that represents the start index of closing - delimiter. delimiter must be either \", ', or '''. - If the returns value is nil, there is no closing delimiter." - (declare (String query-string delimiter) - (Integer overall-pos)) - (let ((current-pos (search delimiter query-string))) - (if current-pos - (if (string-ends-with (subseq query-string 0 current-pos) "\\") - (find-literal-end (subseq query-string (+ current-pos - (length delimiter))) - delimiter (+ overall-pos current-pos 1)) - (+ overall-pos current-pos (length delimiter))) - nil))) \ No newline at end of file + t)))) \ No newline at end of file Modified: trunk/src/base-tools/base-tools.lisp ============================================================================== --- trunk/src/base-tools/base-tools.lisp (original) +++ trunk/src/base-tools/base-tools.lisp Fri Dec 17 06:55:25 2010 @@ -26,6 +26,7 @@ :string-until :string-after :search-first + :search-first-ignore-literals :concatenate-uri :absolute-uri-p :string-starts-with-digit @@ -35,7 +36,11 @@ :white-space-p :escape-string :search-first-unclosed-paranthesis - :search-first-unopened-paranthesis )) + :search-first-unopened-paranthesis + :in-literal-string-p + :find-literal-end + :get-literal-quotation + :get-literal)) (in-package :base-tools) @@ -245,8 +250,7 @@ "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) - (Boolean from-end)) + (List search-strings)) (let ((positions (remove-null (map 'list #'(lambda(search-str) @@ -259,6 +263,81 @@ (first sorted-positions))))) +(defun find-literal-end (query-string delimiter &optional (overall-pos 0)) + "Returns the end of the literal corresponding to the passed delimiter + string. The query-string must start after the opening literal delimiter. + The return value is an int that represents the start index of closing + delimiter. delimiter must be either \", ', or '''. + If the returns value is nil, there is no closing delimiter." + (declare (String query-string delimiter) + (Integer overall-pos)) + (let ((current-pos (search delimiter query-string))) + (if current-pos + (if (string-ends-with (subseq query-string 0 current-pos) "\\") + (find-literal-end (subseq query-string (+ current-pos + (length delimiter))) + delimiter (+ overall-pos current-pos 1)) + (+ overall-pos current-pos (length delimiter))) + nil))) + + +(defun get-literal-quotation (str) + "Returns ', ''', \" or \"\"\" when the string starts with a literal delimiter." + (cond ((string-starts-with str "'''") + "'") + ((string-starts-with str "\"\"\"") + "\"\"\"") + ((string-starts-with str "'") + "'") + ((string-starts-with str "\"") + "\""))) + + +(defun get-literal (query-string &key (quotation "\"")) + "Returns a list of the form (:next-string <string> :literal <string> + where next-query is the query after the found literal and literal + is the literal string." + (declare (String query-string) + (String quotation)) + (cond ((or (string-starts-with query-string "\"\"\"") + (string-starts-with query-string "'''")) + (let ((literal-end + (find-literal-end (subseq query-string 3) (subseq query-string 0 3)))) + (when literal-end + (list :next-string (subseq query-string (+ 3 literal-end)) + :literal (concatenate 'string quotation + (subseq query-string 3 literal-end) + quotation))))) + ((or (string-starts-with query-string "\"") + (string-starts-with query-string "'")) + (let ((literal-end + (find-literal-end (subseq query-string 1) + (subseq query-string 0 1)))) + (when literal-end + (let ((literal + (escape-string (subseq query-string 1 literal-end) "\""))) + (list :next-string (subseq query-string (+ 1 literal-end)) + :literal (concatenate 'string quotation literal + quotation)))))))) + + +(defun search-first-ignore-literals (search-strings main-string) + (declare (String main-string) + (List search-strings)) + (let ((first-pos (search-first search-strings main-string))) + (when first-pos + (if (not (in-literal-string-p main-string first-pos)) + first-pos + (let* ((literal-start (search-first (list "\"" "'") main-string)) + (sub-str (subseq main-string literal-start)) + (literal-result (get-literal sub-str)) + (next-str (getf literal-result :next-string))) + (let ((next-pos + (search-first-ignore-literals search-strings next-str))) + (when next-pos + (+ (- (length main-string) (length next-str)) next-pos)))))))) + + (defun concatenate-uri (absolute-ns value) "Returns a string conctenated of the absolut namespace an the given value separated by either '#' or '/'." @@ -325,38 +404,76 @@ result)) -(defun search-first-unclosed-paranthesis (str) +(defun in-literal-string-p(filter-string pos) + "Returns t if the passed pos is within a literal string value." + (declare (String filter-string) + (Integer pos)) + (let ((result nil)) + (dotimes (idx (length filter-string) result) + (let ((current-char (subseq filter-string idx (1+ idx)))) + (cond ((or (string= current-char "'") + (string= current-char "\"")) + (let* ((l-result (get-literal (subseq filter-string idx))) + (next-idx + (when l-result + (- (length filter-string) + (length (getf l-result :next-query)))))) + (when (and next-idx (< pos next-idx)) + (setf result t) + (setf idx (length filter-string))) + (when (<= pos idx) + (setf idx (length filter-string))))) + (t + (when (<= pos idx) + (setf idx (length filter-string))))))))) + + +(defun search-first-unclosed-paranthesis (str &key ignore-literals) "Returns the idx of the first ( that is not closed, the search is - started from the end of the string." - (declare (String str)) + started from the end of the string. + If ignore-literals is set to t all mparanthesis that are within + \", \"\"\", ' and ''' are ignored." + (declare (String str) + (Boolean ignore-literals)) (let ((r-str (reverse str)) (open-brackets 0) (result-idx nil)) (dotimes (idx (length r-str)) (let ((current-char (subseq r-str idx (1+ idx)))) (cond ((string= current-char ")") - (decf open-brackets)) + (when (or ignore-literals + (not (in-literal-string-p str idx))) + (decf open-brackets))) ((string= current-char "(") - (incf open-brackets) - (when (> open-brackets 0) - (setf result-idx idx) - (setf idx (length r-str))))))) + (when (or ignore-literals + (not (in-literal-string-p str idx))) + (incf open-brackets) + (when (> open-brackets 0) + (setf result-idx idx) + (setf idx (length r-str)))))))) (when result-idx (- (length str) (1+ result-idx))))) -(defun search-first-unopened-paranthesis (str) - "Returns the idx of the first paranthesis that is not opened in str." - (declare (String str)) +(defun search-first-unopened-paranthesis (str &key ignore-literals) + "Returns the idx of the first paranthesis that is not opened in str. + If ignore-literals is set to t all mparanthesis that are within + \", \"\"\", ' and ''' are ignored." + (declare (String str) + (Boolean ignore-literals)) (let ((closed-brackets 0) (result-idx nil)) (dotimes (idx (length str)) (let ((current-char (subseq str idx (1+ idx)))) (cond ((string= current-char "(") - (decf closed-brackets)) + (when (or ignore-literals + (not (in-literal-string-p str idx))) + (decf closed-brackets))) ((string= current-char ")") - (incf closed-brackets) - (when (> closed-brackets 0) - (setf result-idx idx) - (setf idx (length str))))))) + (when (or ignore-literals + (not (in-literal-string-p str idx))) + (incf closed-brackets) + (when (> closed-brackets 0) + (setf result-idx idx) + (setf idx (length str)))))))) result-idx)) \ 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 Fri Dec 17 06:55:25 2010 @@ -1084,6 +1084,8 @@ (str-2 "!BOUND(?var1) = false}") (str-3 "+?var1=-$var2}") (str-4 "!'a\"b\"c' && (+12 = - 14)}") + (str-5 "!'a(+c)' && (+12 = - 14)}") + (str-6 "!'abc)def'}") (result-1 (getf (tm-sparql::set-boundings dummy-object str-1) :filter-string)) (result-1-1 (tm-sparql::set-unary-operators dummy-object result-1)) @@ -1097,7 +1099,15 @@ (result-4 (getf (tm-sparql::set-boundings dummy-object str-4) :filter-string)) (result-4-1 - (tm-sparql::set-unary-operators dummy-object result-4))) + (tm-sparql::set-unary-operators dummy-object result-4)) + (result-5 + (getf (tm-sparql::set-boundings dummy-object str-5) :filter-string)) + (result-5-1 + (tm-sparql::set-unary-operators dummy-object result-5)) + (result-6 + (getf (tm-sparql::set-boundings dummy-object str-6) :filter-string)) + (result-6-1 + (tm-sparql::set-unary-operators dummy-object result-6))) (is-true result-1) (is-true result-1-1) (is-true result-2) @@ -1106,12 +1116,18 @@ (is-true result-3-1) (is-true result-4) (is-true result-4-1) + (is-true result-5) + (is-true result-5-1) + (is-true result-6) + (is-true result-6-1) (is (string= result-1-1 "BOUND(?var1)||(progn (not (progn (1+ (progn (1- (progn ?var1)))))))")) (is (string= result-2-1 "(not BOUND(?var1)) = false")) (is (string= result-3-1 "(1+ ?var1)=(1- $var2)")) - (is (string= result-4-1 "(not \"a\\\"b\\\"c\") && (progn (1+ 12) = (1- 14))")))) + (is (string= result-4-1 "(not \"a\\\"b\\\"c\") && (progn (1+ 12) = (1- 14))")) + (is (string= result-5-1 "(not \"a(+c)\") && (progn (1+ 12) = (1- 14))")) + (is (string= result-6-1 "(not \"abc)def\")")))) (test test-set-or-and-operators @@ -1119,20 +1135,28 @@ (let* ((dummy-object (make-instance 'TM-SPARQL::SPARQL-Query :query " ")) (str-1 "isLITERAL(STR(?var))||?var = 12 && true}") (str-2 "(true != false || !false ) && 12 < 14 || !isLITERAL(?var)}") + (str-3 "isLITERAL('a(bc||def') && 'abc)def'}") (result-1 (getf (tm-sparql::set-boundings dummy-object str-1) :filter-string)) - (result-1-1 (tm-sparql::set-or-and-operators dummy-object result-1)) + (result-1-1 (tm-sparql::set-or-and-operators dummy-object result-1 result-1)) (result-2 (getf (tm-sparql::set-boundings dummy-object str-2) :filter-string)) - (result-2-1 (tm-sparql::set-or-and-operators dummy-object result-2))) + (result-2-1 (tm-sparql::set-or-and-operators dummy-object result-2 result-2)) + (result-3 + (getf (tm-sparql::set-boundings dummy-object str-3) :filter-string)) + (result-3-1 (tm-sparql::set-or-and-operators dummy-object result-3 result-3))) (is-true result-1) (is-true result-1-1) (is-true result-2) (is-true result-2-1) + (is-true result-3) + (is-true result-3-1) (is (string= (string-replace result-1-1 " " "") "(and(progn(or(prognisLITERAL(STR(?var)))(progn?var=12)))(progntrue))")) (is (string= (string-replace result-2-1 " " "") - "(or(progn(and(progn(progn(or(progntrue!=false)(progn!false))))(progn12<14)))(progn!isLITERAL(?var)))")))) + "(or(progn(and(progn(progn(or(progntrue!=false)(progn!false))))(progn12<14)))(progn!isLITERAL(?var)))")) + (is (string= (string-replace result-3-1 " " "") + "(and(prognisLITERAL(\"a(bc||def\"))(progn\"abc)def\"))")))) (defun run-sparql-tests ()

1 0

[isidorus-cvs] r367 - in trunk/src: TM-SPARQL base-tools unit_tests
by Lukas Giessmann 16 Dec '10

16 Dec '10

Author: lgiessmann Date: Thu Dec 16 16:07:40 2010 New Revision: 367 Log: TM-SPARQL: adde the hanlding of || and && operators; added also some unit-tests for these cases 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 Thu Dec 16 16:07:40 2010 @@ -15,10 +15,19 @@ "Contains all supported SPARQL-functions") -(defparameter *supported-operators* - (list "!" "||" "&&" "=" "!=" "<" "<=" ">" ">=" "+" "-" "*" "/") - "Contains all supported operators, note some unary operators - are handled as functions, e.g. + and -") +(defparameter *supported-binary-operators* + (list "||" "&&" "=" "!=" "<" "<=" ">" ">=" "+" "-" "*" "/") + "Contains all supported binary operators.") + + +(defparameter *supported-unary-operators* + (list "!" "+" "-") "Contains all supported unary operators") + + +(defun *supported-operators* () + (union *supported-binary-operators* *supported-unary-operators* + :test #'string=)) + (defparameter *supported-brackets* (list "(" ")") @@ -45,25 +54,115 @@ (let* ((result-set-boundings (set-boundings construct query-string)) (filter-string (getf result-set-boundings :filter-string)) (next-query (getf result-set-boundings :next-query)) - (filter-string-unary-ops (set-unary-operators construct filter-string)) + (filter-string-unary-ops + (set-unary-operators construct filter-string)) + (filter-string-or-and-ops + (set-or-and-operators construct filter-string-unary-ops)) )))) ;;TODO: implement - ;; *replace #comment => in set boundings ;; **replace () by (progn ) - ;; **replace ', """, ''' by ''' + ;; **replace ', """, ''' by " ;; **replace !x by (not x) ;; **replace +x by (1+ x) ;; **replace -x by (1- x) - ;; *replace x operator y by (filter-operator x y) - ;; *=, !=, <, >, <=, >=, +, -, *, /, ||, && + ;; **||, && + ;; *=, !=, <, >, <=, >=, +, -, *, / ;; *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 - ;; add a let with all variables that are used: every variable with $ and ? prefix - ;; add a let with (true t) and (false nil) + ;; *check if all functions that will be invoked are allowed + ;; *add a let with all variables that are used: every variable with $ and ? prefix + ;; *add a let with (true t) and (false nil) + ;; *embrace the final result uris in <> => unit-tests ;; *create and store this filter object +(defgeneric set-or-and-operators (construct filter-string) + (:documentation "Transforms the || and && operators in the filter string to + the the lisp or and and functions.") + (:method ((construct SPARQL-Query) (filter-string String)) + (let ((op-pos (search-first (list "||" "&&") filter-string))) + (if (not op-pos) + 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))) + (left-scope (find-or-and-left-scope left-str)) + (right-scope (find-or-and-right-scope right-str)) + (modified-str + (concatenate 'string (subseq left-str 0 (- (length left-str) + (length left-scope))) + "(" (if (string= op-str "||") "or" "and") " " + "(progn " left-scope ")" "(progn " right-scope ")) " + (subseq right-str (length right-scope))))) + (set-or-and-operators construct modified-str)))))) + + +(defun find-binary-op-string (filter-string idx) + "Returns the operator as string that is placed on the position idx." + (let* ((2-ops + (remove-null (map 'list #'(lambda(op-string) + (when (= (length op-string) 2) + op-string)) + *supported-binary-operators*))) + (operator-str (subseq filter-string idx))) + (if (string-starts-with-one-of operator-str 2-ops) + (subseq operator-str 0 2) + (subseq operator-str 0 1)))) + + +(defun find-or-and-left-scope (left-string) + "Returns the string that is the left part of the binary scope." + (declare (String left-string)) + (let* ((first-bracket + (let ((inner-value (search-first-unclosed-paranthesis left-string))) + (when inner-value + (+ inner-value (1+ (length (name-after-paranthesis + (subseq left-string inner-value)))))))) + (start-idx (if first-bracket + first-bracket + 0))) + (subseq left-string start-idx))) + + +(defun name-after-paranthesis (str) + "Returns the substring that is contained after the paranthesis. + str must start with a ( otherwise the returnvalue is nil." + (declare (String str)) + (let ((result "") + (non-whitespace-found nil)) + (when (string-starts-with str "(") + (let ((cleaned-str (subseq str 1))) + (dotimes (idx (length cleaned-str)) + (let ((current-char (subseq cleaned-str idx (1+ idx)))) + (cond ((string-starts-with-one-of current-char (list "(" ")")) + (setf idx (length cleaned-str))) + ((and non-whitespace-found + (white-space-p current-char)) + (setf idx (length cleaned-str))) + ((white-space-p current-char) + (push-string current-char result)) + (t + (push-string current-char result) + (setf non-whitespace-found t))))) + result)))) + + +(defun find-or-and-right-scope (right-string) + "Returns the string that is the right part of the binary scope." + (declare (String right-string)) + (let* ((first-pos (search-first (list "||" "&&") right-string)) + (first-bracket + (let ((inner-value (search-first-unopened-paranthesis right-string))) + (when inner-value (1+ inner-value)))) + (end-idx (cond ((and first-pos first-bracket) + (min first-pos first-bracket)) + (first-pos first-pos) + (first-bracket first-bracket) + (t (if (= (length right-string) 0) + (1- (length right-string))))))) + (subseq right-string 0 end-idx))) + + (defgeneric set-unary-operators (construct filter-string) (:documentation "Transforms the unary operators !, +, - to (not ), (1+ ) and (1- ). The return value is a modified filter @@ -90,7 +189,7 @@ (if (or (string= string-before "") (string-ends-with string-before "(progn") (string-ends-with-one-of string-before - *supported-operators*)) + (*supported-operators*))) (let ((result (unary-operator-scope filter-string idx))) (push-string (concatenate 'string "(1" current-char " ") result-string) @@ -179,7 +278,7 @@ (declare (String str)) (when (or (string-starts-with str "?") (string-starts-with str "$")) - (let ((found-end (search-first (append (white-space) *supported-operators* + (let ((found-end (search-first (append (white-space) (*supported-operators*) *supported-brackets* (list "?" "$")) (subseq str 1)))) (if found-end @@ -301,7 +400,7 @@ (Integer idx)) (let* ((delimiters (append (list " " (string #\Space) (string #\Tab) (string #\Newline) (string #\cr) "(" ")") - *supported-operators*)) + (*supported-operators*))) (string-before (trim-whitespace-right (subseq query-string 0 idx))) (fragment-before-idx (search-first delimiters string-before :from-end t)) @@ -323,7 +422,7 @@ (> (length fragment-before) (length operator))) (setf fragment-before (string-after fragment-before operator)))) - (append *supported-operators* *supported-brackets*))) + (append (*supported-operators*) *supported-brackets*))) (if fragment-before (progn (when (or (string-starts-with fragment-before "?") Modified: trunk/src/base-tools/base-tools.lisp ============================================================================== --- trunk/src/base-tools/base-tools.lisp (original) +++ trunk/src/base-tools/base-tools.lisp Thu Dec 16 16:07:40 2010 @@ -12,6 +12,7 @@ (:nicknames :tools) (:export :push-string :when-do + :string-replace :remove-null :full-path :trim-whitespace-left @@ -21,6 +22,7 @@ :string-ends-with :string-ends-with-one-of :string-starts-with-char + :string-starts-with-one-of :string-until :string-after :search-first @@ -30,7 +32,10 @@ :string-after-number :separate-leading-digits :white-space - :escape-string)) + :white-space-p + :escape-string + :search-first-unclosed-paranthesis + :search-first-unopened-paranthesis )) (in-package :base-tools) @@ -63,6 +68,17 @@ nil))) +(defun white-space-p (str) + "Returns t if the passed str contains only white space characters." + (cond ((and (= (length str) 1) + (string-starts-with-one-of str (white-space))) + t) + ((string-starts-with-one-of str (white-space)) + (white-space-p (subseq str 1))) + (t + nil))) + + (defun remove-null (lst) "Removes all null values from the passed list." (remove-if #'null lst)) @@ -118,6 +134,16 @@ (length str-i))))) +(defun string-starts-with-one-of (str prefixes &key (ignore-case nil)) + "Returns t if str ends with one of the string contained in suffixes." + (declare (String str) + (List prefixes) + (Boolean ignore-case)) + (loop for prefix in prefixes + when (string-starts-with str prefix :ignore-case ignore-case) + return t)) + + (defun string-ends-with (str suffix &key (ignore-case nil)) "Checks if string str ends with a given suffix." (declare (String str suffix) @@ -146,6 +172,23 @@ return t)) +(defun string-replace (main-string string-to-replace new-string) + "Replaces every occurrence of string-to-replace by new-string + in main-string." + (declare (String main-string string-to-replace new-string)) + (if (string= string-to-replace new-string) + main-string + (let ((search-idx (search-first (list string-to-replace) main-string))) + (if (not search-idx) + main-string + (let ((modified-string + (concatenate 'string (subseq main-string 0 search-idx) + new-string (subseq main-string + (+ search-idx (length string-to-replace)))))) + (string-replace modified-string string-to-replace new-string)))))) + + + (defun string-starts-with-digit (str) "Checks whether the passed string starts with a digit." (declare (String str)) @@ -153,6 +196,7 @@ when (string-starts-with str (write-to-string item)) return t)) + (defun string-after-number (str) "If str starts with a digit, there is returned the first substring after a character that is a non-digit. @@ -278,4 +322,41 @@ (push-string current-char result)) (t (push-string current-char result))))) - result)) \ No newline at end of file + result)) + + +(defun search-first-unclosed-paranthesis (str) + "Returns the idx of the first ( that is not closed, the search is + started from the end of the string." + (declare (String str)) + (let ((r-str (reverse str)) + (open-brackets 0) + (result-idx nil)) + (dotimes (idx (length r-str)) + (let ((current-char (subseq r-str idx (1+ idx)))) + (cond ((string= current-char ")") + (decf open-brackets)) + ((string= current-char "(") + (incf open-brackets) + (when (> open-brackets 0) + (setf result-idx idx) + (setf idx (length r-str))))))) + (when result-idx + (- (length str) (1+ result-idx))))) + + +(defun search-first-unopened-paranthesis (str) + "Returns the idx of the first paranthesis that is not opened in str." + (declare (String str)) + (let ((closed-brackets 0) + (result-idx nil)) + (dotimes (idx (length str)) + (let ((current-char (subseq str idx (1+ idx)))) + (cond ((string= current-char "(") + (decf closed-brackets)) + ((string= current-char ")") + (incf closed-brackets) + (when (> closed-brackets 0) + (setf result-idx idx) + (setf idx (length str))))))) + result-idx)) \ 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 Thu Dec 16 16:07:40 2010 @@ -9,6 +9,7 @@ (defpackage :sparql-test (:use :cl + :base-tools :it.bese.FiveAM :TM-SPARQL :exceptions @@ -31,7 +32,8 @@ :test-set-result-5 :test-result :test-set-boundings - :test-set-unary-operators)) + :test-set-unary-operators + :test-set-or-and-operators)) (in-package :sparql-test) @@ -1112,6 +1114,26 @@ (is (string= result-4-1 "(not \"a\\\"b\\\"c\") && (progn (1+ 12) = (1- 14))")))) +(test test-set-or-and-operators + "Tests various cases of the function set-unary-operators." + (let* ((dummy-object (make-instance 'TM-SPARQL::SPARQL-Query :query " ")) + (str-1 "isLITERAL(STR(?var))||?var = 12 && true}") + (str-2 "(true != false || !false ) && 12 < 14 || !isLITERAL(?var)}") + (result-1 + (getf (tm-sparql::set-boundings dummy-object str-1) :filter-string)) + (result-1-1 (tm-sparql::set-or-and-operators dummy-object result-1)) + (result-2 + (getf (tm-sparql::set-boundings dummy-object str-2) :filter-string)) + (result-2-1 (tm-sparql::set-or-and-operators dummy-object result-2))) + (is-true result-1) + (is-true result-1-1) + (is-true result-2) + (is-true result-2-1) + (is (string= (string-replace result-1-1 " " "") + "(and(progn(or(prognisLITERAL(STR(?var)))(progn?var=12)))(progntrue))")) + (is (string= (string-replace result-2-1 " " "") + "(or(progn(and(progn(progn(or(progntrue!=false)(progn!false))))(progn12<14)))(progn!isLITERAL(?var)))")))) + (defun run-sparql-tests () (it.bese.fiveam:run! 'sparql-test:sparql-tests))

1 0

[isidorus-cvs] r366 - in trunk/src: TM-SPARQL base-tools unit_tests
by Lukas Giessmann 16 Dec '10

16 Dec '10

Author: lgiessmann Date: Thu Dec 16 08:23:10 2010 New Revision: 366 Log: TM-SPARQL: fixed a problem in all filter statements that uses """, ' or ''' and do not escape inner " in literals 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 Thu Dec 16 08:23:10 2010 @@ -58,7 +58,9 @@ ;; *=, !=, <, >, <=, >=, +, -, *, /, ||, && ;; *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 e invoked are allowed + ;; check if all functions that will be invoked are allowed + ;; add a let with all variables that are used: every variable with $ and ? prefix + ;; add a let with (true t) and (false nil) ;; *create and store this filter object @@ -121,7 +123,7 @@ (let ((result (get-filter-variable cleaned-str))) (list :next-query (string-after cleaned-str result) :scope result))) - ((string-starts-with cleaned-str "'''") + ((string-starts-with cleaned-str "\"") (let ((result (get-literal cleaned-str))) (list :next-query (getf result :next-query) :scope (getf result :literal)))) @@ -348,7 +350,7 @@ t)))) -(defun get-literal (query-string &key (quotation "'''")) +(defun get-literal (query-string &key (quotation "\"")) "Returns a list of the form (:next-query <string> :literal <string> where next-query is the query after the found literal and literal is the literal string." @@ -366,12 +368,14 @@ ((or (string-starts-with query-string "\"") (string-starts-with query-string "'")) (let ((literal-end - (find-literal-end (subseq query-string 1)(subseq query-string 0 1)))) + (find-literal-end (subseq query-string 1) + (subseq query-string 0 1)))) (when literal-end - (list :next-query (subseq query-string (+ 1 literal-end)) - :literal (concatenate 'string quotation - (subseq query-string 1 literal-end) - quotation))))))) + (let ((literal + (escape-string (subseq query-string 1 literal-end) "\""))) + (list :next-query (subseq query-string (+ 1 literal-end)) + :literal (concatenate 'string quotation literal + quotation)))))))) (defun find-literal-end (query-string delimiter &optional (overall-pos 0)) Modified: trunk/src/base-tools/base-tools.lisp ============================================================================== --- trunk/src/base-tools/base-tools.lisp (original) +++ trunk/src/base-tools/base-tools.lisp Thu Dec 16 08:23:10 2010 @@ -29,7 +29,8 @@ :string-starts-with-digit :string-after-number :separate-leading-digits - :white-space)) + :white-space + :escape-string)) (in-package :base-tools) @@ -260,4 +261,21 @@ (position #\: uri))) (declare (string uri)) (and position-of-colon (> position-of-colon 0) - (not (find #\/ (subseq uri 0 position-of-colon))))))) \ No newline at end of file + (not (find #\/ (subseq uri 0 position-of-colon))))))) + + +(defun escape-string (str char-to-escape) + "Escapes every occurrence of char-to-escape in str, if it is + not escaped." + (declare (String str char-to-escape)) + (let ((result "")) + (dotimes (idx (length str)) + (let ((current-char (subseq str idx (1+ idx))) + (previous-char (if (= idx 0) "" (subseq str (1- idx) idx)))) + (cond ((and (string= current-char char-to-escape) + (string/= previous-char "\\")) + (push-string "\\" result) + (push-string current-char result)) + (t + (push-string current-char result))))) + result)) \ 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 Thu Dec 16 08:23:10 2010 @@ -1059,10 +1059,10 @@ (is-true result-1) (is-true result-2) (is (string= (getf result-1 :filter-string) - "BOUND((progn (progn ?var) )) || (progn isLITERAL($var) && ?var = '''abc''')")) + "BOUND((progn (progn ?var) )) || (progn isLITERAL($var) && ?var = \"abc\")")) (is (string= (getf result-1 :next-query) "}")) (is (string= (getf result-2 :filter-string) - "(progn REGEX(?var1, '''''', ?var3) || (progn ?var1 > ?var3 && (progn STR( ?var) = '''abc''')))")) + "(progn REGEX(?var1, \"\", ?var3) || (progn ?var1 > ?var3 && (progn STR( ?var) = \"abc\")))")) (is (string= (getf result-2 :next-query) "}")) (is (string= (getf result-3 :filter-string) "DATATYPE(?var3) || +?var1 = -?var2")) @@ -1081,7 +1081,7 @@ (str-1 "BOUND(?var1)||(!(+(-(?var1))))}") (str-2 "!BOUND(?var1) = false}") (str-3 "+?var1=-$var2}") - (str-4 "!'abc' && (+12 = - 14)}") + (str-4 "!'a\"b\"c' && (+12 = - 14)}") (result-1 (getf (tm-sparql::set-boundings dummy-object str-1) :filter-string)) (result-1-1 (tm-sparql::set-unary-operators dummy-object result-1)) @@ -1109,7 +1109,7 @@ "BOUND(?var1)||(progn (not (progn (1+ (progn (1- (progn ?var1)))))))")) (is (string= result-2-1 "(not BOUND(?var1)) = false")) (is (string= result-3-1 "(1+ ?var1)=(1- $var2)")) - (is (string= result-4-1 "(not '''abc''') && (progn (1+ 12) = (1- 14))")))) + (is (string= result-4-1 "(not \"a\\\"b\\\"c\") && (progn (1+ 12) = (1- 14))"))))

1 0

[isidorus-cvs] r365 - in trunk/src: TM-SPARQL unit_tests
by Lukas Giessmann 15 Dec '10

15 Dec '10

Author: lgiessmann Date: Wed Dec 15 13:08:01 2010 New Revision: 365 Log: TM-SPARQL: added some unit-tests for the handling of \!, -, + as unary opertors => fixed some bugs Modified: trunk/src/TM-SPARQL/sparql_filter.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 Wed Dec 15 13:08:01 2010 @@ -58,6 +58,7 @@ ;; *=, !=, <, >, <=, >=, +, -, *, /, ||, && ;; *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 e invoked are allowed ;; *create and store this filter object @@ -115,21 +116,23 @@ (let ((result (bracket-scope cleaned-str))) (list :next-query (string-after cleaned-str result) :scope result))) - ((or (string-starts-with "?" cleaned-str) - (string-starts-with "$" cleaned-str)) + ((or (string-starts-with cleaned-str "?") + (string-starts-with cleaned-str "$")) (let ((result (get-filter-variable cleaned-str))) (list :next-query (string-after cleaned-str result) :scope result))) - ((string-starts-with "'''" cleaned-str) + ((string-starts-with cleaned-str "'''") (let ((result (get-literal cleaned-str))) (list :next-query (getf result :next-query) :scope (getf result :literal)))) ((string-starts-with-digit cleaned-str) - (separate-leading-digits cleaned-str)) - ((string-starts-with "true" cleaned-str) + (let ((result (separate-leading-digits cleaned-str))) + (list :next-query (string-after cleaned-str result) + :scope result))) + ((string-starts-with cleaned-str "true") (list :next-query (string-after cleaned-str "true") :scope "true")) - ((string-starts-with "false" cleaned-str) + ((string-starts-with cleaned-str "false") (list :next-query (string-after cleaned-str "false") :scope "false")) ((let ((pos (search-first *supported-functions* cleaned-str))) Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Wed Dec 15 13:08:01 2010 @@ -30,7 +30,8 @@ :test-set-result-4 :test-set-result-5 :test-result - :test-set-boundings)) + :test-set-boundings + :test-set-unary-operators)) (in-package :sparql-test) @@ -1073,5 +1074,44 @@ "DATATYPE(?var3) ||(progn isLITERAL (+?var1 = -?var2))")) (is (string= (getf result-5 :next-query) "}")))) + +(test test-set-unary-operators + "Tests various cases of the function set-unary-operators." + (let* ((dummy-object (make-instance 'TM-SPARQL::SPARQL-Query :query " ")) + (str-1 "BOUND(?var1)||(!(+(-(?var1))))}") + (str-2 "!BOUND(?var1) = false}") + (str-3 "+?var1=-$var2}") + (str-4 "!'abc' && (+12 = - 14)}") + (result-1 + (getf (tm-sparql::set-boundings dummy-object str-1) :filter-string)) + (result-1-1 (tm-sparql::set-unary-operators dummy-object result-1)) + (result-2 + (getf (tm-sparql::set-boundings dummy-object str-2) :filter-string)) + (result-2-1 (tm-sparql::set-unary-operators dummy-object result-2)) + (result-3 + (getf (tm-sparql::set-boundings dummy-object str-3) :filter-string)) + (result-3-1 + (tm-sparql::set-unary-operators dummy-object result-3)) + (result-4 + (getf (tm-sparql::set-boundings dummy-object str-4) :filter-string)) + (result-4-1 + (tm-sparql::set-unary-operators dummy-object result-4))) + (is-true result-1) + (is-true result-1-1) + (is-true result-2) + (is-true result-2-1) + (is-true result-3) + (is-true result-3-1) + (is-true result-4) + (is-true result-4-1) + (is (string= + result-1-1 + "BOUND(?var1)||(progn (not (progn (1+ (progn (1- (progn ?var1)))))))")) + (is (string= result-2-1 "(not BOUND(?var1)) = false")) + (is (string= result-3-1 "(1+ ?var1)=(1- $var2)")) + (is (string= result-4-1 "(not '''abc''') && (progn (1+ 12) = (1- 14))")))) + + + (defun run-sparql-tests () (it.bese.fiveam:run! 'sparql-test:sparql-tests))

1 0

[isidorus-cvs] r364 - in trunk/src: TM-SPARQL base-tools
by Lukas Giessmann 15 Dec '10

15 Dec '10

Author: lgiessmann Date: Wed Dec 15 08:15:40 2010 New Revision: 364 Log: TM-SPARQL: added the evaluation of the unary-operators: \!, +, - Modified: trunk/src/TM-SPARQL/sparql_filter.lisp trunk/src/base-tools/base-tools.lisp Modified: trunk/src/TM-SPARQL/sparql_filter.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_filter.lisp (original) +++ trunk/src/TM-SPARQL/sparql_filter.lisp Wed Dec 15 08:15:40 2010 @@ -45,13 +45,15 @@ (let* ((result-set-boundings (set-boundings construct query-string)) (filter-string (getf result-set-boundings :filter-string)) (next-query (getf result-set-boundings :next-query)) + (filter-string-unary-ops (set-unary-operators construct filter-string)) )))) ;;TODO: implement + ;; *replace #comment => in set boundings ;; **replace () by (progn ) ;; **replace ', """, ''' by ''' - ;; *replace !x by (not x) - ;; *replace +x by (1+ x) - ;; *replace -x by (1- x) + ;; **replace !x by (not x) + ;; **replace +x by (1+ x) + ;; **replace -x by (1- x) ;; *replace x operator y by (filter-operator x y) ;; *=, !=, <, >, <=, >=, +, -, *, /, ||, && ;; *replace function(x), function(x, y), function(x, y, z) @@ -59,6 +61,171 @@ ;; *create and store this filter object +(defgeneric set-unary-operators (construct filter-string) + (:documentation "Transforms the unary operators !, +, - to (not ), + (1+ ) and (1- ). The return value is a modified filter + string.") + (:method ((construct SPARQL-Query) (filter-string String)) + (let ((result-string "")) + (dotimes (idx (length filter-string)) + (let ((current-char (subseq filter-string idx (1+ idx)))) + (cond ((string= current-char "!") + (if (and (< idx (1- (length filter-string))) + (string= (subseq filter-string (1+ idx) (+ 2 idx)) "=")) + (push-string current-char result-string) + (let ((result (unary-operator-scope filter-string idx))) + (push-string "(not " result-string) + (push-string (set-unary-operators construct (getf result :scope)) + result-string) + (push-string ")" result-string) + (setf idx (- (1- (length filter-string)) + (length (getf result :next-query))))))) + ((or (string= current-char "-") + (string= current-char "+")) + (let ((string-before + (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*)) + (let ((result (unary-operator-scope filter-string idx))) + (push-string (concatenate 'string "(1" current-char " ") + result-string) + (push-string (set-unary-operators construct + (getf result :scope)) + result-string) + (push-string ")" result-string) + (setf idx (- (1- (length filter-string)) + (length (getf result :next-query))))) + (push-string current-char result-string)))) + (t + (push-string current-char result-string))))) + result-string))) + + +(defun unary-operator-scope (filter-string idx) + "Returns a list of the form (:next-query <string> :scope <string>). + scope contains the statement that is in the scope of one of the following + operators !, +, -." + (declare (String filter-string) + (Integer idx)) + (let* ((string-after (subseq filter-string (1+ idx))) + (cleaned-str (cut-comment string-after))) + (cond ((string-starts-with cleaned-str "(") + (let ((result (bracket-scope cleaned-str))) + (list :next-query (string-after cleaned-str result) + :scope result))) + ((or (string-starts-with "?" cleaned-str) + (string-starts-with "$" cleaned-str)) + (let ((result (get-filter-variable cleaned-str))) + (list :next-query (string-after cleaned-str result) + :scope result))) + ((string-starts-with "'''" cleaned-str) + (let ((result (get-literal cleaned-str))) + (list :next-query (getf result :next-query) + :scope (getf result :literal)))) + ((string-starts-with-digit cleaned-str) + (separate-leading-digits cleaned-str)) + ((string-starts-with "true" cleaned-str) + (list :next-query (string-after cleaned-str "true") + :scope "true")) + ((string-starts-with "false" cleaned-str) + (list :next-query (string-after cleaned-str "false") + :scope "false")) + ((let ((pos (search-first *supported-functions* cleaned-str))) + (when pos + (= pos 0))) + (let ((result (function-scope cleaned-str))) + (list :next-query (string-after cleaned-str result) + :scope result))) + (t + (error + (make-condition + 'sparql-parser-error + :message + (format + nil "Invalid filter: \"~a\". An unary operator must be followed by ~a" + filter-string + "a number, boolean, string, function or a variable"))))))) + + +(defun function-scope (str) + "If str starts with a supported function it there is given the entire substr + that is the scope of the function, i.e. the function name and all its + variable including the closing )." + (declare (String str)) + (let* ((cleaned-str (cut-comment str)) + (after-fun + (remove-null (map 'list #'(lambda(fun) + (when (string-starts-with cleaned-str fun) + (string-after str fun))) + *supported-functions*))) + (fun-suffix (when after-fun + (cut-comment (first after-fun))))) + (when fun-suffix + (let* ((args (bracket-scope fun-suffix)) + (fun-name (string-until cleaned-str args))) + (concatenate 'string fun-name args))))) + + +(defun get-filter-variable (str) + "Returns the substring of str if str starts with ? or $ until the variable ends, + otherwise the return value is nil." + (declare (String str)) + (when (or (string-starts-with str "?") + (string-starts-with str "$")) + (let ((found-end (search-first (append (white-space) *supported-operators* + *supported-brackets* (list "?" "$")) + (subseq str 1)))) + (if found-end + (subseq str 0 (1+ found-end)) + str)))) + + +(defun bracket-scope (str &key (open-bracket "(") (close-bracket ")")) + "If str starts with open-bracket there will be returned the substring until + the matching close-bracket is found. Otherwise the return value is nil." + (declare (String str open-bracket close-bracket)) + (when (string-starts-with str open-bracket) + (let ((open-brackets 0) + (result "")) + (dotimes (idx (length str)) + (let ((current-char (subseq str idx (1+ idx)))) + (cond ((or (string= "'" current-char) + (string= "\"" current-char)) + (let* ((sub-str (subseq str idx)) + (quotation + (cond ((string-starts-with sub-str "'''") + "'''") + ((string-starts-with sub-str "\"\"\"") + "\"\"\"") + ((string-starts-with sub-str "'") + "'") + ((string-starts-with sub-str "\"") + "\""))) + (literal + (get-literal (subseq str idx) :quotation quotation))) + (if literal + (progn + (setf idx (- (1- (length str)) + (length (getf literal :next-query)))) + (push-string (getf literal :literal) str)) + (progn + (setf result nil) + (setf idx (length str)))))) + ((string= current-char close-bracket) + (decf open-brackets) + (push-string current-char result) + (when (= open-brackets 0) + (setf idx (length str)))) + ((string= current-char open-bracket) + (incf open-brackets) + (push-string current-char result)) + (t + (push-string current-char result))))) + result))) + + (defgeneric set-boundings (construct query-string) (:documentation "Returns a list of the form (:next-query <string> :filter-string <string>). next-query is a string containing @@ -80,19 +247,20 @@ ((string= ")" current-char) (setf open-brackets (1- open-brackets)) (when (< open-brackets 0) - (make-sparql-parser-condition - (subseq query-string idx) - (original-query construct) - "an opening bracket \"(\" is missing for the current closing one")) + (error + (make-sparql-parser-condition + (subseq query-string idx) + (original-query construct) + "an opening bracket \"(\" is missing for the current closing one"))) (push-string current-char filter-string)) ((or (string= "'" current-char) (string= "\"" current-char)) (let ((result (get-literal (subseq query-string idx)))) (unless result - (make-sparql-parser-condition - (subseq query-string idx) - (original-query construct) - "a closing character for the given literal")) + (error (make-sparql-parser-condition + (subseq query-string idx) + (original-query construct) + "a closing character for the given literal"))) (setf idx (- (1- (length query-string)) (length (getf result :next-query)))) (push-string (getf result :literal) filter-string))) @@ -109,10 +277,10 @@ (setf idx (1- (length query-string)))) ((string= current-char "}") (when (/= open-brackets 0) - (make-sparql-parser-condition - (subseq query-string idx) - (original-query construct) - "a valid filter, but the filter is not complete")) + (error (make-sparql-parser-condition + (subseq query-string idx) + (original-query construct) + "a valid filter, but the filter is not complete"))) (setf result (list :next-query (subseq query-string idx) :filter-string filter-string))) @@ -177,29 +345,30 @@ t)))) -(defun get-literal (query-string) +(defun get-literal (query-string &key (quotation "'''")) "Returns a list of the form (:next-query <string> :literal <string> where next-query is the query after the found literal and literal is the literal string." - (declare (String query-string)) + (declare (String query-string) + (String quotation)) (cond ((or (string-starts-with query-string "\"\"\"") (string-starts-with query-string "'''")) (let ((literal-end (find-literal-end (subseq query-string 3) (subseq query-string 0 3)))) (when literal-end (list :next-query (subseq query-string (+ 3 literal-end)) - :literal (concatenate 'string "'''" + :literal (concatenate 'string quotation (subseq query-string 3 literal-end) - "'''"))))) + quotation))))) ((or (string-starts-with query-string "\"") (string-starts-with query-string "'")) (let ((literal-end (find-literal-end (subseq query-string 1)(subseq query-string 0 1)))) (when literal-end (list :next-query (subseq query-string (+ 1 literal-end)) - :literal (concatenate 'string "'''" + :literal (concatenate 'string quotation (subseq query-string 1 literal-end) - "'''"))))))) + quotation))))))) (defun find-literal-end (query-string delimiter &optional (overall-pos 0)) Modified: trunk/src/base-tools/base-tools.lisp ============================================================================== --- trunk/src/base-tools/base-tools.lisp (original) +++ trunk/src/base-tools/base-tools.lisp Wed Dec 15 08:15:40 2010 @@ -19,17 +19,33 @@ :trim-whitespace :string-starts-with :string-ends-with + :string-ends-with-one-of :string-starts-with-char :string-until :string-after :search-first :concatenate-uri :absolute-uri-p - :string-starts-with-digit)) + :string-starts-with-digit + :string-after-number + :separate-leading-digits + :white-space)) (in-package :base-tools) +(defparameter *white-space* + (list #\Space #\Tab #\Newline #\cr) + "Contains all characters that are treated as white space.") + + +(defun white-space() + "Returns a lit os string that represents a white space." + (map 'list #'(lambda(char) + (string char)) + *white-space*)) + + (defmacro push-string (obj place) "Imitates the push macro but instead of pushing object in a list, there will be appended the given string to the main string object." @@ -70,19 +86,19 @@ (defun trim-whitespace-left (value) "Uses string-left-trim with a predefined character-list." (declare (String value)) - (string-left-trim '(#\Space #\Tab #\Newline #\cr) value)) + (string-left-trim *white-space* value)) (defun trim-whitespace-right (value) "Uses string-right-trim with a predefined character-list." (declare (String value)) - (string-right-trim '(#\Space #\Tab #\Newline #\cr) value)) + (string-right-trim *white-space* value)) (defun trim-whitespace (value) "Uses string-trim with a predefined character-list." (declare (String value)) - (string-trim '(#\Space #\Tab #\Newline #\cr) value)) + (string-trim *white-space* value)) (defun string-starts-with (str prefix &key (ignore-case nil)) @@ -119,6 +135,16 @@ 0)))) +(defun string-ends-with-one-of (str suffixes &key (ignore-case nil)) + "Returns t if str ends with one of the string contained in suffixes." + (declare (String str) + (List suffixes) + (Boolean ignore-case)) + (loop for suffix in suffixes + when (string-ends-with str suffix :ignore-case ignore-case) + return t)) + + (defun string-starts-with-digit (str) "Checks whether the passed string starts with a digit." (declare (String str)) @@ -126,6 +152,26 @@ when (string-starts-with str (write-to-string item)) return t)) +(defun string-after-number (str) + "If str starts with a digit, there is returned the first + substring after a character that is a non-digit. + If str does not start with a digit str is returned." + (declare (String str)) + (if (and (string-starts-with-digit str) + (> (length str) 0)) + (string-after-number (subseq str 1)) + str)) + + +(defun separate-leading-digits (str &optional digits) + "If str starts with a number the number is returned." + (declare (String str) + (type (or Null String) digits)) + (if (string-starts-with-digit str) + (separate-leading-digits + (subseq str 1) (concatenate 'string digits (subseq str 0 1))) + digits)) + (defun string-starts-with-char (begin str) (equal (char str 0) begin))

1 0

[isidorus-cvs] r363 - in trunk/src: TM-SPARQL unit_tests
by Lukas Giessmann 15 Dec '10

15 Dec '10

Author: lgiessmann Date: Wed Dec 15 04:51:01 2010 New Revision: 363 Log: TM-SPARQL: added some unit-tests for the processing of brackets in FILTER-statements => fixed a bug when a function is behind a supported operator without white space Modified: trunk/src/TM-SPARQL/sparql_filter.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 Wed Dec 15 04:51:01 2010 @@ -20,6 +20,10 @@ "Contains all supported operators, note some unary operators are handled as functions, e.g. + and -") +(defparameter *supported-brackets* + (list "(" ")") + "Contains all supported brackets in a list of strings.") + (defun make-sparql-parser-condition(rest-of-query entire-query expected) "Creates a spqrql-parser-error object." @@ -137,13 +141,16 @@ 'SPARQL-PARSER-ERROR :message (format nil "Invalid filter: \"~a\"~%" query-string))) - (when fragment-before-idx - (let ((inner-value - (subseq string-before fragment-before-idx))) - (if (and (> (length inner-value) 1) - (string-starts-with inner-value "(")) - (subseq inner-value 1) - inner-value)))))) + (if fragment-before-idx + (subseq string-before fragment-before-idx) + nil)))) + (when fragment-before + (mapcan #'(lambda(operator) + (when (and (string-starts-with fragment-before operator) + (> (length fragment-before) (length operator))) + (setf fragment-before + (string-after fragment-before operator)))) + (append *supported-operators* *supported-brackets*))) (if fragment-before (progn (when (or (string-starts-with fragment-before "?") @@ -160,7 +167,7 @@ (make-condition 'SPARQL-PARSER-ERROR :message - (format nil "Invalid character: ~a, expected characters: ~a" + (format nil "Invalid character: \"~a\", expected characters: ~a" fragment-before (append *supported-functions* delimiters))))) (if (find fragment-before *supported-functions* :test #'string=) nil Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Wed Dec 15 04:51:01 2010 @@ -1050,7 +1050,11 @@ (str-3 "DATATYPE(?var3) || +?var1 = -?var2 ?var1 ?var2 ?var3}") - (result-3 (tm-sparql::set-boundings dummy-object str-3))) + (result-3 (tm-sparql::set-boundings dummy-object str-3)) + (str-4 "DATATYPE(?var3) ||isLITERAL(+?var1 = -?var2)}") + (result-4 (tm-sparql::set-boundings dummy-object str-4)) + (str-5 "DATATYPE(?var3) ||(isLITERAL (+?var1 = -?var2))}") + (result-5 (tm-sparql::set-boundings dummy-object str-5))) (is-true result-1) (is-true result-2) (is (string= (getf result-1 :filter-string) @@ -1061,8 +1065,13 @@ (is (string= (getf result-2 :next-query) "}")) (is (string= (getf result-3 :filter-string) "DATATYPE(?var3) || +?var1 = -?var2")) - (is (string= (getf result-3 :next-query) (subseq str-3 34))))) - + (is (string= (getf result-3 :next-query) (subseq str-3 34))) + (is (string= (getf result-4 :filter-string) + "DATATYPE(?var3) ||isLITERAL(+?var1 = -?var2)")) + (is (string= (getf result-4 :next-query) "}")) + (is (string= (getf result-5 :filter-string) + "DATATYPE(?var3) ||(progn isLITERAL (+?var1 = -?var2))")) + (is (string= (getf result-5 :next-query) "}")))) (defun run-sparql-tests () (it.bese.fiveam:run! 'sparql-test:sparql-tests))

1 0

[isidorus-cvs] r362 - in trunk/src: TM-SPARQL base-tools unit_tests
by Lukas Giessmann 14 Dec '10

14 Dec '10

Author: lgiessmann Date: Tue Dec 14 16:07:50 2010 New Revision: 362 Log: TM-SPARQL: added some functions that separate a single filter-statement, handle bracketing, and handle unsupported functions Modified: trunk/src/TM-SPARQL/sparql_filter.lisp trunk/src/TM-SPARQL/sparql_parser.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 Tue Dec 14 16:07:50 2010 @@ -9,14 +9,42 @@ (in-package :TM-SPARQL) -(defun parse-filter (query-string query-object) - "A helper functions that returns a filter and the next-query string - in the form (:next-query string :filter object)." - (declare (String query-string) - (SPARQL-Query query-object)) + +(defparameter *supported-functions* + (list "BOUND" "isLITERAL" "STR" "DATATYPE" "REGEX") + "Contains all supported SPARQL-functions") + + +(defparameter *supported-operators* + (list "!" "||" "&&" "=" "!=" "<" "<=" ">" ">=" "+" "-" "*" "/") + "Contains all supported operators, note some unary operators + are handled as functions, e.g. + and -") + + +(defun make-sparql-parser-condition(rest-of-query entire-query expected) + "Creates a spqrql-parser-error object." + (declare (String rest-of-query entire-query expected)) + (let ((message + (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))) + + +(defgeneric parse-filter (construct query-string) + (:documentation "A helper functions that returns a filter and the next-query + string in the form (:next-query string :filter object).") + (:method ((construct SPARQL-Query) (query-string String)) + (let* ((result-set-boundings (set-boundings construct query-string)) + (filter-string (getf result-set-boundings :filter-string)) + (next-query (getf result-set-boundings :next-query)) + )))) ;;TODO: implement - ;; *replace () by (progn ) - ;; *replace ', """, ''' by " + ;; **replace () by (progn ) + ;; **replace ', """, ''' by ''' ;; *replace !x by (not x) ;; *replace +x by (1+ x) ;; *replace -x by (1- x) @@ -25,7 +53,147 @@ ;; *replace function(x), function(x, y), function(x, y, z) ;; by filter-function(x), (filter-function(x, y), filter-function(x, y, z) ;; *create and store this filter object - ) + + +(defgeneric set-boundings (construct query-string) + (:documentation "Returns a list of the form (:next-query <string> + :filter-string <string>). next-query is a string containing + the query after the filter and filter is a string + containing the actual filter. Additionally all free + '(' are transformed into '(progn' and all ', ''', \"\"\" + are transformed into \".") + (:method ((construct SPARQL-Query) (query-string String)) + (let ((filter-string "") + (open-brackets 0) + (result nil)) + (dotimes (idx (length query-string)) + (let ((current-char (subseq query-string idx (1+ idx)))) + (cond ((string= "(" current-char) + (setf open-brackets (1+ open-brackets)) + (if (progn-p query-string idx) + (push-string "(progn " filter-string) + (push-string current-char filter-string))) + ((string= ")" current-char) + (setf open-brackets (1- open-brackets)) + (when (< open-brackets 0) + (make-sparql-parser-condition + (subseq query-string idx) + (original-query construct) + "an opening bracket \"(\" is missing for the current closing one")) + (push-string current-char filter-string)) + ((or (string= "'" current-char) + (string= "\"" current-char)) + (let ((result (get-literal (subseq query-string idx)))) + (unless result + (make-sparql-parser-condition + (subseq query-string idx) + (original-query construct) + "a closing character for the given literal")) + (setf idx (- (1- (length query-string)) + (length (getf result :next-query)))) + (push-string (getf result :literal) filter-string))) + ((string= "#" current-char) + (let ((comment-string + (string-until (subseq query-string idx) + (string #\newline)))) + (setf idx (+ idx (length comment-string))))) + ((and (string= current-char (string #\newline)) + (= 0 open-brackets)) + (setf result + (list :next-query (subseq query-string idx) + :filter-string filter-string)) + (setf idx (1- (length query-string)))) + ((string= current-char "}") + (when (/= open-brackets 0) + (make-sparql-parser-condition + (subseq query-string idx) + (original-query construct) + "a valid filter, but the filter is not complete")) + (setf result + (list :next-query (subseq query-string idx) + :filter-string filter-string))) + (t + (push-string current-char filter-string))))) + result))) + + +(defun progn-p(query-string idx) + "Returns t if the ( at position idx in the filter string + represents a (progn) block." + (declare (String query-string) + (Integer idx)) + (let* ((delimiters (append (list " " (string #\Space) (string #\Tab) + (string #\Newline) (string #\cr) "(" ")") + *supported-operators*)) + (string-before (trim-whitespace-right (subseq query-string 0 idx))) + (fragment-before-idx + (search-first delimiters string-before :from-end t)) + (fragment-before + (if (and (not fragment-before-idx) + (and (> (length string-before) 0) + (not (find string-before *supported-functions* + :test #'string=)))) + (error (make-condition + 'SPARQL-PARSER-ERROR + :message (format nil "Invalid filter: \"~a\"~%" + query-string))) + (when fragment-before-idx + (let ((inner-value + (subseq string-before fragment-before-idx))) + (if (and (> (length inner-value) 1) + (string-starts-with inner-value "(")) + (subseq inner-value 1) + inner-value)))))) + (if fragment-before + (progn + (when (or (string-starts-with fragment-before "?") + (string-starts-with fragment-before "$")) + (error + (make-condition + '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=)) + (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=) + nil + t)) + (if (find string-before *supported-functions* :test #'string=) + nil + t)))) + + +(defun get-literal (query-string) + "Returns a list of the form (:next-query <string> :literal <string> + where next-query is the query after the found literal and literal + is the literal string." + (declare (String query-string)) + (cond ((or (string-starts-with query-string "\"\"\"") + (string-starts-with query-string "'''")) + (let ((literal-end + (find-literal-end (subseq query-string 3) (subseq query-string 0 3)))) + (when literal-end + (list :next-query (subseq query-string (+ 3 literal-end)) + :literal (concatenate 'string "'''" + (subseq query-string 3 literal-end) + "'''"))))) + ((or (string-starts-with query-string "\"") + (string-starts-with query-string "'")) + (let ((literal-end + (find-literal-end (subseq query-string 1)(subseq query-string 0 1)))) + (when literal-end + (list :next-query (subseq query-string (+ 1 literal-end)) + :literal (concatenate 'string "'''" + (subseq query-string 1 literal-end) + "'''"))))))) + (defun find-literal-end (query-string delimiter &optional (overall-pos 0)) "Returns the end of the literal corresponding to the passed delimiter Modified: trunk/src/TM-SPARQL/sparql_parser.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_parser.lisp (original) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Tue Dec 14 16:07:50 2010 @@ -9,19 +9,6 @@ (in-package :TM-SPARQL) -(defun make-sparql-parser-condition(rest-of-query entire-query expected) - "Creates a spqrql-parser-error object." - (declare (String rest-of-query entire-query expected)) - (let ((message - (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))) - - (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 Modified: trunk/src/base-tools/base-tools.lisp ============================================================================== --- trunk/src/base-tools/base-tools.lisp (original) +++ trunk/src/base-tools/base-tools.lisp Tue Dec 14 16:07:50 2010 @@ -150,16 +150,20 @@ nil))) -(defun search-first (search-strings main-string) +(defun search-first (search-strings main-string &key from-end) "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)) + (List search-strings) + (Boolean from-end)) (let ((positions - (remove-null (map 'list #'(lambda(search-str) - (search search-str main-string)) - search-strings)))) - (let ((sorted-positions (sort positions #'<))) + (remove-null + (map 'list #'(lambda(search-str) + (search search-str main-string :from-end from-end)) + search-strings)))) + (let ((sorted-positions (if from-end + (sort positions #'>) + (sort positions #'<)))) (when sorted-positions (first sorted-positions))))) Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Tue Dec 14 16:07:50 2010 @@ -29,7 +29,8 @@ :test-set-result-3 :test-set-result-4 :test-set-result-5 - :test-result)) + :test-result + :test-set-boundings)) (in-package :sparql-test) @@ -1038,6 +1039,29 @@ (getf (first (result q-obj-2)) :result) :test #'string=))))))))) +(test test-set-boundings + "Tests various cases of the function set-boundings" + (let* ((dummy-object (make-instance 'TM-SPARQL::SPARQL-Query :query " ")) + (str-1 "BOUND(( (?var) )) || (isLITERAL($var) && ?var = 'abc')}") + (result-1 (tm-sparql::set-boundings dummy-object str-1)) + (str-2 + "(REGEX(?var1, '''''', ?var3) || (?var1 > ?var3 && (STR( ?var) = \"abc\")))}") + (result-2 (tm-sparql::set-boundings dummy-object str-2)) + (str-3 + "DATATYPE(?var3) || +?var1 = -?var2 + ?var1 ?var2 ?var3}") + (result-3 (tm-sparql::set-boundings dummy-object str-3))) + (is-true result-1) + (is-true result-2) + (is (string= (getf result-1 :filter-string) + "BOUND((progn (progn ?var) )) || (progn isLITERAL($var) && ?var = '''abc''')")) + (is (string= (getf result-1 :next-query) "}")) + (is (string= (getf result-2 :filter-string) + "(progn REGEX(?var1, '''''', ?var3) || (progn ?var1 > ?var3 && (progn STR( ?var) = '''abc''')))")) + (is (string= (getf result-2 :next-query) "}")) + (is (string= (getf result-3 :filter-string) + "DATATYPE(?var3) || +?var1 = -?var2")) + (is (string= (getf result-3 :next-query) (subseq str-3 34))))) (defun run-sparql-tests ()

1 0

[isidorus-cvs] r361 - in trunk/src: . TM-SPARQL unit_tests
by Lukas Giessmann 14 Dec '10

14 Dec '10

Author: lgiessmann Date: Tue Dec 14 11:01:38 2010 New Revision: 361 Log: TM-SPARQL: changed some function in the sparql-parser into mehtods=>SPARQL-Query; created the structure for the filter parser Added: trunk/src/TM-SPARQL/sparql_filter.lisp Modified: trunk/src/TM-SPARQL/sparql_parser.lisp trunk/src/isidorus.asd trunk/src/unit_tests/sparql_test.lisp Added: trunk/src/TM-SPARQL/sparql_filter.lisp ============================================================================== --- (empty file) +++ trunk/src/TM-SPARQL/sparql_filter.lisp Tue Dec 14 11:01:38 2010 @@ -0,0 +1,45 @@ +;;+----------------------------------------------------------------------------- +;;+ Isidorus +;;+ (c) 2008-2010 Marc Kuester, Christoph Ludwig, Lukas Georgieff +;;+ +;;+ Isidorus is freely distributable under the LLGPL license. +;;+ You can find a detailed description in trunk/docs/LLGPL-LICENSE.txt and +;;+ trunk/docs/LGPL-LICENSE.txt. +;;+----------------------------------------------------------------------------- + +(in-package :TM-SPARQL) + +(defun parse-filter (query-string query-object) + "A helper functions that returns a filter and the next-query string + in the form (:next-query string :filter object)." + (declare (String query-string) + (SPARQL-Query query-object)) + ;;TODO: implement + ;; *replace () by (progn ) + ;; *replace ', """, ''' by " + ;; *replace !x by (not x) + ;; *replace +x by (1+ x) + ;; *replace -x by (1- x) + ;; *replace x operator y by (filter-operator x y) + ;; *=, !=, <, >, <=, >=, +, -, *, /, ||, && + ;; *replace function(x), function(x, y), function(x, y, z) + ;; by filter-function(x), (filter-function(x, y), filter-function(x, y, z) + ;; *create and store this filter object + ) + +(defun find-literal-end (query-string delimiter &optional (overall-pos 0)) + "Returns the end of the literal corresponding to the passed delimiter + string. The query-string must start after the opening literal delimiter. + The return value is an int that represents the start index of closing + delimiter. delimiter must be either \", ', or '''. + If the returns value is nil, there is no closing delimiter." + (declare (String query-string delimiter) + (Integer overall-pos)) + (let ((current-pos (search delimiter query-string))) + (if current-pos + (if (string-ends-with (subseq query-string 0 current-pos) "\\") + (find-literal-end (subseq query-string (+ current-pos + (length delimiter))) + delimiter (+ overall-pos current-pos 1)) + (+ overall-pos current-pos (length delimiter))) + nil))) \ 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 Tue Dec 14 11:01:38 2010 @@ -70,7 +70,7 @@ (parse-base construct (string-after trimmed-query-string "BASE") #'parser-start)) ((= (length trimmed-query-string) 0) - ;; If there is only a BASE and/or PREFIX statement return an + ;; If there is only a BASE and/or PREFIX statement return a ;; query-object with the result nil construct) (t @@ -128,7 +128,7 @@ trimmed-str (original-query construct) "FILTER, BASE, or triple. Grouping is currently no implemented."))) ((string-starts-with trimmed-str "FILTER") - nil) ;TODO: parse-filter and store it in construct => extend class + (parse-filter (string-after trimmed-str "FILTER") construct)) ((string-starts-with trimmed-str "OPTIONAL") (error (make-sparql-parser-condition trimmed-str (original-query construct) @@ -144,100 +144,89 @@ (parse-triple construct trimmed-str :last-subject last-subject)))))) -(defun parse-filter (query-string query-object) - "A helper functions that returns a filter and the next-query string - in the form (:next-query string :filter object)." - ;; !, +, -, *, /, (, ), &&, ||, =, !=, <, >, >=, <=, REGEX(string, pattern) - (declare (String query-string) - (SPARQL-Query query-object)) - ;;TODO: implement - ) - - -(defun parse-triple-elem (query-string query-object &key (literal-allowed nil)) - "A helper function to parse a subject or predicate of an RDF triple." - (declare (String query-string) - (SPARQL-Query query-object) - (Boolean literal-allowed)) - (let ((trimmed-str (cut-comment query-string))) - (cond ((string-starts-with trimmed-str "a ") ;;rdf:type - (list :next-query (cut-comment (subseq trimmed-str 1)) - :value (make-instance 'SPARQL-Triple-Elem - :elem-type 'IRI - :value *type-psi*))) - ((string-starts-with trimmed-str "<") - (parse-base-suffix-pair trimmed-str query-object)) - ((or (string-starts-with trimmed-str "?") - (string-starts-with trimmed-str "$")) - (let ((result - (parse-variable-name trimmed-str query-object - :additional-delimiters (list "}")))) - (list :next-query (cut-comment (getf result :next-query)) +(defgeneric parse-triple-elem (construct query-string &key literal-allowed) + (:documentation "A helper function to parse a subject or predicate of an RDF triple.") + (:method ((construct SPARQL-Query) (query-string String) + &key (literal-allowed nil)) + (declare (Boolean literal-allowed)) + (let ((trimmed-str (cut-comment query-string))) + (cond ((string-starts-with trimmed-str "a ") ;;rdf:type + (list :next-query (cut-comment (subseq trimmed-str 1)) :value (make-instance 'SPARQL-Triple-Elem - :elem-type 'VARIABLE - :value (getf result :value))))) - (t - (if (or (string-starts-with-digit trimmed-str) - (string-starts-with trimmed-str "\"") - (string-starts-with trimmed-str "true") - (string-starts-with trimmed-str "false") - (string-starts-with trimmed-str "'")) - (progn - (unless literal-allowed - (error (make-sparql-parser-condition - trimmed-str (original-query query-object) - "an IRI of the form prefix:suffix or <iri> but found a literal."))) - (parse-literal-elem trimmed-str query-object)) - (parse-prefix-suffix-pair trimmed-str query-object)))))) - - -(defun parse-literal-elem (query-string query-object) - "A helper-function that returns a literal vaue of the form - (:value (:value object :literal-type string :literal-lang - string :type <'LITERAL>) :next-query string)." - (declare (String query-string) - (SPARQL-Query query-object)) - (let* ((trimmed-str (cut-comment query-string)) - (value-type-lang-query - (cond ((or (string-starts-with trimmed-str "\"") + :elem-type 'IRI + :value *type-psi*))) + ((string-starts-with trimmed-str "<") + (parse-base-suffix-pair construct trimmed-str)) + ((or (string-starts-with trimmed-str "?") + (string-starts-with trimmed-str "$")) + (let ((result + (parse-variable-name construct trimmed-str + :additional-delimiters (list "}")))) + (list :next-query (cut-comment (getf result :next-query)) + :value (make-instance 'SPARQL-Triple-Elem + :elem-type 'VARIABLE + :value (getf result :value))))) + (t + (if (or (string-starts-with-digit trimmed-str) + (string-starts-with trimmed-str "\"") + (string-starts-with trimmed-str "true") + (string-starts-with trimmed-str "false") (string-starts-with trimmed-str "'")) - (parse-literal-string-value trimmed-str query-object)) - ((string-starts-with trimmed-str "true") - (list :value t :type *xml-boolean* - :next-query (subseq trimmed-str (length "true")))) - ((string-starts-with trimmed-str "false") - (list :value nil :type *xml-boolean* - :next-query (subseq trimmed-str (length "false")))) - ((string-starts-with-digit trimmed-str) - (parse-literal-number-value trimmed-str query-object))))) - (list :next-query (getf value-type-lang-query :next-query) - :value (make-instance - 'SPARQL-Triple-Elem - :elem-type 'LITERAL - :value (getf value-type-lang-query :value) - :literal-lang (getf value-type-lang-query :lang) - :literal-datatype (getf value-type-lang-query :type))))) - - -(defun parse-literal-string-value (query-string query-object) - "A helper function that parses a string that is a literal. - The return value is of the form - (list :value object :type string :lang string :next-query string)." - (declare (String query-string) - (SPARQL-Query query-object)) - (let* ((trimmed-str (cut-comment query-string)) - (result-1 (separate-literal-value trimmed-str query-object)) - (after-literal-value (getf result-1 :next-query)) - (l-value (getf result-1 :literal)) - (result-2 (separate-literal-lang-or-type - after-literal-value query-object)) - (l-type (if (getf result-2 :type) - (getf result-2 :type) - *xml-string*)) - (l-lang (getf result-2 :lang)) - (next-query (getf result-2 :next-query))) - (list :next-query next-query :lang l-lang :type l-type - :value (cast-literal l-value l-type)))) + (progn + (unless literal-allowed + (error (make-sparql-parser-condition + trimmed-str (original-query construct) + "an IRI of the form prefix:suffix or <iri> but found a literal."))) + (parse-literal-elem construct trimmed-str)) + (parse-prefix-suffix-pair construct trimmed-str))))))) + + +(defgeneric parse-literal-elem (construct query-string) + (:documentation "A helper-function that returns a literal vaue of the form + (:value (:value object :literal-type string :literal-lang + string :type <'LITERAL>) :next-query string).") + (:method ((construct SPARQL-Query) (query-string String)) + (let* ((trimmed-str (cut-comment query-string)) + (value-type-lang-query + (cond ((or (string-starts-with trimmed-str "\"") + (string-starts-with trimmed-str "'")) + (parse-literal-string-value construct trimmed-str)) + ((string-starts-with trimmed-str "true") + (list :value t :type *xml-boolean* + :next-query (subseq trimmed-str (length "true")))) + ((string-starts-with trimmed-str "false") + (list :value nil :type *xml-boolean* + :next-query (subseq trimmed-str (length "false")))) + ((string-starts-with-digit trimmed-str) + (parse-literal-number-value construct trimmed-str))))) + (list :next-query (getf value-type-lang-query :next-query) + :value (make-instance + 'SPARQL-Triple-Elem + :elem-type 'LITERAL + :value (getf value-type-lang-query :value) + :literal-lang (getf value-type-lang-query :lang) + :literal-datatype (getf value-type-lang-query :type)))))) + + +(defgeneric parse-literal-string-value (construct query-string) + (:documentation "A helper function that parses a string that is a literal. + The return value is of the form + (list :value object :type string :lang string + :next-query string).") + (:method ((construct SPARQL-Query) (query-string String)) + (let* ((trimmed-str (cut-comment query-string)) + (result-1 (separate-literal-value construct trimmed-str)) + (after-literal-value (getf result-1 :next-query)) + (l-value (getf result-1 :literal)) + (result-2 (separate-literal-lang-or-type + construct after-literal-value)) + (l-type (if (getf result-2 :type) + (getf result-2 :type) + *xml-string*)) + (l-lang (getf result-2 :lang)) + (next-query (getf result-2 :next-query))) + (list :next-query next-query :lang l-lang :type l-type + :value (cast-literal l-value l-type))))) (defun cast-literal (literal-value literal-type) @@ -278,171 +267,150 @@ (write-to-string literal-value))))) -(defun separate-literal-lang-or-type (query-string query-object) - "A helper function that returns (:next-query string :lang string - :type string). Only one of :lang and :type can be set, the other - element is set to nil. The query string must be the string direct - after the closing literal bounding." - (declare (String query-string) - (SPARQL-Query query-object)) - (let ((delimiters-1 (list "." ";" "}" " " (string #\tab) - (string #\newline))) - (delimiters-2 (list " ." ". " ";" "}" " " (string #\tab) - (string #\newline) - (concatenate 'string "." (string #\newline)) - (concatenate 'string "." (string #\tab))))) - (cond ((string-starts-with query-string "@") - (let ((end-pos (search-first delimiters-1 - (subseq query-string 1)))) - (unless end-pos - (error (make-sparql-parser-condition - query-string (original-query query-object) - "'.', ';', '}', ' ', '\t', or '\n'"))) - (list :next-query (subseq (subseq query-string 1) end-pos) - :lang (subseq (subseq query-string 1) 0 end-pos) - :type nil))) - ((string-starts-with query-string "^^") - (let ((end-pos (search-first delimiters-2 (subseq query-string 2)))) - (unless end-pos - (error (make-sparql-parser-condition - query-string (original-query query-object) - "'. ', ,' .', ';', '}', ' ', '\t', or '\n'"))) - (let* ((type-str (subseq (subseq query-string 2) 0 end-pos)) - (next-query (subseq (subseq query-string 2) end-pos)) - (final-type (if (get-prefix query-object type-str) - (get-prefix query-object type-str) - type-str))) - (list :next-query (cut-comment next-query) - :type final-type :lang nil)))) - (t - (list :next-query (cut-comment query-string) :type nil :lang nil))))) - - -(defun separate-literal-value (query-string query-object) - "A helper function that returns (:next-query string :literal string). - The literal string contains the pure literal value." - (declare (String query-string) - (SPARQL-Query query-object)) - (let* ((trimmed-str (cut-comment query-string)) - (delimiter (cond ((string-starts-with trimmed-str "\"") - "\"") - ((string-starts-with trimmed-str "'''") - "'''") - ((string-starts-with trimmed-str "'") - "'") - (t - (error (make-sparql-parser-condition - trimmed-str (original-query query-object) - "a literal starting with ', ''', or \""))))) - (literal-end (find-literal-end (subseq trimmed-str (length delimiter)) - delimiter 0))) - (list :next-query (subseq trimmed-str (+ literal-end (length delimiter))) - :literal (subseq trimmed-str (length delimiter) literal-end)))) - - -(defun find-literal-end (query-string delimiter &optional (overall-pos 0)) - "Returns the end of the literal corresponding to the passed delimiter - string. The query-string must start after the opening literal delimiter. - The return value is an int that represents the start index of closing - delimiter. delimiter must be either \", ', or '''. - If the returns value is nil, there is no closing delimiter." - (declare (String query-string delimiter) - (Integer overall-pos)) - (let ((current-pos (search delimiter query-string))) - (if current-pos - (if (string-ends-with (subseq query-string 0 current-pos) "\\") - (find-literal-end (subseq query-string (+ current-pos - (length delimiter))) - delimiter (+ overall-pos current-pos 1)) - (+ overall-pos current-pos (length delimiter))) - nil))) - - -(defun parse-literal-number-value (query-string query-object) - "A helper function that parses any number that is a literal. - The return value is of the form - (list :value nil :type string :next-query string." - (declare (String query-string) - (SPARQL-Query query-object)) - (let* ((trimmed-str (cut-comment query-string)) - (triple-delimiters - (list ". " ";" " " (string #\tab) - (string #\newline) "}")) - (end-pos (search-first triple-delimiters - trimmed-str))) - (unless end-pos - (error (make-sparql-parser-condition - trimmed-str (original-query query-object) - "'. ', , ';' ' ', '\\t', '\\n' or '}'"))) - (let* ((literal-number - (read-from-string (subseq trimmed-str 0 end-pos))) - (number-type - (if (search "." (subseq trimmed-str 0 end-pos)) - *xml-double* ;could also be an xml:decimal, since the doucble has - ;a bigger range it shouldn't matter - *xml-integer*))) - (unless (numberp literal-number) +(defgeneric separate-literal-lang-or-type (construct query-string) + (:documentation "A helper function that returns (:next-query string + :lang string :type string). Only one of :lang and + :type can be set, the other element is set to nil. + The query string must be the string direct after + the closing literal bounding.") + (:method ((construct SPARQL-Query) (query-string String)) + (let ((delimiters-1 (list "." ";" "}" " " (string #\tab) + (string #\newline))) + (delimiters-2 (list " ." ". " ";" "}" " " (string #\tab) + (string #\newline) + (concatenate 'string "." (string #\newline)) + (concatenate 'string "." (string #\tab))))) + (cond ((string-starts-with query-string "@") + (let ((end-pos (search-first delimiters-1 + (subseq query-string 1)))) + (unless end-pos + (error (make-sparql-parser-condition + query-string (original-query construct) + "'.', ';', '}', ' ', '\t', or '\n'"))) + (list :next-query (subseq (subseq query-string 1) end-pos) + :lang (subseq (subseq query-string 1) 0 end-pos) + :type nil))) + ((string-starts-with query-string "^^") + (let ((end-pos (search-first delimiters-2 (subseq query-string 2)))) + (unless end-pos + (error (make-sparql-parser-condition + query-string (original-query construct) + "'. ', ,' .', ';', '}', ' ', '\t', or '\n'"))) + (let* ((type-str (subseq (subseq query-string 2) 0 end-pos)) + (next-query (subseq (subseq query-string 2) end-pos)) + (final-type (if (get-prefix construct type-str) + (get-prefix construct type-str) + type-str))) + (list :next-query (cut-comment next-query) + :type final-type :lang nil)))) + (t + (list :next-query (cut-comment query-string) :type nil :lang nil)))))) + + +(defgeneric separate-literal-value (construct query-string) + (:documentation "A helper function that returns (:next-query string + :literal string). The literal string contains the + pure literal value.") + (:method ((construct SPARQL-Query) (query-string String)) + (let* ((trimmed-str (cut-comment query-string)) + (delimiter (cond ((string-starts-with trimmed-str "\"") + "\"") + ((string-starts-with trimmed-str "'''") + "'''") + ((string-starts-with trimmed-str "'") + "'") + (t + (error (make-sparql-parser-condition + trimmed-str (original-query construct) + "a literal starting with ', ''', or \""))))) + (literal-end (find-literal-end (subseq trimmed-str (length delimiter)) + delimiter 0))) + (list :next-query (subseq trimmed-str (+ literal-end (length delimiter))) + :literal (subseq trimmed-str (length delimiter) literal-end))))) + + +(defgeneric parse-literal-number-value (construct query-string) + (:documentation "A helper function that parses any number that is a literal. + The return value is of the form + (list :value nil :type string :next-query string.") + (:method ((construct SPARQL-Query) (query-string String)) + (let* ((trimmed-str (cut-comment query-string)) + (triple-delimiters + (list ". " ";" " " (string #\tab) + (string #\newline) "}")) + (end-pos (search-first triple-delimiters + trimmed-str))) + (unless end-pos (error (make-sparql-parser-condition - trimmed-str (original-query query-object) - "a valid number of the form '1', '1.3', 1.0e6'"))) - (list :value literal-number :type number-type - :next-query (subseq trimmed-str end-pos))))) - - -(defun parse-base-suffix-pair (query-string query-object) - "A helper function that returns a list of the form - (list :next-query string :value (:value uri :type 'IRI))." - (declare (String query-string) - (SPARQL-Query query-object)) - (let* ((trimmed-str (cut-comment query-string)) - (result (parse-closed-value trimmed-str query-object)) - (result-uri - (if (or (absolute-uri-p (getf result :value)) - (not (base-value query-object))) - (getf result :value) - (concatenate-uri (base-value query-object) - (getf result :value)))) - (next-query (getf result :next-query))) - (list :next-query (cut-comment next-query) - :value (make-instance 'SPARQL-Triple-Elem - :elem-type 'IRI - :value result-uri)))) - - -(defun parse-prefix-suffix-pair(query-string query-object) - "A helper function that returns a list of the form - (list :next-query string :value (:value uri :type 'IRI))." - (declare (String query-string) - (SPARQL-Query query-object)) - (let* ((trimmed-str (cut-comment query-string)) - (delimiters (list "." ";" "}" "<" " " (string #\newline) - (string #\tab) "#")) - (end-pos (search-first delimiters trimmed-str)) - (elem-str (when end-pos - (subseq trimmed-str 0 end-pos))) - (prefix (when elem-str - (string-until elem-str ":"))) - (suffix (when prefix - (string-after elem-str ":"))) - (full-url - (when (and suffix prefix) - (get-prefix query-object (concatenate 'string prefix ":" suffix))))) - (unless (and end-pos prefix suffix) - (error (make-sparql-parser-condition - trimmed-str (original-query query-object) - "An IRI of the form prefix:suffix"))) - (unless full-url - (error (make-condition - 'sparql-parser-error - :message (format nil "The prefix in \"~a:~a\" is not registered" - prefix suffix)))) - (list :next-query (cut-comment - (string-after - trimmed-str - (concatenate 'string prefix ":" suffix))) - :value (make-instance 'SPARQL-Triple-Elem - :elem-type 'IRI - :value full-url)))) + trimmed-str (original-query construct) + "'. ', , ';' ' ', '\\t', '\\n' or '}'"))) + (let* ((literal-number + (read-from-string (subseq trimmed-str 0 end-pos))) + (number-type + (if (search "." (subseq trimmed-str 0 end-pos)) + *xml-double* ;could also be an xml:decimal, since the doucble has + ;a bigger range it shouldn't matter + *xml-integer*))) + (unless (numberp literal-number) + (error (make-sparql-parser-condition + trimmed-str (original-query construct) + "a valid number of the form '1', '1.3', 1.0e6'"))) + (list :value literal-number :type number-type + :next-query (subseq trimmed-str end-pos)))))) + + +(defgeneric parse-base-suffix-pair (construct query-string) + (:documentation "A helper function that returns a list of the form + (list :next-query string :value (:value uri :type 'IRI)).") + (:method ((construct SPARQL-Query) (query-string String)) + (let* ((trimmed-str (cut-comment query-string)) + (result (parse-closed-value trimmed-str construct)) + (result-uri + (if (or (absolute-uri-p (getf result :value)) + (not (base-value construct))) + (getf result :value) + (concatenate-uri (base-value construct) + (getf result :value)))) + (next-query (getf result :next-query))) + (list :next-query (cut-comment next-query) + :value (make-instance 'SPARQL-Triple-Elem + :elem-type 'IRI + :value result-uri))))) + + +(defgeneric parse-prefix-suffix-pair(construct query-string) + (:documentation "A helper function that returns a list of the form + (list :next-query string :value (:value uri :type 'IRI)).") + (:method ((construct SPARQL-Query) (query-string String)) + (let* ((trimmed-str (cut-comment query-string)) + (delimiters (list "." ";" "}" "<" " " (string #\newline) + (string #\tab) "#")) + (end-pos (search-first delimiters trimmed-str)) + (elem-str (when end-pos + (subseq trimmed-str 0 end-pos))) + (prefix (when elem-str + (string-until elem-str ":"))) + (suffix (when prefix + (string-after elem-str ":"))) + (full-url + (when (and suffix prefix) + (get-prefix construct (concatenate 'string prefix ":" suffix))))) + (unless (and end-pos prefix suffix) + (error (make-sparql-parser-condition + trimmed-str (original-query construct) + "An IRI of the form prefix:suffix"))) + (unless full-url + (error (make-condition + 'sparql-parser-error + :message (format nil "The prefix in \"~a:~a\" is not registered" + prefix suffix)))) + (list :next-query (cut-comment + (string-after + trimmed-str + (concatenate 'string prefix ":" suffix))) + :value (make-instance 'SPARQL-Triple-Elem + :elem-type 'IRI + :value full-url))))) (defgeneric parse-triple (construct query-string &key last-subject) @@ -452,14 +420,15 @@ (let* ((trimmed-str (cut-comment query-string)) (subject-result (if last-subject ;;is used after a ";" last-subject - (parse-triple-elem trimmed-str construct))) + (parse-triple-elem construct trimmed-str))) (predicate-result (parse-triple-elem + construct (if last-subject trimmed-str - (getf subject-result :next-query)) - construct)) - (object-result (parse-triple-elem (getf predicate-result :next-query) - construct :literal-allowed t))) + (getf subject-result :next-query)))) + (object-result (parse-triple-elem construct + (getf predicate-result :next-query) + :literal-allowed t))) (add-triple construct (make-instance 'SPARQL-Triple :subject (if last-subject @@ -487,42 +456,42 @@ (if (string-starts-with trimmed-str "*") (progn (add-variable construct "*") (parse-variables construct (string-after trimmed-str "*"))) - (let ((result (parse-variable-name trimmed-str construct))) + (let ((result (parse-variable-name construct trimmed-str))) (add-variable construct (getf result :value)) (parse-variables construct (getf result :next-query)))))))) -(defun parse-variable-name (query-string query-object &key additional-delimiters) - "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) - (List additional-delimiters)) - (let ((trimmed-str (cut-comment query-string)) - (delimiters (append - (list " " "?" "$" "." (string #\newline) (string #\tab)) - additional-delimiters))) - (unless (or (string-starts-with trimmed-str "?") - (string-starts-with trimmed-str "$")) - (error (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-variable-name (construct query-string &key additional-delimiters) + (:documentation "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).") + (:method ((construct SPARQL-Query) (query-string String) + &key (additional-delimiters)) + (declare (List additional-delimiters)) + (let ((trimmed-str (cut-comment query-string)) + (delimiters (append + (list " " "?" "$" "." (string #\newline) (string #\tab)) + additional-delimiters))) + (unless (or (string-starts-with trimmed-str "?") + (string-starts-with trimmed-str "$")) + (error (make-sparql-parser-condition + trimmed-str (original-query construct) "? 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 construct) + "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 construct) + "a variable name")) + (subseq var-name 1)))) + (list :next-query next-query :value normalized-var-name))))) (defgeneric parse-base (construct query-string next-fun) Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Tue Dec 14 11:01:38 2010 @@ -42,8 +42,10 @@ :depends-on ("constants" "base-tools")) (:module "TM-SPARQL" :components ((:file "sparql") + (:file "sparql_filter" + :depends-on ("sparql")) (:file "sparql_parser" - :depends-on ("sparql"))) + :depends-on ("sparql" "sparql_filter"))) :depends-on ("constants" "base-tools" "model")) (:module "xml" :components ((:module "xtm" Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Tue Dec 14 11:01:38 2010 @@ -169,7 +169,7 @@ (query-9 (concatenate 'string "\"13e4\"^^" *xml-boolean* " .")) (dummy-object (make-instance 'SPARQL-Query :query ""))) (is-true dummy-object) - (let ((res (tm-sparql::parse-literal-elem query-1 dummy-object))) + (let ((res (tm-sparql::parse-literal-elem dummy-object query-1))) (is (string= (getf res :next-query) ".")) (is (string= (tm-sparql::value (getf res :value)) "literal-value")) @@ -178,35 +178,35 @@ (is (string= (tm-sparql::literal-datatype (getf res :value)) *xml-string*)) (is (eql (tm-sparql::elem-type (getf res :value)) 'TM-SPARQL::LITERAL))) - (let ((res (tm-sparql::parse-literal-elem query-2 dummy-object))) + (let ((res (tm-sparql::parse-literal-elem dummy-object query-2))) (is (string= (getf res :next-query) ".")) (is (eql (tm-sparql::value (getf res :value)) t)) (is-false (tm-sparql::literal-lang (getf res :value))) (is (string= (tm-sparql::literal-datatype (getf res :value)) *xml-boolean*)) (is (eql (tm-sparql::elem-type (getf res :value)) 'TM-SPARQL::LITERAL))) - (let ((res (tm-sparql::parse-literal-elem query-3 dummy-object))) + (let ((res (tm-sparql::parse-literal-elem dummy-object query-3))) (is (string= (getf res :next-query) "}")) (is (eql (tm-sparql::value (getf res :value)) nil)) (is-false (tm-sparql::literal-lang (getf res :value))) (is (string= (tm-sparql::literal-datatype (getf res :value)) *xml-boolean*)) (is (eql (tm-sparql::elem-type (getf res :value)) 'TM-SPARQL::LITERAL))) - (let ((res (tm-sparql::parse-literal-elem query-4 dummy-object))) + (let ((res (tm-sparql::parse-literal-elem dummy-object query-4))) (is (string= (getf res :next-query) (string #\tab))) (is (= (tm-sparql::value (getf res :value)) 1234.43e10)) (is-false (tm-sparql::literal-lang (getf res :value))) (is (string= (tm-sparql::literal-datatype (getf res :value)) *xml-double*)) (is (eql (tm-sparql::elem-type (getf res :value)) 'TM-SPARQL::LITERAL))) - (let ((res (tm-sparql::parse-literal-elem query-5 dummy-object))) + (let ((res (tm-sparql::parse-literal-elem dummy-object query-5))) (is (string= (getf res :next-query) ";")) (is (eql (tm-sparql::value (getf res :value)) t)) (is-false (tm-sparql::literal-lang (getf res :value))) (is (string= (tm-sparql::literal-datatype (getf res :value)) *xml-boolean*)) (is (eql (tm-sparql::elem-type (getf res :value)) 'TM-SPARQL::LITERAL))) - (let ((res (tm-sparql::parse-literal-elem query-6 dummy-object))) + (let ((res (tm-sparql::parse-literal-elem dummy-object query-6))) (is (string= (getf res :next-query) (concatenate 'string "." (string #\newline)))) (is (eql (tm-sparql::value (getf res :value)) 123.4)) @@ -214,7 +214,7 @@ (is (string= (tm-sparql::literal-datatype (getf res :value)) *xml-double*)) (is (eql (tm-sparql::elem-type (getf res :value)) 'TM-SPARQL::LITERAL))) - (let ((res (tm-sparql::parse-literal-elem query-7 dummy-object))) + (let ((res (tm-sparql::parse-literal-elem dummy-object query-7))) (is (string= (getf res :next-query) ".")) (is (string= (tm-sparql::value (getf res :value)) "Just a test @@ -225,9 +225,9 @@ *xml-string*)) (is (eql (tm-sparql::elem-type (getf res :value)) 'TM-SPARQL::LITERAL))) (signals sparql-parser-error - (tm-sparql::parse-literal-elem query-8 dummy-object)) + (tm-sparql::parse-literal-elem dummy-object query-8)) (signals sparql-parser-error - (tm-sparql::parse-literal-elem query-9 dummy-object)))) + (tm-sparql::parse-literal-elem dummy-object query-9)))) (test test-parse-triple-elem @@ -245,40 +245,40 @@ (var 'TM-SPARQL::VARIABLE) (iri 'TM-SPARQL::IRI)) (tm-sparql::add-prefix dummy-object "pref" "http://prefix.value") - (let ((res (tm-sparql::parse-triple-elem query-1 dummy-object))) + (let ((res (tm-sparql::parse-triple-elem dummy-object query-1))) (is (string= (getf res :next-query) ".")) (is (string= (tm-sparql::value (getf res :value)) "var1")) (is (eql (tm-sparql::elem-type (getf res :value)) var))) - (let ((res (tm-sparql::parse-triple-elem query-2 dummy-object))) + (let ((res (tm-sparql::parse-triple-elem dummy-object query-2))) (is (string= (getf res :next-query) ";")) (is (string= (tm-sparql::value (getf res :value)) "var2")) (is (eql (tm-sparql::elem-type (getf res :value)) var))) - (let ((res (tm-sparql::parse-triple-elem query-3 dummy-object))) + (let ((res (tm-sparql::parse-triple-elem dummy-object query-3))) (is (string= (getf res :next-query) "}")) (is (string= (tm-sparql::value (getf res :value)) "var3")) (is (eql (tm-sparql::elem-type (getf res :value)) var))) - (let ((res (tm-sparql::parse-triple-elem query-4 dummy-object))) + (let ((res (tm-sparql::parse-triple-elem dummy-object query-4))) (is (string= (getf res :next-query) ".")) (is (string= (tm-sparql::value (getf res :value)) "http://full.url")) (is (eql (tm-sparql::elem-type (getf res :value)) iri))) - (let ((res (tm-sparql::parse-triple-elem query-5 dummy-object))) + (let ((res (tm-sparql::parse-triple-elem dummy-object query-5))) (is (string= (getf res :next-query) "}")) (is (string= (tm-sparql::value (getf res :value)) "http://base.value/url-suffix")) (is (eql (tm-sparql::elem-type (getf res :value)) iri))) - (let ((res (tm-sparql::parse-triple-elem query-6 dummy-object))) + (let ((res (tm-sparql::parse-triple-elem dummy-object query-6))) (is (string= (getf res :next-query) ".")) (is (string= (tm-sparql::value (getf res :value)) "http://prefix.value/suffix")) (is (eql (tm-sparql::elem-type (getf res :value)) iri))) - (let ((res (tm-sparql::parse-triple-elem query-7 dummy-object))) + (let ((res (tm-sparql::parse-triple-elem dummy-object query-7))) (is (string= (getf res :next-query) "}")) (is (string= (tm-sparql::value (getf res :value)) "http://prefix.value/suffix")) (is (eql (tm-sparql::elem-type (getf res :value)) iri))) (signals sparql-parser-error - (tm-sparql::parse-triple-elem query-8 dummy-object)))) + (tm-sparql::parse-triple-elem dummy-object query-8)))) (test test-parse-group-1

1 0

[isidorus-cvs] r360 - in trunk/src: . TM-SPARQL base-tools json rest_interface
by Lukas Giessmann 04 Dec '10

04 Dec '10

Author: lgiessmann Date: Sat Dec 4 16:05:05 2010 New Revision: 360 Log: fixed ticket #87 => added a JSON-handler for SPARQL-requests; fixed a bug in base-tools:trim-whitespace => #\cr is also added as a whitespace character Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_parser.lisp trunk/src/base-tools/base-tools.lisp trunk/src/isidorus.asd trunk/src/json/json_exporter.lisp trunk/src/rest_interface/rest-interface.lisp trunk/src/rest_interface/set-up-json-interface.lisp Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Sat Dec 4 16:05:05 2010 @@ -759,9 +759,9 @@ (let ((result-lists (make-result-lists construct))) (reduce-results construct result-lists) (let* ((response-variables - (if (*-p construct) - (all-variables construct) - (variables construct))) + (reverse (if (*-p construct) + (all-variables construct) + (variables construct)))) (cleaned-results (make-result-lists construct))) (map 'list #'(lambda(response-variable) (list :variable response-variable Modified: trunk/src/TM-SPARQL/sparql_parser.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_parser.lisp (original) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Sat Dec 4 16:05:05 2010 @@ -76,7 +76,8 @@ (t (error (make-sparql-parser-condition trimmed-query-string (original-query construct) - "SELECT, PREFIX or BASE"))))))) + (format nil "SELECT, PREFIX or BASE, but found: ~a..." + (subseq trimmed-query-string 0 10))))))))) (defgeneric parse-select (construct query-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 4 16:05:05 2010 @@ -70,19 +70,19 @@ (defun trim-whitespace-left (value) "Uses string-left-trim with a predefined character-list." (declare (String value)) - (string-left-trim '(#\Space #\Tab #\Newline) value)) + (string-left-trim '(#\Space #\Tab #\Newline #\cr) value)) (defun trim-whitespace-right (value) "Uses string-right-trim with a predefined character-list." (declare (String value)) - (string-right-trim '(#\Space #\Tab #\Newline) value)) + (string-right-trim '(#\Space #\Tab #\Newline #\cr) value)) (defun trim-whitespace (value) "Uses string-trim with a predefined character-list." (declare (String value)) - (string-trim '(#\Space #\Tab #\Newline) value)) + (string-trim '(#\Space #\Tab #\Newline #\cr) value)) (defun string-starts-with (str prefix &key (ignore-case nil)) Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Sat Dec 4 16:05:05 2010 @@ -104,6 +104,7 @@ :depends-on ("model" "atom" "xml" + "TM-SPARQL" "json" "threading")) (:module "unit_tests" @@ -194,7 +195,8 @@ (:file "json_delete_interface" :depends-on ("json_importer"))) :depends-on ("model" - "xml")) + "xml" + "TM-SPARQL")) (:module "ajax" :components ((:static-file "isidorus.html") (:module "javascripts" Modified: trunk/src/json/json_exporter.lisp ============================================================================== --- trunk/src/json/json_exporter.lisp (original) +++ trunk/src/json/json_exporter.lisp Sat Dec 4 16:05:05 2010 @@ -8,7 +8,7 @@ ;;+----------------------------------------------------------------------------- (defpackage :json-exporter - (:use :cl :json :datamodel) + (:use :cl :json :datamodel :TM-SPARQL :base-tools) (:export :to-json-string :get-all-topic-psis :to-json-string-summary @@ -475,4 +475,25 @@ (to-json-string-summary topic :revision revision) ",")))) (subseq inner-string 0 (- (length inner-string) 1))))) (concatenate 'string "[" json-string "]")) - "null")) \ No newline at end of file + "null")) + + +;; ============================================================================= +;; --- json data sparql-results ------------------------------------------------ +;; ============================================================================= + +(defmethod to-json-string ((construct SPARQL-Query) &key xtm-id revision) + "Returns a JSON string that represents the object query result." + (declare (Ignorable revision xtm-id)) + (let ((query-result (result construct))) + (if (not query-result) + "null" + (let ((j-str "{")) + (loop for entry in query-result + do (push-string + (concatenate + 'string + (json:encode-json-to-string (getf entry :variable)) ":" + (json:encode-json-to-string (getf entry :result)) ",") + j-str)) + (concatenate 'string (subseq j-str 0 (- (length j-str) 1)) "}"))))) \ No newline at end of file Modified: trunk/src/rest_interface/rest-interface.lisp ============================================================================== --- trunk/src/rest_interface/rest-interface.lisp (original) +++ trunk/src/rest_interface/rest-interface.lisp Sat Dec 4 16:05:05 2010 @@ -12,6 +12,8 @@ (:use :cl :hunchentoot :cxml :constants + :exceptions + :TM-SPARQL :atom :datamodel :exporter @@ -44,7 +46,8 @@ :*ajax-user-interface-file-path* :*ajax-javascript-directory-path* :*ajax-javascript-url-prefix* - :*xtm-commit-prefix*)) + :*xtm-commit-prefix* + :*sparql-url*)) (in-package :rest-interface) Modified: trunk/src/rest_interface/set-up-json-interface.lisp ============================================================================== --- trunk/src/rest_interface/set-up-json-interface.lisp (original) +++ trunk/src/rest_interface/set-up-json-interface.lisp Sat Dec 4 16:05:05 2010 @@ -59,6 +59,8 @@ (defparameter *mark-as-deleted-url* "/mark-as-deleted") ;the get url to request the latest revision of the storage (defparameter *latest-revision-url* "/json/latest-revision/?$") +;the ulr to invoke a SPARQL query +(defparameter *sparql-url* "/json/tm-sparql/?$") (defun set-up-json-interface (&key (json-get-prefix *json-get-prefix*) @@ -80,7 +82,8 @@ (ajax-javascripts-url-prefix *ajax-javascript-url-prefix*) (mark-as-deleted-url *mark-as-deleted-url*) (latest-revision-url *latest-revision-url*) - (xtm-commit-prefix *xtm-commit-prefix*)) + (xtm-commit-prefix *xtm-commit-prefix*) + (sparql-url *sparql-url*)) "registers the json im/exporter to the passed base-url in hunchentoot's dispatch-table and also registers a file-hanlder to the html-user-interface" @@ -162,6 +165,9 @@ hunchentoot:*dispatch-table*) (push (create-regex-dispatcher latest-revision-url #'return-latest-revision) + hunchentoot:*dispatch-table*) + (push + (create-regex-dispatcher sparql-url #'return-tm-sparql) hunchentoot:*dispatch-table*)) ;; ============================================================================= @@ -485,6 +491,28 @@ (setf (hunchentoot:content-type*) "text") (format nil "Condition: \"~a\"" err))))) + +(defun return-tm-sparql (&optional param) + "Returns a JSON object representing a SPARQL response." + (declare (Ignorable param)) + (handler-case + (if (eql (hunchentoot:request-method*) :POST) + (let ((external-format (flexi-streams:make-external-format + :UTF-8 :eol-style :LF))) + (let ((sparql-request (hunchentoot:raw-post-data + :external-format external-format + :force-text t))) + (to-json-string (make-instance 'SPARQL-Query :query sparql-request + :revision 0)))) + (setf (hunchentoot:return-code*) hunchentoot:+http-bad-request+)) + (condition (err) + (progn + (setf (hunchentoot:return-code*) hunchentoot:+http-internal-server-error+) + (setf (hunchentoot:content-type*) "text") + (if (typep err 'SPARQL-Parser-Error) + (format nil "SPARQL-Parser-Error: \"~a\"" (exceptions::message err)) + (format nil "Condition: \"~a\"" err)))))) + ;; ============================================================================= ;; --- some helper functions --------------------------------------------------- ;; =============================================================================

1 0

[isidorus-cvs] r359 - in trunk/src: TM-SPARQL unit_tests
by Lukas Giessmann 04 Dec '10

04 Dec '10

Author: lgiessmann Date: Sat Dec 4 12:07:46 2010 New Revision: 359 Log: TM-SPARQL: added unit-tests for the "result"=>SPARQL-Query method => fixed some bugs Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_parser.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 Sat Dec 4 12:07:46 2010 @@ -132,9 +132,8 @@ ;purposes and mustn't be reset :type List :initform nil - :documentation "A list of the form ((:variable var-name - :value value-object)), that contains tuples - for each selected variable and its result.") + :documentation "A list of the form that contains the variable + names as string.") (prefixes :initarg :prefixes :accessor prefixes ;this value is only for internal purposes ;purposes and mustn't be reset @@ -159,18 +158,23 @@ (:documentation "This class represents the entire request.")) -(defmethod variables ((construct SPARQL-Triple-Elem)) +(defgeneric *-p (construct) + (:documentation "Returns t if the user selected all variables with *.") + (:method ((construct SPARQL-Query)) + (and (= (length (variables construct)) 1) + (string= (first (variables construct)) "*")))) + + +(defmethod variables ((construct SPARQL-Triple)) "Returns all variable names that are contained in the passed element." (remove-duplicates (remove-null - (loop for triple in (select-group construct) - collect (remove-null - (list (when (variable-p (subject construct)) - (value (subject construct))) - (when (variable-p (predicate construct)) - (value (predicate construct))) - (when (variable-p (object construct)) - (value (object construct))))))) + (list (when (variable-p (subject construct)) + (value (subject construct))) + (when (variable-p (predicate construct)) + (value (predicate construct))) + (when (variable-p (object construct)) + (value (object construct))))) :test #'string=)) @@ -222,20 +226,14 @@ (concatenate 'string (getf entry :label) ":")))))) -(defgeneric add-variable (construct variable-name variable-value) +(defgeneric add-variable (construct variable-name) (: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)))))) + (:method ((construct SPARQL-Query) (variable-name String)) + (unless (find variable-name (variables construct) :test #'string=) + (push variable-name (variables construct))))) (defgeneric set-results (construct &key revision) @@ -755,17 +753,20 @@ assocs))))) - (defgeneric result (construct) (:documentation "Returns the result of the entire query.") (:method ((construct SPARQL-Query)) (let ((result-lists (make-result-lists construct))) (reduce-results construct result-lists) - (let* ((response-variables (variables construct)) + (let* ((response-variables + (if (*-p construct) + (all-variables construct) + (variables construct))) (cleaned-results (make-result-lists construct))) (map 'list #'(lambda(response-variable) - (variable-intersection response-variable - cleaned-results)) + (list :variable response-variable + :result (variable-intersection response-variable + cleaned-results))) response-variables))))) @@ -775,28 +776,39 @@ (:method ((construct SPARQL-Query)) (remove-null (loop for triple in (select-group construct) - collect (remove-null - (list - (when (variable-p (subject construct)) - (list :variable (value (subject construct)) - :result (subject-result construct))) - (when (variable-p (predicate construct)) - (list :variable (value (predicate construct)) - :result (predicate-result construct))) - (when (variable-p (object construct)) - (list :variable (value (object construct)) - :result (object-result construct))))))))) + append (remove-null + (list + (when (variable-p (subject triple)) + (list :variable (value (subject triple)) + :result (subject-result triple))) + (when (variable-p (predicate triple)) + (list :variable (value (predicate triple)) + :result (predicate-result triple))) + (when (variable-p (object triple)) + (list :variable (value (object triple)) + :result (object-result triple))))))))) (defgeneric all-variables (result-lists) (:documentation "Returns a list of all variables that are contained in - the passed result-lists.") - (:method ((result-lists List)) - (remove-duplicates - (map 'list #'(lambda(entry) - (getf entry :variable)) - result-lists) - :test #'string=))) + the passed result-lists.")) + + +(defmethod all-variables ((result-lists List)) + (remove-duplicates + (map 'list #'(lambda(entry) + (getf entry :variable)) + result-lists) + :test #'string=)) + + +(defmethod all-variables ((construct SPARQL-Query)) + "Returns all variables that are contained in the select groupt memebers." + (remove-duplicates + (remove-null + (loop for triple in (select-group construct) + append (variables triple))) + :test #'string=)) (defgeneric variable-intersection (variable-name result-lists) @@ -814,7 +826,7 @@ (recursive-intersection list-1 list-2 more-lists)))) -(defun recursive-intersection (list-1 list-2 &rest more-lists) +(defun recursive-intersection (list-1 list-2 more-lists) "Returns an intersection of al the passed lists." (declare (List list-1 list-2)) (let ((current-result @@ -823,10 +835,10 @@ (if (and (stringp val-1) (stringp val-2)) (string= val-1 val-2) (eql val-1 val-2)))))) - (if (= (length more-lists) 0) + (if (not more-lists) current-result - (apply #'recursive-intersection current-result - (first more-lists) (rest more-lists))))) + (recursive-intersection current-result (first more-lists) + (rest more-lists))))) (defgeneric reduce-results(construct result-lists) @@ -841,7 +853,7 @@ (defgeneric reduce-triple(construct result-lists) (:documentation "Reduces the results of a triple by using only the intersection values.") - (:method ((construct SPARQL-Triple-Elem) (result-lists List)) + (:method ((construct SPARQL-Triple) (result-lists List)) (let* ((triple-variables (variables construct)) (intersections (map 'list #'(lambda(var) @@ -859,7 +871,7 @@ (:documentation "Checks all results of the passed variable of the given construct and deletes every result with the corresponding row that is not contained in the dont-touch-values.") - (:method ((construct SPARQL-Triple-Elem) (variable-name String) + (:method ((construct SPARQL-Triple) (variable-name String) (dont-touch-values List)) (let ((var-elem (cond ((and (variable-p (subject construct)) @@ -871,29 +883,30 @@ ((and (variable-p (object construct)) (string= (value (object construct)) variable-name)) (object-result construct))))) - (if (not var-elem) - construct - (let* ((rows-to-hold - (remove-null - (map 'list #'(lambda(val) - (if (stringp val) - (position val var-elem :test #'string=) - (position val var-elem))) - var-elem))) - (new-result-list - (dolist (row-idx rows-to-hold) - (list :subject (elt (subject-result construct) row-idx) - :predicate (elt (predicate-result construct) row-idx) - :object (elt (object-result construct) row-idx))))) - (setf (subject-result construct) - (map 'list #'(lambda(entry) - (getf entry :subject)) new-result-list)) - (setf (predicate-result construct) - (map 'list #'(lambda(entry) - (getf entry :predicate)) new-result-list)) - (setf (object-result construct) - (map 'list #'(lambda(entry) - (getf entry :object)) new-result-list))))))) + (when var-elem + (let* ((rows-to-hold + (remove-null + (map 'list #'(lambda(val) + (if (stringp val) + (position val var-elem :test #'string=) + (position val var-elem))) + dont-touch-values))) + (new-result-list + (map 'list + #'(lambda(row-idx) + (list :subject (elt (subject-result construct) row-idx) + :predicate (elt (predicate-result construct) row-idx) + :object (elt (object-result construct) row-idx))) + rows-to-hold))) + (setf (subject-result construct) + (map 'list #'(lambda(entry) + (getf entry :subject)) new-result-list)) + (setf (predicate-result construct) + (map 'list #'(lambda(entry) + (getf entry :predicate)) new-result-list)) + (setf (object-result construct) + (map 'list #'(lambda(entry) + (getf entry :object)) new-result-list))))))) (defgeneric results-for-variable (variable-name result-lists) Modified: trunk/src/TM-SPARQL/sparql_parser.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_parser.lisp (original) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Sat Dec 4 12:07:46 2010 @@ -163,7 +163,7 @@ (list :next-query (cut-comment (subseq trimmed-str 1)) :value (make-instance 'SPARQL-Triple-Elem :elem-type 'IRI - :value *rdf-type*))) + :value *type-psi*))) ((string-starts-with trimmed-str "<") (parse-base-suffix-pair trimmed-str query-object)) ((or (string-starts-with trimmed-str "?") @@ -484,10 +484,10 @@ (if (string-starts-with trimmed-str "WHERE") trimmed-str (if (string-starts-with trimmed-str "*") - (progn (add-variable construct "*" nil) + (progn (add-variable construct "*") (parse-variables construct (string-after trimmed-str "*"))) (let ((result (parse-variable-name trimmed-str construct))) - (add-variable construct (getf result :value) nil) + (add-variable construct (getf result :value)) (parse-variables construct (getf result :next-query)))))))) 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 4 12:07:46 2010 @@ -28,7 +28,8 @@ :test-set-result-2 :test-set-result-3 :test-set-result-4 - :test-set-result-5)) + :test-set-result-5 + :test-result)) (in-package :sparql-test) @@ -134,35 +135,22 @@ (is-true query-object-3) (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-true (find "var1" (TM-SPARQL::variables query-object-1) + :test #'string=)) + (is-true (find "var2" (TM-SPARQL::variables query-object-1) + :test #'string=)) + (is-true (find "var3" (TM-SPARQL::variables query-object-1) + :test #'string=)) (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))) - (is-true (find-if #'(lambda(elem) - (and (string= (getf elem :variable) "*") - (null (getf elem :value)))) - (TM-SPARQL::variables query-object-3))))) + (is-true (find "var1" (TM-SPARQL::variables query-object-2) + :test #'string=)) + (is-true (find "var2" (TM-SPARQL::variables query-object-2) + :test #'string=)) + (is-true (find "var3" (TM-SPARQL::variables query-object-2) + :test #'string=)) + (is-true (find "*" (TM-SPARQL::variables query-object-3) + :test #'string=)) + (is-true (tm-sparql::*-p query-object-3)))) (test test-parse-literals @@ -940,5 +928,117 @@ (second (tm-sparql::select-group q-obj-3)))))))))) +(test test-result + (with-fixture with-tm-filled-db ("data_base" *poems.xtm*) + (with-revision 0 + (let* ((query-1 "PREFIX author:<http://some.where/psis/author/> + PREFIX poem:<http://some.where/psis/poem/> + PREFIX basePSIs:<http://some.where/base-psis/> + SELECT ?poems ?poets WHERE { + ?poets a basePSIs:author . + ?poets basePSIs:written ?poems. + ?poems basePSIs:title 'Der Erlkönig' . + ?poems a basePSIs:poem}") + (q-obj-1 (make-instance 'TM-SPARQL:SPARQL-Query :query query-1)) + (query-2 "PREFIX author:<http://some.where/psis/author/> + PREFIX poem:<http://some.where/psis/poem/> + PREFIX basePSIs:<http://some.where/base-psis/> + SELECT * WHERE { + ?poems a basePSIs:poem. + <goethe> <last-name> 'von Goethe' . + ?poems basePSIs:title ?titles}") + (q-obj-2 (make-instance 'TM-SPARQL:SPARQL-Query :query query-2))) + (is-true q-obj-1) + (is-true q-obj-2) + (is (= (length (tm-sparql::select-group q-obj-1)) 4)) + (is (= (length (tm-sparql::select-group q-obj-2)) 3)) + (is (= (length (result q-obj-1)) 2)) + (if (string= (getf (first (result q-obj-1)) :variable) "poets") + (progn + (is (= (length (getf (first (result q-obj-1)) :result)) 1)) + (is (or (string= (first (getf (first (result q-obj-1)) :result)) + "http://some.where/psis/author/goethe") + (string= (first (getf (first (result q-obj-1)) :result)) + "http://some.where/psis/persons/goethe"))) + (is (= (length (getf (second (result q-obj-1)) :result)) 1)) + (is (string= (first (getf (second (result q-obj-1)) :result)) + "http://some.where/psis/poem/erlkoenig")) + (is (string= (getf (second (result q-obj-1)) :variable) "poems"))) + (progn + (is (= (length (getf (second (result q-obj-1)) :result)) 1)) + (is (or (string= (first (getf (second (result q-obj-1)) :result)) + "http://some.where/psis/author/goethe") + (string= (first (getf (second (result q-obj-1)) :result)) + "http://some.where/psis/persons/goethe"))) + (is (= (length (getf (first (result q-obj-1)) :result)) 1)) + (is (string= (first (getf (first (result q-obj-1)) :result)) + "http://some.where/psis/poem/erlkoenig")) + (is (string= (getf (first (result q-obj-1)) :variable) "poems")))) + (is (= (length (result q-obj-2)) 2)) + (if (string= (getf (first (result q-obj-2)) :variable) "titles") + (progn + (is (= (length (getf (first (result q-obj-2)) :result)) 4)) + (is-true + (find "Mondnacht" + (getf (first (result q-obj-2)) :result) :test #'string=)) + (is-true + (find "Der Erlkönig" + (getf (first (result q-obj-2)) :result) :test #'string=)) + (is-true + (find "Der Zauberlehrling" + (getf (first (result q-obj-2)) :result) :test #'string=)) + (is-true + (find "Resignation - Eine Phantasie" + (getf (first (result q-obj-2)) :result) :test #'string=)) + (string= (getf (second (result q-obj-2)) :variable) "poems") + (is-true + (find "http://some.where/psis/poem/mondnacht" + (getf (second (result q-obj-2)) :result) :test #'string=)) + (is-true + (find "http://some.where/psis/poem/resignation" + (getf (second (result q-obj-2)) :result) :test #'string=)) + (is-true + (find "http://some.where/psis/poem/erlkoenig" + (getf (second (result q-obj-2)) :result) :test #'string=)) + (is-true + (or + (find "http://some.where/psis/poem/zauberlehrling" + (getf (second (result q-obj-2)) :result) :test #'string=) + (find "http://some.where/psis/poem/der_zauberlehrling" + (getf (second (result q-obj-2)) :result) :test #'string=)))) + (progn + (is (= (length (getf (second (result q-obj-2)) :result)) 4)) + (is-true + (find "Mondnacht" + (getf (second (result q-obj-2)) :result) :test #'string=)) + (is-true + (find "Der Erlkönig" + (getf (second (result q-obj-2)) :result) :test #'string=)) + (is-true + (find "Der Zauberlehrling" + (getf (second (result q-obj-2)) :result) :test #'string=)) + (is-true + (find "Resignation - Eine Phantasie" + (getf (second (result q-obj-2)) :result) :test #'string=)) + (string= (getf (first (result q-obj-2)) :variable) "poems") + (is-true + (find "http://some.where/psis/poem/mondnacht" + (getf (first (result q-obj-2)) :result) :test #'string=)) + (is-true + (find "http://some.where/psis/poem/resignation" + (getf (first (result q-obj-2)) :result) :test #'string=)) + (is-true + (find "http://some.where/psis/poem/erlkoenig" + (getf (first (result q-obj-2)) :result) :test #'string=)) + (is-true + (or + (find "http://some.where/psis/poem/zauberlehrling" + (getf (first (result q-obj-2)) :result) :test #'string=) + (find "http://some.where/psis/poem/der_zauberlehrling" + (getf (first (result q-obj-2)) :result) :test #'string=))))))))) + + + + (defun run-sparql-tests () (it.bese.fiveam:run! 'sparql-test:sparql-tests))

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

isidorus-cvs December 2010