From lgiessmann at common-lisp.net Thu Mar 3 17:00:15 2011 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Thu, 03 Mar 2011 12:00:15 -0500 Subject: [isidorus-cvs] r396 - trunk/src/unit_tests Message-ID: Author: lgiessmann Date: Thu Mar 3 12:00:13 2011 New Revision: 396 Log: tmsparql: added a new test file for the sparql-api Added: trunk/src/unit_tests/sparql_test.xtm Added: trunk/src/unit_tests/sparql_test.xtm ============================================================================== --- (empty file) +++ trunk/src/unit_tests/sparql_test.xtm Thu Mar 3 12:00:13 2011 @@ -0,0 +1,217 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + Johann Wolfgang + + + + von Goethe + + + Goethe + + + + + Johann Wolfgang von Goethe + + + + + 28.08.1749 + + + + 22.03.1832 + + + + 82 + + + + true + + + + + + + + + + + + + + + + + + + + Der Zauberlehrling + + + + + Hat der alte Hexenmeister + sich doch einmal wegbegeben! + ... + + + + + + + + + + + + + + + + + + + + + + + + + + + + From lgiessmann at common-lisp.net Thu Mar 31 11:34:18 2011 From: lgiessmann at common-lisp.net (Lukas Giessmann) Date: Thu, 31 Mar 2011 07:34:18 -0400 Subject: [isidorus-cvs] r397 - in trunk/src: . TM-SPARQL base-tools unit_tests Message-ID: Author: lgiessmann Date: Thu Mar 31 07:34:18 2011 New Revision: 397 Log: tm-sparql: finished all unittests that checks the api's behaviour with different literal datatypes => fixed several bugs that handles xml-boolean, xml-integer, xml-decimal, xml-double, and xml-date values; fixed a bug in the xtm test file; extended the function "literal=" so any objects can be compared to other objects in the string^^datatype format. Modified: trunk/src/TM-SPARQL/sparql.lisp trunk/src/TM-SPARQL/sparql_parser.lisp trunk/src/TM-SPARQL/tmsparql_core_psis.xtm trunk/src/base-tools/base-tools.lisp trunk/src/constants.lisp trunk/src/isidorus.asd trunk/src/unit_tests/sparql_test.lisp trunk/src/unit_tests/sparql_test.xtm trunk/src/unit_tests/unittests-constants.lisp Modified: trunk/src/TM-SPARQL/sparql.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql.lisp (original) +++ trunk/src/TM-SPARQL/sparql.lisp Thu Mar 31 07:34:18 2011 @@ -502,7 +502,8 @@ (defun return-characteristics (literal-value literal-datatype) - "Returns all characteristica that own the specified value." + "Returns all characteristica that own the specified value. + Note the type xsd:date is not supported and so handled as a string." (declare (String literal-datatype)) (let ((chars (cond ((string= literal-datatype *xml-string*) @@ -516,7 +517,8 @@ (elephant:get-instances-by-value 'NameC 'charvalue literal-value)))) ((and (string= literal-datatype *xml-boolean*) - literal-value) + (or (and (stringp literal-value) (string= literal-value "true")) + (and (typep literal-value 'Boolean) literal-value))) (remove-if #'(lambda(elem) (string/= (charvalue elem) "true")) (append (elephant:get-instances-by-value @@ -524,7 +526,8 @@ (elephant:get-instances-by-value 'OccurrenceC 'charvalue "true")))) ((and (string= literal-datatype *xml-boolean*) - (not literal-value)) + (or (and (stringp literal-value) (string= literal-value "false")) + (and (typep literal-value 'Boolean) (not literal-value)))) (remove-if #'(lambda(elem) (string/= (charvalue elem) "false")) (append (elephant:get-instances-by-value @@ -541,9 +544,15 @@ (elephant:get-instances-by-value 'VariantC 'datatype literal-datatype) (elephant:get-instances-by-value - 'OccurrenceC 'datatype literal-datatype))))) + 'OccurrenceC 'datatype literal-datatype)))) + (user-val (if (stringp literal-value) + (concat "\"\"\"" literal-value "\"\"\"^^" + literal-datatype) + literal-value))) (remove-if #'(lambda(con) - (not (literal= (charvalue con) literal-value))) + (not (literal= (concat "\"\"\"" (charvalue con) + "\"\"\"^^" (datatype con)) + user-val))) constructs)))))) ;;elephant returns names, occurences, and variants if any string ;;value matches, so all duplicates have to be removed @@ -830,24 +839,53 @@ (get-item-by-any-id (value construct) :revision revision))))) +(defun split-literal-string (literal-string) + "Returns a list of the form (:value literal-value :datatype literal-type) + of a string literal-value^^literal-type." + (when (stringp literal-string) + (let ((str (cut-comment literal-string))) + (when (string-starts-with-one-of literal-string (list "\"" "'")) + (let* ((delimiter (cond ((string-starts-with str "'") "'") + ((string-starts-with str "\"\"\"") "\"\"\"") + (t "\""))) + (l-end (find-literal-end (subseq str (length delimiter)) delimiter)) + (l-value (subseq str (length delimiter) l-end)) + (l-rest (subseq str (+ (length delimiter) l-end))) + (l-type (if (string-starts-with l-rest "^^") + (subseq l-rest 2) + *xml-string*))) + (list :value l-value :datatype l-type)))))) + + (defun literal= (value-1 value-2) "Returns t if both arguments are equal. The equality function is searched in the table *equal-operators*." - (when (or (and (numberp value-1) (numberp value-2)) - (typep value-1 (type-of value-2)) - (typep value-2 (type-of value-1))) - (let ((operator (get-equal-operator value-1))) - (funcall operator value-1 value-2)))) + (let ((real-value-1 (let ((result (split-literal-string value-1))) + (if result + (cast-literal (getf result :value) + (getf result :datatype)) + value-1))) + (real-value-2 (let ((result (split-literal-string value-2))) + (if result + (cast-literal (getf result :value) + (getf result :datatype)) + value-2)))) + (when (or (and (numberp real-value-1) (numberp real-value-2)) + (typep value-1 (type-of real-value-2)) + (typep value-2 (type-of real-value-1))) + (let ((operator (get-equal-operator real-value-1))) + (funcall operator real-value-1 real-value-2))))) (defun filter-datatypable-by-value (construct literal-value literal-datatype) "A helper that compares the datatypable's charvalue with the passed literal value." (declare (d::DatatypableC construct) - (type (or Null String) literal-value literal-datatype)) + (type (or Null String) literal-datatype)) (when (or (not literal-datatype) (string= (datatype construct) literal-datatype)) - (if (not literal-value) + (if (and (not literal-value) + (string/= literal-datatype *xml-boolean*)) construct (handler-case (let ((occ-value (cast-literal (charvalue construct) @@ -869,7 +907,7 @@ "A helper that compares the occurrence's charvalue with the passed literal value." (declare (OccurrenceC occurrence) - (type (or Null String) literal-value literal-datatype)) + (type (or Null String) literal-datatype)) (filter-datatypable-by-value occurrence literal-value literal-datatype)) @@ -919,7 +957,8 @@ (by-literal (if literal-value (names-by-value construct #'(lambda(name) - (string= name literal-value)) + (literal= name literal-value)) + ;(string= name literal-value)) :revision revision) (names construct :revision revision))) (all-names (intersection by-type by-literal)) Modified: trunk/src/TM-SPARQL/sparql_parser.lisp ============================================================================== --- trunk/src/TM-SPARQL/sparql_parser.lisp (original) +++ trunk/src/TM-SPARQL/sparql_parser.lisp Thu Mar 31 07:34:18 2011 @@ -288,17 +288,21 @@ (triple-delimiters (list ". " ";" " " (string #\tab) (string #\newline) "}")) - (end-pos (search-first triple-delimiters - trimmed-str))) + (end-pos (search-first triple-delimiters trimmed-str))) (unless end-pos (error (make-sparql-parser-condition trimmed-str (original-query construct) "'. ', , ';' ' ', '\\t', '\\n' or '}'"))) (let* ((literal-number - (read-from-string (subseq trimmed-str 0 end-pos))) + (read-from-string + (let ((str-value (subseq trimmed-str 0 end-pos))) + (if (string-ends-with str-value ".") + (progn (decf end-pos) + (subseq str-value 0 (1- (length str-value)))) + str-value)))) (number-type (if (search "." (subseq trimmed-str 0 end-pos)) - *xml-double* ;could also be an xml:decimal, since the doucble has + *xml-double* ;could also be an xml:decimal, since the double has ;a bigger range it shouldn't matter *xml-integer*))) (unless (numberp literal-number) Modified: trunk/src/TM-SPARQL/tmsparql_core_psis.xtm ============================================================================== --- trunk/src/TM-SPARQL/tmsparql_core_psis.xtm (original) +++ trunk/src/TM-SPARQL/tmsparql_core_psis.xtm Thu Mar 31 07:34:18 2011 @@ -42,4 +42,7 @@ + + + Modified: trunk/src/base-tools/base-tools.lisp ============================================================================== --- trunk/src/base-tools/base-tools.lisp (original) +++ trunk/src/base-tools/base-tools.lisp Thu Mar 31 07:34:18 2011 @@ -113,20 +113,23 @@ (defun trim-whitespace-left (value) "Uses string-left-trim with a predefined character-list." - (declare (String value)) - (string-left-trim *white-space* value)) + (declare (type (or Null String) value)) + (when value + (string-left-trim *white-space* value))) (defun trim-whitespace-right (value) "Uses string-right-trim with a predefined character-list." - (declare (String value)) - (string-right-trim *white-space* value)) + (declare (type (or Null String) value)) + (when value + (string-right-trim *white-space* value))) (defun trim-whitespace (value) "Uses string-trim with a predefined character-list." - (declare (String value)) - (string-trim *white-space* value)) + (declare (type (or Null String) value)) + (when value + (string-trim *white-space* value))) (defun string-starts-with (str prefix &key (ignore-case nil)) Modified: trunk/src/constants.lisp ============================================================================== --- trunk/src/constants.lisp (original) +++ trunk/src/constants.lisp Thu Mar 31 07:34:18 2011 @@ -30,6 +30,7 @@ :*xml-decimal* :*xml-double* :*xml-integer* + :*xml-date* :*xml-uri* :*rdf2tm-ns* :*rdf-statement* @@ -109,6 +110,8 @@ (defparameter *xml-integer* "http://www.w3.org/2001/XMLSchema#integer") +(defparameter *xml-date* "http://www.w3.org/2001/XMLSchema#date") + (defparameter *xml-decimal* "http://www.w3.org/2001/XMLSchema#decimal") (defparameter *xml-double* "http://www.w3.org/2001/XMLSchema#double") Modified: trunk/src/isidorus.asd ============================================================================== --- trunk/src/isidorus.asd (original) +++ trunk/src/isidorus.asd Thu Mar 31 07:34:18 2011 @@ -149,6 +149,7 @@ (:static-file "reification_xtm1.0.xtm") (:static-file "reification_xtm2.0.xtm") (:static-file "reification.rdf") + (:static-file "sparql_test.xtm") (:file "atom-conf") (:file "unittests-constants" :depends-on ("dangling_topicref.xtm" Modified: trunk/src/unit_tests/sparql_test.lisp ============================================================================== --- trunk/src/unit_tests/sparql_test.lisp (original) +++ trunk/src/unit_tests/sparql_test.lisp Thu Mar 31 07:34:18 2011 @@ -1625,7 +1625,63 @@ "" "") :test #'string=)))))) - + + +(test test-all-1 + "Tests the entire module with the file sparql_test.xtm" + (with-fixture with-tm-filled-db ("data_base" *sparql_test.xtm*) + (tm-sparql:init-tm-sparql) + (let* ((q-1 (concat + "SELECT * WHERE { + ?subj1 \"Johann Wolfgang\". + ?subj2 'von Goethe'^^" + *xml-string* ". + ?subj3 '28.08.1749'^^" + *xml-date* ". + ?subj4 '22.03.1832'^^" + *xml-date* ". + ?subj5 82.0. + ?subj6 82. + ?subj7 '82'^^" *xml-integer* ". + ?subj8 true. + ?subj9 'true'^^" *xml-boolean* ". + ?subj10 'false'^^" *xml-boolean* ". + ?subj11 false" + "}")) + (r-1 (tm-sparql:result (make-instance 'TM-SPARQL:SPARQL-Query :query q-1)))) + (is-true (= (length r-1) 11)) + (map 'list #'(lambda(item) + (cond ((or (string= (getf item :variable) "subj1") + (string= (getf item :variable) "subj2") + (string= (getf item :variable) "subj3") + (string= (getf item :variable) "subj4") + (string= (getf item :variable) "subj6") + (string= (getf item :variable) "subj7") + (string= (getf item :variable) "subj8") + (string= (getf item :variable) "subj9")) + (is (string= (first (getf item :result)) + ""))) + ((or (string= (getf item :variable) "subj5") + (string= (getf item :variable) "subj10") + (string= (getf item :variable) "subj11")) + (is-false (getf item :result))) + (t + (is-true (format t "bad variable-name found"))))) + r-1)) + (is-true (d:get-item-by-psi "http://www.networkedplanet.com/tmsparql/topicProperty" + :revision 0)) + (is-true (d:get-item-by-psi "http://www.networkedplanet.com/tmsparql/reifier" + :revision 0)) + (is-true (d:get-item-by-psi "http://www.networkedplanet.com/tmsparql/role" + :revision 0)) + (is-true (d:get-item-by-psi "http://www.networkedplanet.com/tmsparql/player" + :revision 0)) + (is-true (d:get-item-by-psi "http://www.networkedplanet.com/tmsparql/scope" + :revision 0)) + (is-true (d:get-item-by-psi "http://www.networkedplanet.com/tmsparql/value" + :revision 0)) + (is-true (d:get-item-by-psi *rdf-type* :revision 0)))) + (defun run-sparql-tests () (it.bese.fiveam:run! 'sparql-test:sparql-tests)) Modified: trunk/src/unit_tests/sparql_test.xtm ============================================================================== --- trunk/src/unit_tests/sparql_test.xtm (original) +++ trunk/src/unit_tests/sparql_test.xtm Thu Mar 31 07:34:18 2011 @@ -73,7 +73,7 @@ - + @@ -117,6 +117,11 @@ + + + + + @@ -147,19 +152,23 @@ - 28.08.1749 + 28.08.1749 - 22.03.1832 + 22.03.1832 - 82 + 82 - true + true + + + + false Modified: trunk/src/unit_tests/unittests-constants.lisp ============================================================================== --- trunk/src/unit_tests/unittests-constants.lisp (original) +++ trunk/src/unit_tests/unittests-constants.lisp Thu Mar 31 07:34:18 2011 @@ -30,6 +30,7 @@ :*atom_test.xtm* :*atom-conf.lisp* :*poems.xtm* + :*sparql_test.xtm* :*poems_light.rdf* :*poems_light.xtm* :*poems_light.xtm.txt* @@ -105,6 +106,10 @@ (asdf:component-pathname (asdf:find-component *unit-tests-component* "poems.xtm"))) +(defparameter *sparql_test.xtm* + (asdf:component-pathname + (asdf:find-component *unit-tests-component* "sparql_test.xtm"))) + (defparameter *poems_light.rdf* (asdf:component-pathname (asdf:find-component *unit-tests-component* "poems_light.rdf")))