- isidorus-cvs@common-lisp.net - mailman3.common-lisp.net

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

15 Dec '10

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

1 0

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

15 Dec '10

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

1 0

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

14 Dec '10

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

1 0

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

14 Dec '10

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

1 0

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

04 Dec '10

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

1 0

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

04 Dec '10

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

1 0

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

04 Dec '10

Author: lgiessmann Date: Sat Dec 4 08:59:08 2010 New Revision: 358 Log: TM-SPARQL: added a method called "result"=>SPARQL-Query, so invoking it produces a result of the entier query; fixed a style warning in the RESTful-itnerface Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/rest_interface/set-up-json-interface.lisp trunk/src/unit_tests/sparql_test.lisp Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Sat Dec 4 08:59:08 2010 @@ -9,10 +9,8 @@ (defpackage :TM-SPARQL (:use :cl :datamodel :base-tools :exceptions :constants) - (:export :SPARQL-Query)) - -;;TODO: -;; *handle special URIs => http://www.networkedplanet.com/ontopic/2009/11/making_topic_maps_sparql.html + (:export :SPARQL-Query + :result)) (in-package :TM-SPARQL) @@ -161,6 +159,21 @@ (:documentation "This class represents the entire request.")) +(defmethod variables ((construct SPARQL-Triple-Elem)) + "Returns all variable names that are contained in the passed element." + (remove-duplicates + (remove-null + (loop for triple in (select-group construct) + collect (remove-null + (list (when (variable-p (subject construct)) + (value (subject construct))) + (when (variable-p (predicate construct)) + (value (predicate construct))) + (when (variable-p (object construct)) + (value (object construct))))))) + :test #'string=)) + + (defgeneric add-triple (construct triple) (:documentation "Adds a triple object to the select-group list.") (:method ((construct SPARQL-Query) (triple SPARQL-Triple)) @@ -742,6 +755,162 @@ assocs))))) + +(defgeneric result (construct) + (:documentation "Returns the result of the entire query.") + (:method ((construct SPARQL-Query)) + (let ((result-lists (make-result-lists construct))) + (reduce-results construct result-lists) + (let* ((response-variables (variables construct)) + (cleaned-results (make-result-lists construct))) + (map 'list #'(lambda(response-variable) + (variable-intersection response-variable + cleaned-results)) + response-variables))))) + + +(defgeneric make-result-lists (construct) + (:documentation "Returns a list of the form ((:variable 'var-name' + :result (<any-object>)).") + (:method ((construct SPARQL-Query)) + (remove-null + (loop for triple in (select-group construct) + collect (remove-null + (list + (when (variable-p (subject construct)) + (list :variable (value (subject construct)) + :result (subject-result construct))) + (when (variable-p (predicate construct)) + (list :variable (value (predicate construct)) + :result (predicate-result construct))) + (when (variable-p (object construct)) + (list :variable (value (object construct)) + :result (object-result construct))))))))) + + +(defgeneric all-variables (result-lists) + (:documentation "Returns a list of all variables that are contained in + the passed result-lists.") + (:method ((result-lists List)) + (remove-duplicates + (map 'list #'(lambda(entry) + (getf entry :variable)) + result-lists) + :test #'string=))) + + +(defgeneric variable-intersection (variable-name result-lists) + (:documentation "Returns a list with all results of the passed variable + that are contained in the result-lists. All results is + an intersection of all paratial results.") + (:method ((variable-name String) (result-lists List)) + (let* ((all-values (results-for-variable variable-name result-lists)) + (list-1 (when (>= (length all-values) 1) + (first all-values))) + (list-2 (if (> (length all-values) 2) + (second all-values) + list-1)) + (more-lists (rest (rest all-values)))) + (recursive-intersection list-1 list-2 more-lists)))) + + +(defun recursive-intersection (list-1 list-2 &rest more-lists) + "Returns an intersection of al the passed lists." + (declare (List list-1 list-2)) + (let ((current-result + (intersection list-1 list-2 + :test #'(lambda(val-1 val-2) + (if (and (stringp val-1) (stringp val-2)) + (string= val-1 val-2) + (eql val-1 val-2)))))) + (if (= (length more-lists) 0) + current-result + (apply #'recursive-intersection current-result + (first more-lists) (rest more-lists))))) + + +(defgeneric reduce-results(construct result-lists) + (:documentation "Reduces the select-group of the passed construct by processing + all triples with the intersection-results.") + (:method ((construct SPARQL-Query) (result-lists List)) + (map 'list #'(lambda(triple) + (reduce-triple triple result-lists)) + (select-group construct)))) + + +(defgeneric reduce-triple(construct result-lists) + (:documentation "Reduces the results of a triple by using only the + intersection values.") + (:method ((construct SPARQL-Triple-Elem) (result-lists List)) + (let* ((triple-variables (variables construct)) + (intersections + (map 'list #'(lambda(var) + (list :variable var + :result (variable-intersection + var result-lists))) + triple-variables))) + (map 'list #'(lambda(entry) + (delete-rows construct (getf entry :variable) + (getf entry :result))) + intersections)))) + + +(defgeneric delete-rows (construct variable-name dont-touch-values) + (:documentation "Checks all results of the passed variable of the given + construct and deletes every result with the corresponding + row that is not contained in the dont-touch-values.") + (:method ((construct SPARQL-Triple-Elem) (variable-name String) + (dont-touch-values List)) + (let ((var-elem + (cond ((and (variable-p (subject construct)) + (string= (value (subject construct)) variable-name)) + (subject-result construct)) + ((and (variable-p (predicate construct)) + (string= (value (predicate construct)) variable-name)) + (predicate-result construct)) + ((and (variable-p (object construct)) + (string= (value (object construct)) variable-name)) + (object-result construct))))) + (if (not var-elem) + construct + (let* ((rows-to-hold + (remove-null + (map 'list #'(lambda(val) + (if (stringp val) + (position val var-elem :test #'string=) + (position val var-elem))) + var-elem))) + (new-result-list + (dolist (row-idx rows-to-hold) + (list :subject (elt (subject-result construct) row-idx) + :predicate (elt (predicate-result construct) row-idx) + :object (elt (object-result construct) row-idx))))) + (setf (subject-result construct) + (map 'list #'(lambda(entry) + (getf entry :subject)) new-result-list)) + (setf (predicate-result construct) + (map 'list #'(lambda(entry) + (getf entry :predicate)) new-result-list)) + (setf (object-result construct) + (map 'list #'(lambda(entry) + (getf entry :object)) new-result-list))))))) + + +(defgeneric results-for-variable (variable-name result-lists) + (:documentation "Returns a list with result-lists for the passed variable.") + (:method ((variable-name String) (result-lists List)) + (let* ((cleaned-result-lists + (remove-if-not #'(lambda(entry) + (string= (getf entry :variable) + variable-name)) + result-lists)) + (values + (map 'list #'(lambda(entry) + (getf entry :result)) + cleaned-result-lists))) + values))) + + (defmethod initialize-instance :after ((construct SPARQL-Query) &rest args) (declare (ignorable args)) (parser-start construct (original-query construct)) Modified: trunk/src/rest_interface/set-up-json-interface.lisp ============================================================================== --- trunk/src/rest_interface/set-up-json-interface.lisp (original) +++ trunk/src/rest_interface/set-up-json-interface.lisp Sat Dec 4 08:59:08 2010 @@ -428,8 +428,10 @@ (if result (progn (when (typep result 'd:TopicC) - (delete (elephant::oid result) *type-table*) - (delete (elephant::oid result) *instance-table*)) + (append ;;the append function is used only for suppress + ;;style warnings of unused delete return values + (delete (elephant::oid result) *type-table*) + (delete (elephant::oid result) *instance-table*))) (format nil "")) ;operation succeeded (progn (setf (hunchentoot:return-code*) hunchentoot:+http-not-found+) Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Sat Dec 4 08:59:08 2010 @@ -19,6 +19,7 @@ (:export :run-sparql-tests :sparql-tests :test-prefix-and-base + :test-variable-names :test-parse-literals :test-parse-triple-elem :test-parse-group-1 @@ -180,61 +181,61 @@ (query-9 (concatenate 'string "\"13e4\"^^" *xml-boolean* " .")) (dummy-object (make-instance 'SPARQL-Query :query ""))) (is-true dummy-object) - (let ((result (tm-sparql::parse-literal-elem query-1 dummy-object))) - (is (string= (getf result :next-query) ".")) - (is (string= (tm-sparql::value (getf result :value)) + (let ((res (tm-sparql::parse-literal-elem query-1 dummy-object))) + (is (string= (getf res :next-query) ".")) + (is (string= (tm-sparql::value (getf res :value)) "literal-value")) - (is (string= (tm-sparql::literal-lang (getf result :value)) + (is (string= (tm-sparql::literal-lang (getf res :value)) "de")) - (is (string= (tm-sparql::literal-datatype (getf result :value)) + (is (string= (tm-sparql::literal-datatype (getf res :value)) *xml-string*)) - (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL))) - (let ((result (tm-sparql::parse-literal-elem query-2 dummy-object))) - (is (string= (getf result :next-query) ".")) - (is (eql (tm-sparql::value (getf result :value)) t)) - (is-false (tm-sparql::literal-lang (getf result :value))) - (is (string= (tm-sparql::literal-datatype (getf result :value)) + (is (eql (tm-sparql::elem-type (getf res :value)) 'TM-SPARQL::LITERAL))) + (let ((res (tm-sparql::parse-literal-elem query-2 dummy-object))) + (is (string= (getf res :next-query) ".")) + (is (eql (tm-sparql::value (getf res :value)) t)) + (is-false (tm-sparql::literal-lang (getf res :value))) + (is (string= (tm-sparql::literal-datatype (getf res :value)) *xml-boolean*)) - (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL))) - (let ((result (tm-sparql::parse-literal-elem query-3 dummy-object))) - (is (string= (getf result :next-query) "}")) - (is (eql (tm-sparql::value (getf result :value)) nil)) - (is-false (tm-sparql::literal-lang (getf result :value))) - (is (string= (tm-sparql::literal-datatype (getf result :value)) + (is (eql (tm-sparql::elem-type (getf res :value)) 'TM-SPARQL::LITERAL))) + (let ((res (tm-sparql::parse-literal-elem query-3 dummy-object))) + (is (string= (getf res :next-query) "}")) + (is (eql (tm-sparql::value (getf res :value)) nil)) + (is-false (tm-sparql::literal-lang (getf res :value))) + (is (string= (tm-sparql::literal-datatype (getf res :value)) *xml-boolean*)) - (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL))) - (let ((result (tm-sparql::parse-literal-elem query-4 dummy-object))) - (is (string= (getf result :next-query) (string #\tab))) - (is (= (tm-sparql::value (getf result :value)) 1234.43e10)) - (is-false (tm-sparql::literal-lang (getf result :value))) - (is (string= (tm-sparql::literal-datatype (getf result :value)) + (is (eql (tm-sparql::elem-type (getf res :value)) 'TM-SPARQL::LITERAL))) + (let ((res (tm-sparql::parse-literal-elem query-4 dummy-object))) + (is (string= (getf res :next-query) (string #\tab))) + (is (= (tm-sparql::value (getf res :value)) 1234.43e10)) + (is-false (tm-sparql::literal-lang (getf res :value))) + (is (string= (tm-sparql::literal-datatype (getf res :value)) *xml-double*)) - (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL))) - (let ((result (tm-sparql::parse-literal-elem query-5 dummy-object))) - (is (string= (getf result :next-query) ";")) - (is (eql (tm-sparql::value (getf result :value)) t)) - (is-false (tm-sparql::literal-lang (getf result :value))) - (is (string= (tm-sparql::literal-datatype (getf result :value)) + (is (eql (tm-sparql::elem-type (getf res :value)) 'TM-SPARQL::LITERAL))) + (let ((res (tm-sparql::parse-literal-elem query-5 dummy-object))) + (is (string= (getf res :next-query) ";")) + (is (eql (tm-sparql::value (getf res :value)) t)) + (is-false (tm-sparql::literal-lang (getf res :value))) + (is (string= (tm-sparql::literal-datatype (getf res :value)) *xml-boolean*)) - (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL))) - (let ((result (tm-sparql::parse-literal-elem query-6 dummy-object))) - (is (string= (getf result :next-query) + (is (eql (tm-sparql::elem-type (getf res :value)) 'TM-SPARQL::LITERAL))) + (let ((res (tm-sparql::parse-literal-elem query-6 dummy-object))) + (is (string= (getf res :next-query) (concatenate 'string "." (string #\newline)))) - (is (eql (tm-sparql::value (getf result :value)) 123.4)) - (is-false (tm-sparql::literal-lang (getf result :value))) - (is (string= (tm-sparql::literal-datatype (getf result :value)) + (is (eql (tm-sparql::value (getf res :value)) 123.4)) + (is-false (tm-sparql::literal-lang (getf res :value))) + (is (string= (tm-sparql::literal-datatype (getf res :value)) *xml-double*)) - (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL))) - (let ((result (tm-sparql::parse-literal-elem query-7 dummy-object))) - (is (string= (getf result :next-query) ".")) - (is (string= (tm-sparql::value (getf result :value)) + (is (eql (tm-sparql::elem-type (getf res :value)) 'TM-SPARQL::LITERAL))) + (let ((res (tm-sparql::parse-literal-elem query-7 dummy-object))) + (is (string= (getf res :next-query) ".")) + (is (string= (tm-sparql::value (getf res :value)) "Just a test literal with some \\\"quoted\\\" words!")) - (is (string= (tm-sparql::literal-lang (getf result :value)) "en")) - (is (string= (tm-sparql::literal-datatype (getf result :value)) + (is (string= (tm-sparql::literal-lang (getf res :value)) "en")) + (is (string= (tm-sparql::literal-datatype (getf res :value)) *xml-string*)) - (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL))) + (is (eql (tm-sparql::elem-type (getf res :value)) 'TM-SPARQL::LITERAL))) (signals sparql-parser-error (tm-sparql::parse-literal-elem query-8 dummy-object)) (signals sparql-parser-error @@ -256,38 +257,38 @@ (var 'TM-SPARQL::VARIABLE) (iri 'TM-SPARQL::IRI)) (tm-sparql::add-prefix dummy-object "pref" "http://prefix.value") - (let ((result (tm-sparql::parse-triple-elem query-1 dummy-object))) - (is (string= (getf result :next-query) ".")) - (is (string= (tm-sparql::value (getf result :value)) "var1")) - (is (eql (tm-sparql::elem-type (getf result :value)) var))) - (let ((result (tm-sparql::parse-triple-elem query-2 dummy-object))) - (is (string= (getf result :next-query) ";")) - (is (string= (tm-sparql::value (getf result :value)) "var2")) - (is (eql (tm-sparql::elem-type (getf result :value)) var))) - (let ((result (tm-sparql::parse-triple-elem query-3 dummy-object))) - (is (string= (getf result :next-query) "}")) - (is (string= (tm-sparql::value (getf result :value)) "var3")) - (is (eql (tm-sparql::elem-type (getf result :value)) var))) - (let ((result (tm-sparql::parse-triple-elem query-4 dummy-object))) - (is (string= (getf result :next-query) ".")) - (is (string= (tm-sparql::value (getf result :value)) + (let ((res (tm-sparql::parse-triple-elem query-1 dummy-object))) + (is (string= (getf res :next-query) ".")) + (is (string= (tm-sparql::value (getf res :value)) "var1")) + (is (eql (tm-sparql::elem-type (getf res :value)) var))) + (let ((res (tm-sparql::parse-triple-elem query-2 dummy-object))) + (is (string= (getf res :next-query) ";")) + (is (string= (tm-sparql::value (getf res :value)) "var2")) + (is (eql (tm-sparql::elem-type (getf res :value)) var))) + (let ((res (tm-sparql::parse-triple-elem query-3 dummy-object))) + (is (string= (getf res :next-query) "}")) + (is (string= (tm-sparql::value (getf res :value)) "var3")) + (is (eql (tm-sparql::elem-type (getf res :value)) var))) + (let ((res (tm-sparql::parse-triple-elem query-4 dummy-object))) + (is (string= (getf res :next-query) ".")) + (is (string= (tm-sparql::value (getf res :value)) "http://full.url")) - (is (eql (tm-sparql::elem-type (getf result :value)) iri))) - (let ((result (tm-sparql::parse-triple-elem query-5 dummy-object))) - (is (string= (getf result :next-query) "}")) - (is (string= (tm-sparql::value (getf result :value)) + (is (eql (tm-sparql::elem-type (getf res :value)) iri))) + (let ((res (tm-sparql::parse-triple-elem query-5 dummy-object))) + (is (string= (getf res :next-query) "}")) + (is (string= (tm-sparql::value (getf res :value)) "http://base.value/url-suffix")) - (is (eql (tm-sparql::elem-type (getf result :value)) iri))) - (let ((result (tm-sparql::parse-triple-elem query-6 dummy-object))) - (is (string= (getf result :next-query) ".")) - (is (string= (tm-sparql::value (getf result :value)) + (is (eql (tm-sparql::elem-type (getf res :value)) iri))) + (let ((res (tm-sparql::parse-triple-elem query-6 dummy-object))) + (is (string= (getf res :next-query) ".")) + (is (string= (tm-sparql::value (getf res :value)) "http://prefix.value/suffix")) - (is (eql (tm-sparql::elem-type (getf result :value)) iri))) - (let ((result (tm-sparql::parse-triple-elem query-7 dummy-object))) - (is (string= (getf result :next-query) "}")) - (is (string= (tm-sparql::value (getf result :value)) + (is (eql (tm-sparql::elem-type (getf res :value)) iri))) + (let ((res (tm-sparql::parse-triple-elem query-7 dummy-object))) + (is (string= (getf res :next-query) "}")) + (is (string= (tm-sparql::value (getf res :value)) "http://prefix.value/suffix")) - (is (eql (tm-sparql::elem-type (getf result :value)) iri))) + (is (eql (tm-sparql::elem-type (getf res :value)) iri))) (signals sparql-parser-error (tm-sparql::parse-triple-elem query-8 dummy-object))))

