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