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

[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