1 0

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

02 Dec '10

Author: lgiessmann Date: Thu Dec 2 14:53:40 2010 New Revision: 357 Log: TM-SPARQL: added more unit-tests for the sparql-interface => fixed some bug when processing query-triples in the SELECT-WHERE statement Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_parser.lisp trunk/src/unit_tests/sparql_test.lisp Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Thu Dec 2 14:53:40 2010 @@ -431,7 +431,7 @@ (declare (Integer revision)) (when (and (not (iri-p (object construct))) (or (not (literal-datatype (object construct))) - (string= (literal-datatype construct) *xml-string*))) + (string= (literal-datatype (object construct)) *xml-string*))) (let* ((names-by-type (remove-null (map 'list #'(lambda(typed-construct) @@ -521,7 +521,7 @@ subj pred nil :revision revision))) ((literal-p (object construct)) (filter-characteristics - subj pred (value (subject construct)) + subj pred (value (object construct)) (literal-datatype (object construct)) :revision revision)) ((iri-p (object construct)) (filter-associations subj pred (value (object construct)) @@ -621,7 +621,9 @@ (type (or Null String) literal-value literal-datatype) (type (or Null TopicC) type-top)) (let* ((occs-by-type - (occurrences-by-type construct type-top :revision revision)) + (if type-top + (occurrences-by-type construct type-top :revision revision) + (occurrences construct :revision revision))) (all-occs (remove-null (map 'list @@ -650,8 +652,10 @@ (declare (Integer revision) (type (or Null String) literal-value) (type (or Null TopicC) type-top)) - (let* ((by-type - (names-by-type construct type-top :revision revision)) + (let* ((by-type + (if type-top + (names-by-type construct type-top :revision revision) + (names construct :revision revision))) (by-literal (if literal-value (names-by-value construct #'(lambda(name) @@ -693,36 +697,48 @@ (defgeneric filter-associations(construct type-top player-top &key revision) - (:documentation "Returns a list of the form (:type <uri> :value <uri>). - type-identifier is the type of the otherrole and - player-identifier if the otherplayer.") + (:documentation "Returns a list of the form (:predicate <uri> + :object <uri> :subject <uri>). + predicate is the type of the otherrole and + object is the uri of the otherplayer.") (:method ((construct TopicC) type-top player-top &key (revision *TM-REVISION*)) (declare (Integer revision) (type (or Null TopicC) type-top player-top)) (let ((assocs (associations-of construct nil nil type-top player-top - :revision revision))) + :revision revision)) + (subj-uri (any-id construct :revision revision))) (remove-null ;only assocs with two roles can match! (map 'list #'(lambda(assoc) (when (= (length (roles assoc :revision revision)) 2) (let* ((other-role (find-if #'(lambda(role) - (not (eql construct - (player role :revision revision)))) + (and + (not (eql construct + (player role :revision revision))) + (or (not type-top) + (eql type-top + (instance-of + role :revision revision))))) (roles assoc :revision revision))) (pred-uri - (when-do type-top (instance-of other-role - :revision revision) - (any-id type-top :revision revision))) + (when other-role + (when-do + type-top (instance-of other-role + :revision revision) + (any-id type-top :revision revision)))) + (obj-uri - (when-do player-top (player other-role - :revision revision) - (any-id player-top :revision revision)))) + (when other-role + (when-do player-top (player other-role + :revision revision) + (any-id player-top :revision revision))))) (when (and pred-uri obj-uri) - (list :type pred-uri - :value obj-uri))))) + (list :subject subj-uri + :predicate pred-uri + :object obj-uri))))) assocs))))) Modified: trunk/src/TM-SPARQL/sparql_parser.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_parser.lisp (original) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Thu Dec 2 14:53:40 2010 @@ -168,7 +168,9 @@ (parse-base-suffix-pair trimmed-str query-object)) ((or (string-starts-with trimmed-str "?") (string-starts-with trimmed-str "$")) - (let ((result (parse-variable-name trimmed-str query-object))) + (let ((result + (parse-variable-name trimmed-str query-object + :additional-delimiters (list "}")))) (list :next-query (cut-comment (getf result :next-query)) :value (make-instance 'SPARQL-Triple-Elem :elem-type 'VARIABLE @@ -269,11 +271,11 @@ :message (format nil "Could not cast from ~a to ~a" literal-value literal-type)))) value)) - (t - (error (make-condition - 'sparql-error - :message (format nil "The type \"~a\" is not supported." - literal-type)))))) + (t ; return the value as a string + (if (stringp literal-value) + literal-value + (write-to-string literal-value))))) + (defun separate-literal-lang-or-type (query-string query-object) "A helper function that returns (:next-query string :lang string @@ -489,15 +491,18 @@ (parse-variables construct (getf result :next-query)))))))) -(defun parse-variable-name (query-string query-object) +(defun parse-variable-name (query-string query-object &key additional-delimiters) "A helper function that parses the first non-whitespace character in the query. since it must be a variable, it must be prefixed by a ? or $. The return value is of the form (:next-query string :value string)." (declare (String query-string) - (SPARQL-Query query-object)) + (SPARQL-Query query-object) + (List additional-delimiters)) (let ((trimmed-str (cut-comment query-string)) - (delimiters (list " " "?" "$" "." (string #\newline) (string #\tab)))) + (delimiters (append + (list " " "?" "$" "." (string #\newline) (string #\tab)) + additional-delimiters))) (unless (or (string-starts-with trimmed-str "?") (string-starts-with trimmed-str "$")) (error (make-sparql-parser-condition Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Thu Dec 2 14:53:40 2010 @@ -24,7 +24,10 @@ :test-parse-group-1 :test-parse-group-2 :test-set-result-1 - :test-set-result-2)) + :test-set-result-2 + :test-set-result-3 + :test-set-result-4 + :test-set-result-5)) (in-package :sparql-test) @@ -183,35 +186,35 @@ "literal-value")) (is (string= (tm-sparql::literal-lang (getf result :value)) "de")) - (is (string= (tm-sparql::literal-type (getf result :value)) + (is (string= (tm-sparql::literal-datatype (getf result :value)) *xml-string*)) (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL))) (let ((result (tm-sparql::parse-literal-elem query-2 dummy-object))) (is (string= (getf result :next-query) ".")) (is (eql (tm-sparql::value (getf result :value)) t)) (is-false (tm-sparql::literal-lang (getf result :value))) - (is (string= (tm-sparql::literal-type (getf result :value)) + (is (string= (tm-sparql::literal-datatype (getf result :value)) *xml-boolean*)) (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL))) (let ((result (tm-sparql::parse-literal-elem query-3 dummy-object))) (is (string= (getf result :next-query) "}")) (is (eql (tm-sparql::value (getf result :value)) nil)) (is-false (tm-sparql::literal-lang (getf result :value))) - (is (string= (tm-sparql::literal-type (getf result :value)) + (is (string= (tm-sparql::literal-datatype (getf result :value)) *xml-boolean*)) (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL))) (let ((result (tm-sparql::parse-literal-elem query-4 dummy-object))) (is (string= (getf result :next-query) (string #\tab))) (is (= (tm-sparql::value (getf result :value)) 1234.43e10)) (is-false (tm-sparql::literal-lang (getf result :value))) - (is (string= (tm-sparql::literal-type (getf result :value)) + (is (string= (tm-sparql::literal-datatype (getf result :value)) *xml-double*)) (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL))) (let ((result (tm-sparql::parse-literal-elem query-5 dummy-object))) (is (string= (getf result :next-query) ";")) (is (eql (tm-sparql::value (getf result :value)) t)) (is-false (tm-sparql::literal-lang (getf result :value))) - (is (string= (tm-sparql::literal-type (getf result :value)) + (is (string= (tm-sparql::literal-datatype (getf result :value)) *xml-boolean*)) (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL))) (let ((result (tm-sparql::parse-literal-elem query-6 dummy-object))) @@ -219,7 +222,7 @@ (concatenate 'string "." (string #\newline)))) (is (eql (tm-sparql::value (getf result :value)) 123.4)) (is-false (tm-sparql::literal-lang (getf result :value))) - (is (string= (tm-sparql::literal-type (getf result :value)) + (is (string= (tm-sparql::literal-datatype (getf result :value)) *xml-double*)) (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL))) (let ((result (tm-sparql::parse-literal-elem query-7 dummy-object))) @@ -229,7 +232,7 @@ literal with some \\\"quoted\\\" words!")) (is (string= (tm-sparql::literal-lang (getf result :value)) "en")) - (is (string= (tm-sparql::literal-type (getf result :value)) + (is (string= (tm-sparql::literal-datatype (getf result :value)) *xml-string*)) (is (eql (tm-sparql::elem-type (getf result :value)) 'TM-SPARQL::LITERAL))) (signals sparql-parser-error @@ -322,7 +325,7 @@ "http://prefix.value/predicate")) (is (eql (tm-sparql::elem-type (tm-sparql::object elem)) lit)) (is (= (tm-sparql::value (tm-sparql::object elem)) 1234.5e12)) - (is (string= (tm-sparql::literal-type (tm-sparql::object elem)) + (is (string= (tm-sparql::literal-datatype (tm-sparql::object elem)) *xml-double*)) (is-false (tm-sparql::literal-lang (tm-sparql::object elem)))) (is (string= (tm-sparql::parse-triple dummy-object query-3) "")) @@ -336,7 +339,7 @@ "predicate")) (is (eql (tm-sparql::elem-type (tm-sparql::object elem)) lit)) (is (string= (tm-sparql::value (tm-sparql::object elem)) "literal")) - (is (string= (tm-sparql::literal-type (tm-sparql::object elem)) + (is (string= (tm-sparql::literal-datatype (tm-sparql::object elem)) *xml-string*)) (is (string= (tm-sparql::literal-lang (tm-sparql::object elem)) "en"))))) @@ -368,7 +371,7 @@ "http://base.value/predicate")) (is (eql (tm-sparql::elem-type (tm-sparql::object elem)) lit)) (is (eql (tm-sparql::value (tm-sparql::object elem)) t)) - (is (string= (tm-sparql::literal-type (tm-sparql::object elem)) + (is (string= (tm-sparql::literal-datatype (tm-sparql::object elem)) *xml-boolean*)) (is-false (tm-sparql::literal-lang (tm-sparql::object elem)))) (let ((elem (first (tm-sparql::select-group dummy-object)))) @@ -380,7 +383,7 @@ "http://prefix.value/predicate-2")) (is (eql (tm-sparql::elem-type (tm-sparql::object elem)) lit)) (is (= (tm-sparql::value (tm-sparql::object elem)) 12)) - (is (string= (tm-sparql::literal-type (tm-sparql::object elem)) + (is (string= (tm-sparql::literal-datatype (tm-sparql::object elem)) *xml-integer*)) (is-false (tm-sparql::literal-lang (tm-sparql::object elem)))) (is (string= "http://base.value/" (tm-sparql::base-value dummy-object))) @@ -396,7 +399,7 @@ "http://base.value/predicate")) (is (eql (tm-sparql::elem-type (tm-sparql::object elem)) lit)) (is (eql (tm-sparql::value (tm-sparql::object elem)) nil)) - (is (string= (tm-sparql::literal-type (tm-sparql::object elem)) + (is (string= (tm-sparql::literal-datatype (tm-sparql::object elem)) *xml-boolean*)) (is-false (tm-sparql::literal-lang (tm-sparql::object elem)))) (let ((elem (first (tm-sparql::select-group dummy-object)))) @@ -408,7 +411,7 @@ "http://new.base/predicate-2")) (is (eql (tm-sparql::elem-type (tm-sparql::object elem)) lit)) (is (string= (tm-sparql::value (tm-sparql::object elem)) "abc")) - (is (string= (tm-sparql::literal-type (tm-sparql::object elem)) + (is (string= (tm-sparql::literal-datatype (tm-sparql::object elem)) *xml-string*)) (is-false (tm-sparql::literal-lang (tm-sparql::object elem)))))) @@ -514,6 +517,8 @@ (q-obj-2 (make-instance 'TM-SPARQL:SPARQL-Query :query query-2)) (q-obj-3 (make-instance 'TM-SPARQL:SPARQL-Query :query query-3))) (is-true q-obj-1) + (is-true q-obj-2) + (is-true q-obj-3) (is (= (length (tm-sparql::select-group q-obj-1)) 1)) (is (= (length (tm-sparql::subject-result (first (tm-sparql::select-group q-obj-1)))) 4)) @@ -659,7 +664,279 @@ (is (string= (first (tm-sparql::object-result (first (tm-sparql::select-group q-obj-3)))) "http://some.where/psis/poem/zauberlehrling")))))) - + + +(test test-set-result-3 + (with-fixture with-tm-filled-db ("data_base" *poems.xtm*) + (with-revision 0 + (let* ((query-1 "PREFIX pref:<http://some.where/base-psis/> + SELECT $subject WHERE { + ?subject pref:author-info \"http://de.wikipedia.org/wiki/Johann_Wolfgang_von_Goethe\"^^http://www.w3.org/2001/XMLSchema#anyURI }") + (query-2 "BASE <http://some.where/base-psis/> + SELECT $subject WHERE { + ?subject <last-name> 'von Goethe'^^anyType }") + (query-3 "BASE <http://some.where/base-psis/> + SELECT ?subject WHERE{ + ?subject <http://some.where/base-psis/last-name> + 'Johann Wolfgang' }") + (query-4 "PREFIX pref-1:<http://some.where/base-psis/> + PREFIX pref-2:<http://some.where/psis/> + SELECT ?subject WHERE { + ?subject pref-1:written pref-2:poem/resignation }") + (q-obj-1 (make-instance 'TM-SPARQL:SPARQL-Query :query query-1)) + (q-obj-2 (make-instance 'TM-SPARQL:SPARQL-Query :query query-2)) + (q-obj-3 (make-instance 'TM-SPARQL:SPARQL-Query :query query-3)) + (q-obj-4 (make-instance 'TM-SPARQL:SPARQL-Query :query query-4))) + (is-true q-obj-1) + (is-true q-obj-2) + (is-true q-obj-3) + (is-true q-obj-4) + (is (= (length (tm-sparql::select-group q-obj-1)) 1)) + (is (= (length (tm-sparql::select-group q-obj-2)) 1)) + (is (= (length (tm-sparql::select-group q-obj-3)) 1)) + (is (= (length (tm-sparql::select-group q-obj-4)) 1)) + (is (= (length (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-1)))) 1)) + (is (= (length (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-2)))) 0)) + (is (= (length (tm-sparql::predicate-result + (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") + (string= (first (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-1)))) + "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")) + (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")) + (is (string= (first (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-4)))) + "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")))))) + + +(test test-set-result-4 + (with-fixture with-tm-filled-db ("data_base" *poems.xtm*) + (with-revision 0 + (let* ((query-1 "BASE <http://some.where/> + SELECT ?predicate ?object WHERE { + <psis/author/goethe> ?predicate ?object}") + (query-2 "BASE <http://some.where/> + SELECT ?predicate ?object WHERE { + <psis/poem/zauberlehrling> ?predicate ?object}") + (query-3 "BASE <http://some.where/> + SELECT ?predicate WHERE { + <psis/persons/goethe> ?predicate <psis/poem/zauberlehrling>}") + (q-obj-1 (make-instance 'TM-SPARQL:SPARQL-Query :query query-1)) + (q-obj-2 (make-instance 'TM-SPARQL:SPARQL-Query :query query-2)) + (q-obj-3 (make-instance 'TM-SPARQL:SPARQL-Query :query query-3))) + (is-true q-obj-1) + (is-true q-obj-2) + (is-true q-obj-3) + (is (= (length (tm-sparql::select-group q-obj-1)) 1)) + (is (= (length (tm-sparql::select-group q-obj-2)) 1)) + (is (= (length (tm-sparql::select-group q-obj-3)) 1)) + (is (= (length (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-1)))) 7)) + (is (= (length (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-2)))) 4)) + (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") + (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") + (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 + :test #'string=) 2)) + (is (= (count "http://some.where/base-psis/place" predicates + :test #'string=) 1)) + (is (= (count "http://some.where/base-psis/first-name" predicates + :test #'string=) 1)) + (is (= (count "http://some.where/base-psis/last-name" predicates + :test #'string=) 1)) + (is (= (count "http://some.where/base-psis/author-info" predicates + :test #'string=) 1)) + (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 + :test #'string=) 1)) + (is (or (= (count "http://some.where/psis/poem/der_zauberlehrling" + objects :test #'string=) 1) + (= (count "http://some.where/psis/poem/zauberlehrling" objects + :test #'string=) 1))) + (is (or (= (count "http://some.where/base-psis/author" objects + :test #'string=) 1) + (= (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" + objects :test #'string=) 1))) + (is-true (or (null (set-exclusive-or + (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") + (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 + :test #'string=) 1)) + (is (= (count "http://some.where/base-psis/title" predicates + :test #'string=) 1)) + (is (= (count "http://some.where/base-psis/poem-content" predicates + :test #'string=) 1)) + (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 + :test #'string=) 1) + (= (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" + objects :test #'string=) 1)) + ;do not check the entire poem content => too long + ) + (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" + (first (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-3))))))) + (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" + (first (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-3))))) + (string= "http://some.where/psis/poem/zauberlehrling" + (first (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-3))))))))))) + + +(test test-set-result-5 + (with-fixture with-tm-filled-db ("data_base" *poems.xtm*) + (with-revision 0 + (let* ((query-1 "BASE <http://some.where/> + SELECT ?predicate WHERE { + <psis/author/goethe> ?predicate 'Johann Wolfgang'}") + (query-2 "BASE <http://some.where/> + SELECT ?object WHERE { + <psis/author/goethe> <base-psis/written> ?object}") + (query-3 "BASE <http://some.where/> + SELECT ?object WHERE { + <psis/persons/goethe> <base-psis/last-name> ?object. + <does/not/exist> <any-predicate> ?object}") + (q-obj-1 (make-instance 'TM-SPARQL:SPARQL-Query :query query-1)) + (q-obj-2 (make-instance 'TM-SPARQL:SPARQL-Query :query query-2)) + (q-obj-3 (make-instance 'TM-SPARQL:SPARQL-Query :query query-3))) + (is-true q-obj-1) + (is-true q-obj-2) + (is-true q-obj-3) + (is (= (length (tm-sparql::select-group q-obj-1)) 1)) + (is (= (length (tm-sparql::select-group q-obj-2)) 1)) + (is (= (length (tm-sparql::select-group q-obj-3)) 2)) + (is (= (length (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-1)))) 1)) + (is (= (length (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-2)))) 2)) + (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)) + (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" + (first (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-1))))))) + (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" + (first (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-2))))) + (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" + (first (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-2)))))) + (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" + (first (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-2))))) + (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" + (second (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-2))))) + (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" + (second (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-2)))))) + (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" + (second (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-2))))) + (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 + (first (tm-sparql::select-group q-obj-3))))) + (is-false (first (tm-sparql::predicate-result + (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)))))))))) (defun run-sparql-tests ()

1 0

[isidorus-cvs] r356 - in trunk/src: TM-SPARQL unit_tests
by Lukas Giessmann 28 Nov '10

28 Nov '10

Author: lgiessmann Date: Sun Nov 28 14:47:27 2010 New Revision: 356 Log: TM-SPARQL: added some unit-tests for processing single triples in a SELECT-WHERE statement => fixed some bugs in the SPARQL-queries Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_parser.lisp trunk/src/unit_tests/poems.xtm 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 Nov 28 14:47:27 2010 @@ -114,7 +114,13 @@ (defclass SPARQL-Query () - ((original-query :initarg :query + ((revision :initarg :revision + :accessor revision + :type Integer + :initform 0 + :documentation "Represents the revision in which all the queries + are processed in the DB.") + (original-query :initarg :query :accessor original-query ;this value is only for internal ;purposes and mustn't be reset :type String @@ -230,9 +236,9 @@ (filter-by-given-predicate construct :revision revision) (filter-by-given-object construct :revision revision)))) (map 'list #'(lambda(result) - (push (getf result :subject) (subject construct)) - (push (getf result :predicate) (predicate construct)) - (push (getf result :object) (object construct))) + (push (getf result :subject) (subject-result construct)) + (push (getf result :predicate) (predicate-result construct)) + (push (getf result :object) (object-result construct))) ;;literal-datatype is not used and is not returned, since ;;the values are returned as object of their specific type, e.g. ;;integer, boolean, string, ... @@ -244,7 +250,9 @@ of a given object.") (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*)) (declare (Integer revision)) - (unless (variable-p (object construct)) + (when (and (not (variable-p (object construct))) + (variable-p (predicate construct)) + (variable-p (subject construct))) (cond ((literal-p (object construct)) (filter-by-characteristic-value (value (object construct)) (literal-datatype (object construct)) @@ -304,7 +312,12 @@ :predicate pred :object (charvalue char) :literal-datatyp literal-datatype)))) - chars)))) + ;;elephant returns names, occurences, and variants if any string + ;;value matches, so all duplicates have to be removed, additionaly + ;;variants have to be remove completely + (remove-if #'(lambda(obj) + (typep obj 'VariantC)) + (remove-duplicates chars)))))) (defgeneric filter-by-otherplayer (construct &key revision) @@ -328,7 +341,7 @@ (when-do type (instance-of role :revision revision) (any-id type :revision revision))) (subj-uri - (when-do plr (instance-of orole :revision revision) + (when-do plr (player orole :revision revision) (any-id plr :revision revision)))) (when (and obj-uri pred-uri subj-uri) (list :subject subj-uri @@ -364,16 +377,18 @@ (when (or (variable-p (object construct)) (iri-p (object construct))) (let* ((roles-by-type - (map 'list #'(lambda(typed-construct) - (when (typep typed-construct 'RoleC) - typed-construct)) - (used-as-type construct :revision revision))) + (remove-null + (map 'list #'(lambda(typed-construct) + (when (typep typed-construct 'RoleC) + typed-construct)) + (used-as-type (value (predicate construct)) :revision revision)))) (roles-by-player (if (iri-p (object construct)) (remove-null (map 'list #'(lambda(role) - (when (eql (instance-of role :revision revision) - (value (object construct))))) + (when (eql (player role :revision revision) + (value (object construct))) + role)) roles-by-type)) roles-by-type)) (pred-uri (any-id (value (predicate construct)) :revision revision))) @@ -415,7 +430,7 @@ (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*)) (declare (Integer revision)) (when (and (not (iri-p (object construct))) - (or (not (literal-datatype construct)) + (or (not (literal-datatype (object construct))) (string= (literal-datatype construct) *xml-string*))) (let* ((names-by-type (remove-null @@ -426,12 +441,13 @@ :revision revision)))) (names-by-literal (if (variable-p (object construct)) + names-by-type (remove-null (map 'list #'(lambda(name) - (string= (charvalue name) - (value (object construct)))) - names-by-type)) - names-by-type))) + (when (string= (charvalue name) + (value (object construct))) + name)) + names-by-type))))) (remove-null (map 'list #'(lambda(name) @@ -713,4 +729,6 @@ (defmethod initialize-instance :after ((construct SPARQL-Query) &rest args) (declare (ignorable args)) (parser-start construct (original-query construct)) + (dolist (triple (select-group construct)) + (set-results triple :revision (revision construct))) construct) \ No newline at end of file Modified: trunk/src/TM-SPARQL/sparql_parser.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_parser.lisp (original) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Sun Nov 28 14:47:27 2010 @@ -208,11 +208,12 @@ ((string-starts-with-digit trimmed-str) (parse-literal-number-value trimmed-str query-object))))) (list :next-query (getf value-type-lang-query :next-query) - :value (make-instance 'SPARQL-Triple-Elem - :elem-type 'LITERAL - :value (getf value-type-lang-query :value) - :literal-lang (getf value-type-lang-query :lang) - :literal-type (getf value-type-lang-query :type))))) + :value (make-instance + 'SPARQL-Triple-Elem + :elem-type 'LITERAL + :value (getf value-type-lang-query :value) + :literal-lang (getf value-type-lang-query :lang) + :literal-datatype (getf value-type-lang-query :type))))) (defun parse-literal-string-value (query-string query-object) Modified: trunk/src/unit_tests/poems.xtm ============================================================================== --- trunk/src/unit_tests/poems.xtm (original) +++ trunk/src/unit_tests/poems.xtm Sun Nov 28 14:47:27 2010 @@ -1,16 +1,16 @@ <?xml version="1.0" encoding="UTF-8"?> <tm:topicMap version="2.0" xmlns:tm="http://www.topicmaps.org/xtm/"> -  -  -  -  -  -  -  -  -  -  -  +  +  +  +  +  +  +  +  +  +  +     Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Sun Nov 28 14:47:27 2010 @@ -12,6 +12,9 @@ :it.bese.FiveAM :TM-SPARQL :exceptions + :unittests-constants + :fixtures + :d :constants) (:export :run-sparql-tests :sparql-tests @@ -19,7 +22,9 @@ :test-parse-literals :test-parse-triple-elem :test-parse-group-1 - :test-parse-group-2)) + :test-parse-group-2 + :test-set-result-1 + :test-set-result-2)) (in-package :sparql-test) @@ -408,5 +413,254 @@ (is-false (tm-sparql::literal-lang (tm-sparql::object elem)))))) +(test test-set-result-1 + (with-fixture with-tm-filled-db ("data_base" *poems.xtm*) + (with-revision 0 + (let* ((query-1 "BASE <http://some.where/> + SELECT ?subject ?predicate ?object WHERE { + ?subject ?predicate ?object }") + (query-2 "BASE <http://some.where/psis/poem/> + SELECT $subject ?predicate WHERE{ + ?subject $predicate <zauberlehrling> }") + (query-3 "SELECT ?predicate ?subject WHERE + {?subject ?predicate \"Johann Wolfgang\" }") + (q-obj-1 (make-instance 'TM-SPARQL:SPARQL-Query :query query-1)) + (q-obj-2 (make-instance 'TM-SPARQL:SPARQL-Query :query query-2)) + (q-obj-3 (make-instance 'TM-SPARQL:SPARQL-Query :query query-3))) + (is-true q-obj-1) + (is (= (length (tm-sparql::select-group q-obj-1)) 1)) + (is-true q-obj-2) + (is (= (length (tm-sparql::select-group q-obj-2)) 1)) + (is-true q-obj-3) + (is (= (length (tm-sparql::select-group q-obj-3)) 1)) + (is-false (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-1)))) + (is-false (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-1)))) + (is-false (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-1)))) + (is (= (length (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-2)))) 2)) + (is (= (length (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-2)))) 2)) + (is (= (length (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-2)))) 2)) + (let ((subj-1 (first (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-2))))) + (subj-2 (second (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-2))))) + (pred-1 (first (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-2))))) + (pred-2 (second (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-2))))) + (obj-1 (first (tm-sparql::object-result + (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")))) + (t + (is-true nil)))) + (is (= (length (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-3)))) 1)) + (is (= (length (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-3)))) 1)) + (is (= (length (tm-sparql::object-result + (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") + (string= (first (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-3)))) + "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")) + (is (string= (first (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-3)))) + "Johann Wolfgang")))))) + + +(test test-set-result-2 + (with-fixture with-tm-filled-db ("data_base" *poems.xtm*) + (with-revision 0 + (let* ((query-1 "PREFIX pref:<http://some.where/base-psis/> + SELECT $subject $object WHERE { + ?subject pref:written ?object }") + (query-2 "BASE <http://some.where/base-psis/> + SELECT $subject $object WHERE { + ?subject <first-name> ?object }") + (query-3 "BASE <http://some.where/psis/> + SELECT ?subject WHERE{ + ?subject <http://some.where/base-psis/written> + <poem/zauberlehrling>}") + (q-obj-1 (make-instance 'TM-SPARQL:SPARQL-Query :query query-1)) + (q-obj-2 (make-instance 'TM-SPARQL:SPARQL-Query :query query-2)) + (q-obj-3 (make-instance 'TM-SPARQL:SPARQL-Query :query query-3))) + (is-true q-obj-1) + (is (= (length (tm-sparql::select-group q-obj-1)) 1)) + (is (= (length (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-1)))) 4)) + (is (= (length (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-1)))) 4)) + (is (= (length (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-1)))) 4)) + (let* ((s-1 (first (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-1))))) + (s-2 (second (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-1))))) + (s-3 (third (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-1))))) + (s-4 (fourth (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-1))))) + (p-1 (first (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-1))))) + (p-2 (second (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-1))))) + (p-3 (third (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-1))))) + (p-4 (fourth (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-1))))) + (o-1 (first (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-1))))) + (o-2 (second (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-1))))) + (o-3 (third (tm-sparql::object-result + (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 (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 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 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 o-1 o-2 o-3 o-4) + :test #'string=))) + (is-true q-obj-2) + (is (= (length (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-2)))) 3)) + (is (= (length (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-2)))) 3)) + (is (= (length (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-2)))) 3)) + (let* ((s-1 (first (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-2))))) + (s-2 (second (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-2))))) + (s-3 (third (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-2))))) + (p-1 (first (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-2))))) + (p-2 (second (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-2))))) + (p-3 (third (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-2))))) + (o-1 (first (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-2))))) + (o-2 (second (tm-sparql::object-result + (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") + (cond ((string= o-1 "Johann Christoph Friedrich") + (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 (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= 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"))) + (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= 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= 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")) + (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 (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= o-3 "Johann Wolfgang"))) + (t + (is-true nil)))) + (t + (is-true nil)))) + (is-true q-obj-3) + (is (= (length (tm-sparql::select-group q-obj-3)) 1)) + (is (= (length (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-3)))) 1)) + (is (= (length (tm-sparql::predicate-result + (first (tm-sparql::select-group q-obj-3)))) 1)) + (is (= (length (tm-sparql::object-result + (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") + (string= (first (tm-sparql::subject-result + (first (tm-sparql::select-group q-obj-3)))) + "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")) + (is (string= (first (tm-sparql::object-result + (first (tm-sparql::select-group q-obj-3)))) + "http://some.where/psis/poem/zauberlehrling")))))) + + + (defun run-sparql-tests () (it.bese.fiveam:run! 'sparql-test:sparql-tests))

1 0

[isidorus-cvs] r355 - in trunk/src: TM-SPARQL model
by Lukas Giessmann 27 Nov '10

27 Nov '10

Author: lgiessmann Date: Sat Nov 27 11:40:38 2010 New Revision: 355 Log: TM-SPARQL: fixed ticket #86 => requests without FILTERs can be processed Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_parser.lisp trunk/src/model/datamodel.lisp trunk/src/model/trivial-queries.lisp Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Sat Nov 27 11:40:38 2010 @@ -11,10 +11,33 @@ (:use :cl :datamodel :base-tools :exceptions :constants) (:export :SPARQL-Query)) +;;TODO: +;; *handle special URIs => http://www.networkedplanet.com/ontopic/2009/11/making_topic_maps_sparql.html (in-package :TM-SPARQL) -(defvar *empty-label* "_empty_label_symbol") +(defvar *empty-label* "_empty_label_symbol" "A label symobl for empyt prefix labels") + +(defvar *equal-operators* nil "A Table taht contains tuples of + classes and equality operators.") + +(defun init-*equal-operators* () + (setf *equal-operators* + (list (list :class 'Boolean :operator #'eql) + (list :class 'String :operator #'string=) + (list :class 'Number :operator #'=)))) + + +(init-*equal-operators*) + + +(defun get-equal-operator (value) + (let ((entry + (find-if #'(lambda(entry) + (typep value (getf entry :class))) + *equal-operators*))) + (when entry + (getf entry :operator)))) (defclass SPARQL-Triple-Elem() @@ -37,11 +60,12 @@ :initform nil :type String :documentation "Contains the @lang attribute of a literal") - (literal-type :initarg :literal-type - :accessor literal-type - :type String - :initform nil - :documentation "Contains the datatype of the literal, e.g. xml:string")) + (literal-datatype :initarg :literal-datatype + :accessor literal-datatype + :type String + :initform nil + :documentation "Contains the datatype of the literal, + e.g. xml:string")) (:documentation "Represents one element of an RDF-triple.")) @@ -195,36 +219,495 @@ (variables construct)))))) - - -;;TODO: -;; -;; find-triples (subject predicate object) -;; * var var var => return the entire graph (all subjects) -;; * var var object -;; * var predicate var -;; * var predicate object -;; * subject var var -;; * subject var object -;; * subject predicate var -;; * subject predicate object => return subject predicate object if true otherweise nil -;; handle special URIs => http://www.networkedplanet.com/ontopic/2009/11/making_topic_maps_sparql.html - -(defgeneric set-result (construct) +(defgeneric set-results (construct &key revision) (:documentation "Calculates the result of a triple and set all the values in the passed object.") + (:method ((construct SPARQL-Triple) &key (revision d:*TM-REVISION*)) + (declare (Integer revision)) + (set-tm-constructs construct :revision revision) + (when (not (iri-not-found-p construct)) ;there is only a result if all IRIs were found + (let ((results (or (filter-by-given-subject construct :revision revision) + (filter-by-given-predicate construct :revision revision) + (filter-by-given-object construct :revision revision)))) + (map 'list #'(lambda(result) + (push (getf result :subject) (subject construct)) + (push (getf result :predicate) (predicate construct)) + (push (getf result :object) (object construct))) + ;;literal-datatype is not used and is not returned, since + ;;the values are returned as object of their specific type, e.g. + ;;integer, boolean, string, ... + results))))) + + +(defgeneric filter-by-given-object (construct &key revision) + (:documentation "Returns a list representing a triple that is the result + of a given object.") + (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*)) + (declare (Integer revision)) + (unless (variable-p (object construct)) + (cond ((literal-p (object construct)) + (filter-by-characteristic-value (value (object construct)) + (literal-datatype (object construct)) + :revision revision)) + ((iri-p (object construct)) + (filter-by-otherplayer (value (object construct)) + :revision revision)))))) + + +(defun filter-by-characteristic-value (literal-value literal-datatype + &key (revision *TM-REVISION*)) + "Returns a triple where the passed value is a charvalue in a occurrence + or name. The subject is the owner topic and the predicate is the + characteristic's type." + (declare (Integer revision) + (String literal-value literal-datatype)) + (let ((chars + (cond ((string= literal-datatype *xml-string*) + (remove-if #'(lambda(elem) + (string/= (charvalue elem) literal-value)) + (append + (elephant:get-instances-by-value + 'OccurrenceC 'charvalue literal-value) + (elephant:get-instances-by-value + 'NameC 'charvalue literal-value)))) + ((and (string= literal-datatype *xml-boolean*) + (eql literal-value t)) + (remove-if #'(lambda(elem) + (string/= (charvalue elem) "true")) + (elephant:get-instances-by-value + 'OccurrenceC 'charvalue "true"))) + ((and (string= literal-datatype *xml-boolean*) + (eql literal-value nil)) + (remove-if #'(lambda(elem) + (string/= (charvalue elem) "false")) + (elephant:get-instances-by-value + 'OccurrenceC 'charvalue "false"))) + ((or (string= literal-datatype *xml-double*) + (string= literal-datatype *xml-decimal*) + (string= literal-datatype *xml-integer*)) + (let ((occs + (remove-if #'(lambda(occ) + (string/= (datatype occ) literal-datatype)) + (elephant:get-instances-by-value + 'OccurrenceC 'datatype literal-datatype)))) + (remove-if #'(lambda(occ) + (not (literal= (charvalue occ) literal-value))) + occs)))))) + (remove-null + (map 'list #'(lambda(char) + (let ((subj (when-do top (parent char :revision revision) + (any-id top :revision revision))) + (pred (when-do top (instance-of char :revision revision) + (any-id top :revision revision)))) + (when (and subj pred) + (list :subject subj + :predicate pred + :object (charvalue char) + :literal-datatyp literal-datatype)))) + chars)))) + + +(defgeneric filter-by-otherplayer (construct &key revision) + (:documentation "Returns triples where the passed player is the object, + the other player is the subject and the type of the passed + player's role is the predicate.") + (:method ((construct TopicC) &key (revision *TM-REVISION*)) + (declare (Integer revision)) + (let ((roles-by-oplayer (player-in-roles construct :revision revision)) + (obj-uri (any-id construct :revision revision))) + (remove-null + (map 'list + #'(lambda(role) + (let* ((orole + (when-do assoc (parent role :revision revision) + (when (= (length (roles assoc :revision revision)) + 2) + (find-if #'(lambda(r) (not (eql r role))) + (roles assoc :revision revision))))) + (pred-uri + (when-do type (instance-of role :revision revision) + (any-id type :revision revision))) + (subj-uri + (when-do plr (instance-of 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)))) + roles-by-oplayer))))) + + +(defgeneric filter-by-given-predicate (construct &key revision) + (:documentation "Returns all topics that owns a characteristic of the + given type or an associaiton with an otherrole of the + given type. The result is a plist representing a triple.") + (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*)) + (declare (Integer revision)) + (when (and (variable-p (subject construct)) + (iri-p (predicate construct))) + (cond ((variable-p (object construct)) + (append (filter-by-otherroletype construct :revision revision) + (filter-by-characteristictype construct :revision revision))) + ((literal-p (object construct)) + (filter-by-characteristictype construct :revision revision)) + ((iri-p (object construct)) + (filter-by-otherroletype construct :revision revision)))))) + + +(defgeneric filter-by-otherroletype (construct &key revision) + (:documentation "Returns triple where the passed predicate is a + type of a role. The returned subject is the otherplayer, + the predicate is the passed predicate, the object is + the player of the role of the passed type.") + (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*)) + (declare (Integer revision)) + (when (or (variable-p (object construct)) + (iri-p (object construct))) + (let* ((roles-by-type + (map 'list #'(lambda(typed-construct) + (when (typep typed-construct 'RoleC) + typed-construct)) + (used-as-type construct :revision revision))) + (roles-by-player + (if (iri-p (object construct)) + (remove-null + (map 'list #'(lambda(role) + (when (eql (instance-of role :revision revision) + (value (object construct))))) + roles-by-type)) + roles-by-type)) + (pred-uri (any-id (value (predicate construct)) :revision revision))) + (remove-null + (map 'list + #'(lambda(role) + (let* ((obj-uri + (when-do plr-top (player role :revision revision) + (any-id plr-top :revision revision))) + (assoc (parent role :revision revision)) + (orole (when (and assoc + (= (length + (roles assoc :revision revision)) + 2)) + (find-if #'(lambda(r) + (not (eql r role))) + (roles assoc :revision revision)))) + (subj-uri + (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)))) + roles-by-player)))))) + + +(defgeneric filter-by-characteristictype (construct &key revision) + (:documentation "Returns the results of filter-by-nametype and + filter-by-occurrencetype.") + (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*)) + (declare (Integer revision)) + (append (filter-by-nametype construct :revision revision) + (filter-by-occurrencetype construct :revision revision)))) + + +(defgeneric filter-by-nametype (construct &key revision) + (:documentation "Returns all names that corresponds to the given parameters.") + (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*)) + (declare (Integer revision)) + (when (and (not (iri-p (object construct))) + (or (not (literal-datatype construct)) + (string= (literal-datatype construct) *xml-string*))) + (let* ((names-by-type + (remove-null + (map 'list #'(lambda(typed-construct) + (when (typep typed-construct 'NameC) + typed-construct)) + (used-as-type (value (predicate construct)) + :revision revision)))) + (names-by-literal + (if (variable-p (object construct)) + (remove-null + (map 'list #'(lambda(name) + (string= (charvalue name) + (value (object construct)))) + names-by-type)) + names-by-type))) + (remove-null + (map 'list + #'(lambda(name) + (let ((subj + (when-do top (parent name :revision revision) + (any-id top :revision revision))) + (pred + (when-do top (instance-of name :revision revision) + (any-id top :revision revision)))) + (when (and subj pred) + (list :subject subj + :predicate pred + :object (charvalue name) + :literal-datatype *xml-string*)))) + names-by-literal)))))) + + +(defgeneric filter-by-occurrencetype (construct &key revision) + (:documentation "Returns all occurrence that corresponds to the + given parameters.") + (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*)) + (declare (Integer revision)) + (unless (iri-p (object construct)) + (let* ((occs-by-type + (remove-null + (map 'list #'(lambda(typed-construct) + (when (typep typed-construct 'OccurrenceC) + typed-construct)) + (used-as-type (value (predicate construct)) + :revision revision)))) + (all-occs + (let ((literal-value (if (variable-p (object construct)) + nil + (value (object construct)))) + (literal-datatype (literal-datatype (object construct)))) + (remove-null + (map 'list #'(lambda(occ) + (filter-occ-by-value occ literal-value + literal-datatype)) + occs-by-type))))) + (remove-null + (map 'list + #'(lambda(occ) + (let ((subj + (when-do top (parent occ :revision revision) + (any-id top :revision revision))) + (pred + (when-do top (instance-of occ :revision revision) + (any-id top :revision revision)))) + (when (and subj pred) + (list :subject subj + :predicate pred + :object (charvalue occ) + :literal-datatype (datatype occ))))) + all-occs)))))) + + +(defgeneric filter-by-given-subject (construct &key revision) + (:documentation "Calls filter-characteristics and filter associations + for the topic that is set as a subject of the passed triple.") + (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*)) + (declare (Integer revision)) + (when (iri-p (subject construct)) + (let* ((subj (value (subject construct))) + (pred (when (iri-p (predicate construct)) + (value (predicate construct))))) + (cond ((variable-p (object construct)) + (append (filter-characteristics + subj pred nil nil :revision revision) + (filter-associations + subj pred nil :revision revision))) + ((literal-p (object construct)) + (filter-characteristics + subj pred (value (subject construct)) + (literal-datatype (object construct)) :revision revision)) + ((iri-p (object construct)) + (filter-associations subj pred (value (object construct)) + :revision revision))))))) + + +(defgeneric literal-p (construct) + (:documentation "Returns t if the passed construct has an elem-type + set to 'LITERAL.") + (:method ((construct SPARQL-Triple-Elem)) + (eql (elem-type construct) 'LITERAL))) + + +(defgeneric iri-p (construct) + (:documentation "Returns t if the passed construct has an elem-type + set to 'IRI.") + (:method ((construct SPARQL-Triple-Elem)) + (eql (elem-type construct) 'IRI))) + + +(defgeneric variable-p (construct) + (:documentation "Returns t if the passed construct has an elem-type + set to 'VARIABLE.") + (:method ((construct SPARQL-Triple-Elem)) + (eql (elem-type construct) 'VARIABLE))) + + +(defgeneric iri-not-found-p (construct) + (:documentation "Must be called after a call of set-tm-constructs. + It returns t if a TM-construct was not found for a + given IRI, so the result value of a query is nil.") (:method ((construct SPARQL-Triple)) - ;;TODO: implement - construct)) - - -(defgeneric find-subject-var-var (construct) - (:documentation "Finds a triple corresponding to the subject and sets - both variables.") - (:method ((construct SPARQL-Triple)) - - )) - + (or (iri-not-found-p (subject construct)) + (iri-not-found-p (predicate construct)) + (iri-not-found-p (object construct))))) + + +(defmethod iri-not-found-p ((construct SPARQL-Triple-Elem)) + (and (eql (elem-type construct) 'IRI) + (not (value construct)))) + + +(defgeneric set-tm-constructs (construct &key revision) + (:documentation "Calls the method set-tm-construct for every element + in a SPARQL-Triple object.") + (:method ((construct SPARQL-Triple) &key (revision *TM-REVISION*)) + (when-do subj (subject construct) + (set-tm-construct subj :revision revision)) + (when-do pred (predicate construct) + (set-tm-construct pred :revision revision)) + (when-do obj (object construct) (set-tm-construct obj :revision revision)))) + + +(defgeneric set-tm-construct (construct &key revision) + (:documentation "Replaces the IRI in the given object by the corresponding + TM-construct.") + (:method ((construct SPARQL-Triple-Elem) &key (revision *TM-REVISION*)) + (declare (Integer revision)) + (when (eql (elem-type construct) 'IRI) + (setf (value construct) + (get-item-by-any-id (value construct) :revision revision))))) + + +(defun literal= (value-1 value-2) + "Returns t if both arguments are equal. The equality function is searched in + the table *equal-operators*." + (when (or (and (numberp value-1) (numberp value-2)) + (typep value-1 (type-of value-2)) + (typep value-2 (type-of value-1))) + (let ((operator (get-equal-operator value-1))) + (funcall operator value-1 value-2)))) + + +(defun filter-occ-by-value (occurrence literal-value literal-datatype) + "A helper that compares the occurrence's charvalue with the passed + literal value." + (declare (OccurrenceC occurrence) + (type (or Null String) literal-value literal-datatype)) + (when (or (not literal-datatype) + (string= (datatype occurrence) literal-datatype)) + (if (not literal-value) + occurrence + (handler-case + (let ((occ-value (cast-literal (charvalue occurrence) + (datatype occurrence)))) + (when (literal= occ-value literal-value) + occurrence)) + (condition () nil))))) + + +(defgeneric filter-occurrences(construct type-top literal-value + literal-datatype &key revision) + (:documentation "Returns a list representing a triple.") + (:method ((construct TopicC) type-top literal-value literal-datatype + &key (revision *TM-REVISION*)) + (declare (Integer revision) + (type (or Null String) literal-value literal-datatype) + (type (or Null TopicC) type-top)) + (let* ((occs-by-type + (occurrences-by-type construct type-top :revision revision)) + (all-occs + (remove-null + (map 'list + #'(lambda(occ) + (filter-occ-by-value occ literal-value literal-datatype)) + occs-by-type))) + (subj-uri (any-id construct :revision revision))) + (remove-null + (map 'list #'(lambda(occ) + (let ((pred-uri + (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 + :object (charvalue occ) + :literal-datatype (datatype occ))))) + all-occs))))) + + +(defgeneric filter-names(construct type-top literal-value + &key revision) + (:documentation "Returns a list representing a triple.") + (:method ((construct TopicC) type-top literal-value + &key (revision *TM-REVISION*)) + (declare (Integer revision) + (type (or Null String) literal-value) + (type (or Null TopicC) type-top)) + (let* ((by-type + (names-by-type construct type-top :revision revision)) + (by-literal (if literal-value + (names-by-value + construct #'(lambda(name) + (string= name literal-value)) + :revision revision) + (names construct :revision revision))) + (all-names (intersection by-type by-literal)) + (subj-uri (any-id construct :revision revision))) + (remove-null + (map 'list #'(lambda(name) + (let ((pred-uri + (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 + :object (charvalue name) + :literal-datatype *xml-string*)))) + all-names))))) + + +(defgeneric filter-characteristics (construct type-top literal-value + literal-datatype &key revision) + (:documentation "Returns a list representing a triple.") + (:method ((construct TopicC) type-top literal-value literal-datatype + &key (revision *TM-REVISION*)) + (declare (Integer revision) + (type (or Null String) literal-value literal-datatype) + (type (or Null TopicC) type-top)) + (let ((occs (filter-occurrences construct type-top literal-value + literal-datatype :revision revision)) + (names (if (or (not literal-datatype) + (string= literal-datatype *xml-string*)) + (filter-names construct type-top literal-value + :revision revision) + nil))) + (append occs names)))) + + +(defgeneric filter-associations(construct type-top player-top + &key revision) + (:documentation "Returns a list of the form (:type <uri> :value <uri>). + type-identifier is the type of the otherrole and + player-identifier if the otherplayer.") + (:method ((construct TopicC) type-top player-top + &key (revision *TM-REVISION*)) + (declare (Integer revision) + (type (or Null TopicC) type-top player-top)) + (let ((assocs + (associations-of construct nil nil type-top player-top + :revision revision))) + (remove-null ;only assocs with two roles can match! + (map 'list + #'(lambda(assoc) + (when (= (length (roles assoc :revision revision)) 2) + (let* ((other-role + (find-if #'(lambda(role) + (not (eql construct + (player role :revision revision)))) + (roles assoc :revision revision))) + (pred-uri + (when-do type-top (instance-of other-role + :revision revision) + (any-id type-top :revision revision))) + (obj-uri + (when-do player-top (player other-role + :revision revision) + (any-id player-top :revision revision)))) + (when (and pred-uri obj-uri) + (list :type pred-uri + :value obj-uri))))) + assocs))))) (defmethod initialize-instance :after ((construct SPARQL-Query) &rest args) Modified: trunk/src/TM-SPARQL/sparql_parser.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_parser.lisp (original) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Sat Nov 27 11:40:38 2010 @@ -92,7 +92,10 @@ next-query (original-query construct) "WHERE"))) (let* ((triples (string-after next-query "WHERE")) (query-tail (parse-where construct triples))) - (or query-tail) ;TODO: process tail-of query, e.g. order by, ... + (when (> (length query-tail) 0) + (error (make-sparql-parser-condition + query-tail (original-query construct) + "The end of the query. Solution sequence modifiers are not supported yet."))) construct)))) @@ -147,7 +150,7 @@ (declare (String query-string) (SPARQL-Query query-object)) ;;TODO: implement - (or query-string query-object)) + ) (defun parse-triple-elem (query-string query-object &key (literal-allowed nil)) @@ -264,8 +267,12 @@ 'sparql-parser-error :message (format nil "Could not cast from ~a to ~a" literal-value literal-type)))) - value)))) - + value)) + (t + (error (make-condition + 'sparql-error + :message (format nil "The type \"~a\" is not supported." + literal-type)))))) (defun separate-literal-lang-or-type (query-string query-object) "A helper function that returns (:next-query string :lang string Modified: trunk/src/model/datamodel.lisp ============================================================================== --- trunk/src/model/datamodel.lisp (original) +++ trunk/src/model/datamodel.lisp Sat Nov 27 11:40:38 2010 @@ -43,6 +43,7 @@ :FragmentC ;;methods, functions and macros + :get-all-identifiers-of-construct :xtm-id :uri :identified-construct @@ -108,6 +109,8 @@ :get-item-by-item-identifier :get-item-by-locator :get-item-by-content + :get-item-by-any-id + :any-id :string-integer-p :with-revision :get-latest-fragment-of-topic @@ -170,6 +173,7 @@ :invoke-on :names-by-type :occurrences-by-type + :occurrences-by-datatype :characteristics-by-type :occurrences-by-value :names-by-value @@ -1028,6 +1032,11 @@ the TM.")) +(defgeneric any-id (construct &key revision) + (:documentation "Returns any uri of the constructs identifier, except + TopicIdentificationC. The order is: PSIs, SL, II.")) + + ;;; generic functions/accessors ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; VersionInfocC @@ -1838,6 +1847,28 @@ (item-identifiers construct :revision revision))) +(defun get-item-by-any-id (id-uri &key (revision d:*TM-REVISION*)) + "Returns a topic or REfifiableConstruct corresponding to the given uri." + (declare (String id-uri) + (Integer revision)) + (or (d:get-item-by-psi id-uri :revision revision) + (get-item-by-item-identifier id-uri :revision revision) + (get-item-by-locator id-uri :revision revision))) + + +(defmethod any-id ((construct TopicC) &key (revision *TM-REVISION*)) + (declare (Integer revision)) + (let ((psi (when-do psis (psis construct :revision revision) + (uri (first psis))))) + (if psi + psi + (let ((sl (when-do sls (locators construct :revision revision) + (uri (first sls))))) + (if sl + sl + (call-next-method)))))) + + (defgeneric names (construct &key revision) (:documentation "Returns the NameC-objects that correspond with the passed construct and the passed version.") @@ -3159,7 +3190,6 @@ construct 'reifier :start-revision revision))) (when assocs ;assocs must be nil or a list with exactly one item (reifier-topic (first assocs)))))) -1 (defgeneric add-item-identifier (construct item-identifier &key revision) @@ -3229,6 +3259,12 @@ construct))) +(defmethod any-id ((construct ReifiableConstructC) &key (revision *TM-REVISION*)) + (declare (Integer revision)) + (when-do iis (item-identifiers construct :revision revision) + (uri (first iis)))) + + (defgeneric add-reifier (construct reifier-topic &key revision) (:documentation "Adds the passed reifier-topic as reifier of the construct. If the construct is already reified by the given topic Modified: trunk/src/model/trivial-queries.lisp ============================================================================== --- trunk/src/model/trivial-queries.lisp (original) +++ trunk/src/model/trivial-queries.lisp Sat Nov 27 11:40:38 2010 @@ -321,6 +321,20 @@ (occurrences-by-value construct filter :revision revision)))) +(defgeneric occurrences-by-datatype (construct datatype &key revision) + (:documentation "Returns all occurrences of the specified datatype.") + (:method ((construct TopicC) datatype &key (revision *TM-REVISION*)) + (declare (type (or Null String) datatype) + (Integer revision)) + (if datatype + (remove-null + (map 'list #'(lambda(occ) + (when (string= (datatype occ) datatype) + occ)) + (occurrences construct :revision revision))) + (occurrences construct :revision revision)))) + + (defgeneric isa (construct type &key revision) (:documentation "Returns all types if the passed construct is of the specified type.")

1 0